source: branches/ia32/lisp-kernel/x86-gc.c @ 9468

Last change on this file since 9468 was 9468, checked in by rme, 11 years ago

Correct off-by-one bug in update_self_references.

(You'd think I could write this routine correctly after three times...)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 122.1 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp_globals.h"
19#include "bits.h"
20#include "gc.h"
21#include "area.h"
22#include "Threads.h"
23#include <stddef.h>
24#include <stdlib.h>
25#include <string.h>
26#include <sys/time.h>
27
28#ifndef timeradd
29# define timeradd(a, b, result)                                               \
30  do {                                                                        \
31    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
32    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
33    if ((result)->tv_usec >= 1000000)                                         \
34      {                                                                       \
35        ++(result)->tv_sec;                                                   \
36        (result)->tv_usec -= 1000000;                                         \
37      }                                                                       \
38  } while (0)
39#endif
40#ifndef timersub
41# define timersub(a, b, result)                                               \
42  do {                                                                        \
43    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
44    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
45    if ((result)->tv_usec < 0) {                                              \
46      --(result)->tv_sec;                                                     \
47      (result)->tv_usec += 1000000;                                           \
48    }                                                                         \
49  } while (0)
50#endif
51
52void
53comma_output_decimal(char *buf, int len, natural n) 
54{
55  int nout = 0;
56
57  buf[--len] = 0;
58  do {
59    buf[--len] = n%10+'0';
60    n = n/10;
61    if (n == 0) {
62      while (len) {
63        buf[--len] = ' ';
64      }
65      return;
66    }
67    if (len == 0) return;
68    nout ++;
69    if (nout == 3) {
70      buf[--len] = ',';
71      nout = 0;
72    }
73  } while (len >= 0);
74}
75
76
77/* Heap sanity checking. */
78
79void
80check_node(LispObj n)
81{
82  int tag = fulltag_of(n), header_tag;
83  area *a;
84  LispObj header;
85
86  if (n == (n & 0xff)) {
87    return;
88  }
89
90  switch (tag) {
91  case fulltag_even_fixnum:
92  case fulltag_odd_fixnum:
93#ifdef X8632
94  case fulltag_imm:
95#endif
96#ifdef X8664
97  case fulltag_imm_0:
98  case fulltag_imm_1:
99#endif
100    return;
101
102#ifdef X8664
103  case fulltag_nil:
104    if (n != lisp_nil) {
105      Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n);
106    }
107    return;
108#endif
109
110#ifdef X8632
111  case fulltag_nodeheader:
112  case fulltag_immheader:
113#endif
114#ifdef X8664
115  case fulltag_nodeheader_0: 
116  case fulltag_nodeheader_1: 
117  case fulltag_immheader_0: 
118  case fulltag_immheader_1: 
119  case fulltag_immheader_2: 
120#endif
121    Bug(NULL, "Header not expected : 0x%lx", n);
122    return;
123
124#ifdef X8632
125  case fulltag_tra:
126#endif
127#ifdef X8664
128  case fulltag_tra_0:
129  case fulltag_tra_1:
130#endif
131    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
132    if (a == NULL) {
133      a = active_dynamic_area;
134      if ((n > (ptr_to_lispobj(a->active))) &&
135          (n < (ptr_to_lispobj(a->high)))) {
136        Bug(NULL, "TRA points to heap free space: 0x%lx", n);
137      }
138      return;
139    }
140    /* tra points into the heap.  Check displacement, then
141       check the function it (should) identify.
142    */
143#ifdef X8632
144    {
145      LispObj fun = 0;
146
147      if (*(unsigned char *)n == RECOVER_FN_OPCODE)
148        fun = *(LispObj *)(n + 1);
149      if (fun == 0 ||
150         (header_subtag(header_of(fun)) != subtag_function) ||
151         (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) {
152        Bug(NULL, "TRA at 0x%x has bad function address 0x%x\n", n, fun);
153      }
154      n = fun;
155    }
156#endif
157#ifdef X8664
158    {
159      int disp = 0;
160      LispObj m = n;
161
162      if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
163          (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
164        disp = (*(int *) (n+3));
165        n = RECOVER_FN_FROM_RIP_LENGTH+m+disp;
166      }
167      if ((disp == 0) ||
168          (fulltag_of(n) != fulltag_function) ||
169          (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) {
170        Bug(NULL, "TRA at 0x%lx has bad displacement %d\n", n, disp);
171      }
172    }
173#endif
174    /* Otherwise, fall through and check the header on the function
175       that the tra references */
176
177  case fulltag_misc:
178  case fulltag_cons:
179#ifdef X8664
180  case fulltag_symbol:
181  case fulltag_function:
182#endif
183    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
184   
185    if (a == NULL) {
186      /* Can't do as much sanity checking as we'd like to
187         if object is a defunct stack-consed object.
188         If a dangling reference to the heap, that's
189         bad .. */
190      a = active_dynamic_area;
191      if ((n > (ptr_to_lispobj(a->active))) &&
192          (n < (ptr_to_lispobj(a->high)))) {
193        Bug(NULL, "Node points to heap free space: 0x%lx", n);
194      }
195      return;
196    }
197    break;
198  }
199  /* Node points to heap area, so check header/lack thereof. */
200  header = header_of(n);
201  header_tag = fulltag_of(header);
202  if (tag == fulltag_cons) {
203    if ((nodeheader_tag_p(header_tag)) ||
204        (immheader_tag_p(header_tag))) {
205      Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header);
206    }
207    return;
208  }
209
210  if ((!nodeheader_tag_p(header_tag)) &&
211      (!immheader_tag_p(header_tag))) {
212    Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header);
213  }
214  return;
215}
216
217void
218check_all_mark_bits(LispObj *nodepointer) 
219{
220}
221
222
223Boolean GCDebug = true, GCverbose = true;
224
225
226
227void
228check_range(LispObj *start, LispObj *end, Boolean header_allowed)
229{
230  LispObj node, *current = start, *prev;
231  int tag;
232  natural elements;
233
234  while (current < end) {
235    prev = current;
236    node = *current++;
237    tag = fulltag_of(node);
238    if (immheader_tag_p(tag)) {
239      if (! header_allowed) {
240        Bug(NULL, "Header not expected at 0x%lx\n", prev);
241      }
242      current = (LispObj *)skip_over_ivector((natural)prev, node);
243    } else if (nodeheader_tag_p(tag)) {
244      if (! header_allowed) {
245        Bug(NULL, "Header not expected at 0x%lx\n", prev);
246      }
247      elements = header_element_count(node) | 1;
248      if (header_subtag(node) == subtag_function) {
249#ifdef X8632
250        int skip = *(unsigned short *)current;
251#else
252        int skip = *(int *)current;
253#endif
254        current += skip;
255        elements -= skip;
256      }
257      while (elements--) {
258        check_node(*current++);
259      }
260    } else {
261      check_node(node);
262      check_node(*current++);
263    }
264  }
265
266  if (current != end) {
267    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
268        start, end, prev, current);
269  }
270}
271
272void
273check_all_areas()
274{
275  area *a = active_dynamic_area;
276  area_code code = a->code;
277
278  while (code != AREA_VOID) {
279    switch (code) {
280    case AREA_DYNAMIC:
281    case AREA_STATIC:
282    case AREA_MANAGED_STATIC:
283      check_range((LispObj *)a->low, (LispObj *)a->active, true);
284      break;
285
286    case AREA_VSTACK:
287      {
288        LispObj* low = (LispObj *)a->active;
289        LispObj* high = (LispObj *)a->high;
290       
291        if (((natural)low) & node_size) {
292          check_node(*low++);
293        }
294        check_range(low, high, false);
295      }
296      break;
297
298    case AREA_TSTACK:
299      {
300        LispObj *current, *next,
301                *start = (LispObj *) a->active,
302                *end = start,
303                *limit = (LispObj *) a->high;
304                 
305        for (current = start;
306             end != limit;
307             current = next) {
308          next = ptr_from_lispobj(*current);
309          end = ((next >= start) && (next < limit)) ? next : limit;
310          check_range(current+2, end, true);
311        }
312      }
313      break;
314    }
315    a = a->succ;
316    code = (a->code);
317  }
318}
319
320natural
321static_dnodes_for_area(area *a)
322{
323  if (a->low == tenured_area->low) {
324    return tenured_area->static_dnodes;
325  }
326  return 0;
327}
328
329
330
331
332
333
334
335bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
336LispObj GCarealow, GCareadynamiclow;
337natural GCndnodes_in_area, GCndynamic_dnodes_in_area;
338LispObj GCweakvll = (LispObj)NULL;
339LispObj GCephemeral_low;
340natural GCn_ephemeral_dnodes;
341
342
343/* Sooner or later, this probably wants to be in assembler */
344/* Return false if n is definitely not an ephemeral node, true if
345   it might be */
346void
347mark_root(LispObj n)
348{
349  int tag_n = fulltag_of(n);
350  natural dnode, bits, *bitsp, mask;
351
352  if (!is_node_fulltag(tag_n)) {
353    return;
354  }
355
356#ifdef X8632
357  if (tag_n == fulltag_tra) {
358    if (*(unsigned char *)n == RECOVER_FN_OPCODE) {
359      n = *(LispObj *)(n + 1);
360      tag_n = fulltag_misc;
361    } else
362      return;
363  }
364#endif
365#ifdef X8664
366  if (tag_of(n) == tag_tra) {
367    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
368        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
369      int sdisp = (*(int *) (n+3));
370      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
371      tag_n = fulltag_function;
372    }
373    else {
374      return;
375    }
376  }
377#endif
378
379
380  dnode = gc_area_dnode(n);
381  if (dnode >= GCndnodes_in_area) {
382    return;
383  }
384  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
385  if (bits & mask) {
386    return;
387  }
388  *bitsp = (bits | mask);
389
390  if (tag_n == fulltag_cons) {
391    cons *c = (cons *) ptr_from_lispobj(untag(n));
392
393    rmark(c->car);
394    rmark(c->cdr);
395    return;
396  }
397  {
398    LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
399    natural
400      header = *((natural *) base),
401      subtag = header_subtag(header),
402      element_count = header_element_count(header),
403      total_size_in_bytes,      /* including 4/8-byte header */
404      suffix_dnodes;
405    natural prefix_nodes = 0;
406
407    tag_n = fulltag_of(header);
408
409#ifdef X8664
410    if ((nodeheader_tag_p(tag_n)) ||
411        (tag_n == ivector_class_64_bit)) {
412      total_size_in_bytes = 8 + (element_count<<3);
413    } else if (tag_n == ivector_class_32_bit) {
414      total_size_in_bytes = 8 + (element_count<<2);
415    } else {
416      /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */
417      if (subtag == subtag_bit_vector) {
418        total_size_in_bytes = 8 + ((element_count+7)>>3);
419      } else if (subtag >= min_8_bit_ivector_subtag) {
420        total_size_in_bytes = 8 + element_count;
421      } else {
422        total_size_in_bytes = 8 + (element_count<<1);
423      }
424    }
425#endif
426#ifdef X8632
427    if ((tag_n == fulltag_nodeheader) ||
428        (subtag <= max_32_bit_ivector_subtag)) {
429      total_size_in_bytes = 4 + (element_count<<2);
430    } else if (subtag <= max_8_bit_ivector_subtag) {
431      total_size_in_bytes = 4 + element_count;
432    } else if (subtag <= max_16_bit_ivector_subtag) {
433      total_size_in_bytes = 4 + (element_count<<1);
434    } else if (subtag == subtag_double_float_vector) {
435      total_size_in_bytes = 8 + (element_count<<3);
436    } else {
437      total_size_in_bytes = 4 + ((element_count+7)>>3);
438    }
439#endif
440
441
442    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1;
443
444    if (suffix_dnodes) {
445      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
446    }
447
448    if (nodeheader_tag_p(tag_n)) {
449      if (subtag == subtag_hash_vector) {
450        /* Don't invalidate the cache here.  It should get
451           invalidated on the lisp side, if/when we know
452           that rehashing is necessary. */
453        LispObj flags = ((hash_table_vector_header *) base)->flags;
454
455        if (flags & nhash_weak_mask) {
456          ((hash_table_vector_header *) base)->cache_key = undefined;
457          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
458        }
459        deref(ptr_to_lispobj(base),1) = GCweakvll;
460        GCweakvll = n;
461        return;
462      }
463
464      if (subtag == subtag_pool) {
465        deref(ptr_to_lispobj(base), 1) = lisp_nil;
466      }
467     
468      if (subtag == subtag_weak) {
469        natural weak_type = (natural) base[2];
470        if (weak_type >> population_termination_bit) {
471          element_count -= 2;
472        } else {
473          element_count -= 1;
474        }
475      }
476
477      if (subtag == subtag_function) {
478#ifdef X8632
479        prefix_nodes = (natural) ((unsigned short) deref(base,1));
480#else
481        prefix_nodes = (natural) ((int) deref(base,1));
482#endif
483        if (prefix_nodes > element_count) {
484          Bug(NULL, "Function 0x%lx trashed",n);
485        }
486      }
487      base += (1+element_count);
488
489      element_count -= prefix_nodes;
490
491      while(element_count--) {
492        rmark(*--base);
493      }
494      if (subtag == subtag_weak) {
495        deref(ptr_to_lispobj(base),1) = GCweakvll;
496        GCweakvll = n;
497      }
498    }
499  }
500}
501
502
503/*
504  This marks the node if it needs to; it returns true if the node
505  is either a hash table vector header or a cons/misc-tagged pointer
506  to ephemeral space.
507  Note that it  might be a pointer to ephemeral space even if it's
508  not pointing to the current generation.
509*/
510
511Boolean
512mark_ephemeral_root(LispObj n)
513{
514  int tag_n = fulltag_of(n);
515  natural eph_dnode;
516
517  if (nodeheader_tag_p(tag_n)) {
518    return (header_subtag(n) == subtag_hash_vector);
519  }
520 
521  if (is_node_fulltag (tag_n)) {
522    eph_dnode = area_dnode(n, GCephemeral_low);
523    if (eph_dnode < GCn_ephemeral_dnodes) {
524      mark_root(n);             /* May or may not mark it */
525      return true;              /* but return true 'cause it's an ephemeral node */
526    }
527  }
528  return false;                 /* Not a heap pointer or not ephemeral */
529}
530 
531
532
533#ifdef X8664
534#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */
535#define RMARK_PREV_CAR fulltag_nil /* fulltag_nil + node_size. Coincidence ? I think not. */
536#else
537#define RMARK_PREV_ROOT fulltag_imm
538#define RMARK_PREV_CAR fulltag_immheader
539#endif
540
541natural
542GCstack_limit = 0;
543
544/*
545  This wants to be in assembler even more than "mark_root" does.
546  For now, it does link-inversion: hard as that is to express in C,
547  reliable stack-overflow detection may be even harder ...
548*/
549void
550rmark(LispObj n)
551{
552  int tag_n = fulltag_of(n);
553  bitvector markbits = GCmarkbits;
554  natural dnode, bits, *bitsp, mask, original_n = n;
555
556  if (!is_node_fulltag(tag_n)) {
557    return;
558  }
559
560#ifdef X8632
561  if (tag_n == fulltag_tra) {
562    if (*(unsigned char *)n == RECOVER_FN_OPCODE) {
563      n = *(LispObj *)(n + 1);
564      tag_n = fulltag_misc;
565    } else {
566      return;
567    }
568  }
569#endif
570#ifdef X8664
571  if (tag_of(n) == tag_tra) {
572    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
573        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
574      int sdisp = (*(int *) (n+3));
575      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
576      tag_n = fulltag_function;
577    } else {
578      return;
579    }
580  }
581#endif
582
583  dnode = gc_area_dnode(n);
584  if (dnode >= GCndnodes_in_area) {
585    return;
586  }
587  set_bits_vars(markbits,dnode,bitsp,bits,mask);
588  if (bits & mask) {
589    return;
590  }
591  *bitsp = (bits | mask);
592
593  if (current_stack_pointer() > GCstack_limit) {
594    if (tag_n == fulltag_cons) {
595      rmark(deref(n,1));
596      rmark(deref(n,0));
597    } else {
598      LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
599      natural
600        header = *((natural *) base),
601        subtag = header_subtag(header),
602        element_count = header_element_count(header),
603        total_size_in_bytes,
604        suffix_dnodes,
605        nmark;
606
607      tag_n = fulltag_of(header);
608
609#ifdef X8664
610      if ((nodeheader_tag_p(tag_n)) ||
611          (tag_n == ivector_class_64_bit)) {
612        total_size_in_bytes = 8 + (element_count<<3);
613      } else if (tag_n == ivector_class_32_bit) {
614        total_size_in_bytes = 8 + (element_count<<2);
615      } else {
616        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
617        if (subtag == subtag_bit_vector) {
618          total_size_in_bytes = 8 + ((element_count+7)>>3);
619        } else if (subtag >= min_8_bit_ivector_subtag) {
620          total_size_in_bytes = 8 + element_count;
621        } else {
622          total_size_in_bytes = 8 + (element_count<<1);
623        }
624      }
625#else
626      if ((tag_n == fulltag_nodeheader) ||
627          (subtag <= max_32_bit_ivector_subtag)) {
628        total_size_in_bytes = 4 + (element_count<<2);
629      } else if (subtag <= max_8_bit_ivector_subtag) {
630        total_size_in_bytes = 4 + element_count;
631      } else if (subtag <= max_16_bit_ivector_subtag) {
632        total_size_in_bytes = 4 + (element_count<<1);
633      } else if (subtag == subtag_double_float_vector) {
634        total_size_in_bytes = 8 + (element_count<<3);
635      } else {
636        total_size_in_bytes = 4 + ((element_count+7)>>3);
637      }
638#endif
639
640      suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
641
642      if (suffix_dnodes) {
643        set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
644      }
645
646      if (!nodeheader_tag_p(tag_n)) return;
647
648      if (subtag == subtag_hash_vector) {
649        /* Splice onto weakvll, then return */
650        /* In general, there's no reason to invalidate the cached
651           key/value pair here.  However, if the hash table's weak,
652           we don't want to retain an otherwise unreferenced key
653           or value simply because they're referenced from the
654           cache.  Clear the cached entries iff the hash table's
655           weak in some sense.
656        */
657        LispObj flags = ((hash_table_vector_header *) base)->flags;
658
659        if (flags & nhash_weak_mask) {
660          ((hash_table_vector_header *) base)->cache_key = undefined;
661          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
662        }
663        deref(ptr_to_lispobj(base),1) = GCweakvll;
664        GCweakvll = n;
665        return;
666      }
667
668      if (subtag == subtag_pool) {
669        deref(n, 1) = lisp_nil;
670      }
671
672      if (subtag == subtag_weak) {
673        natural weak_type = (natural) base[2];
674        if (weak_type >> population_termination_bit)
675          element_count -= 2;
676        else
677          element_count -= 1;
678      }
679
680      nmark = element_count;
681
682      if (subtag == subtag_function) {
683#ifdef X8664
684        int code_words = (int)base[1];
685#else
686        int code_words = (unsigned short)base[1];
687#endif
688        if (code_words >= nmark) {
689          Bug(NULL,"Bad function at 0x%lx",n);
690        }
691        nmark -= code_words;
692      }
693
694      while (nmark--) {
695        rmark(deref(n,element_count));
696        element_count--;
697      }
698
699      if (subtag == subtag_weak) {
700        deref(n, 1) = GCweakvll;
701        GCweakvll = n;
702      }
703
704    }
705  } else {
706#ifdef X8632
707    fprintf(stderr, "probably in trouble here\n");
708#endif
709    /* This is all a bit more complicated than the PPC version:
710
711       - a symbol-vector can be referenced via either a FULLTAG-MISC
712       pointer or a FULLTAG-SYMBOL pointer.  When we've finished
713       marking the symbol-vector's elements, we need to know which tag
714       the object that pointed to the symbol-vector had originally.
715
716       - a function-vector can be referenced via either a FULLTAG-MISC
717       pointer or a FULLTAG-FUNCTION pointer.  That introduces pretty
718       much the same set of issues, but ...
719
720       - a function-vector can also be referenced via a TRA; the
721       offset from the TRA to the function header is arbitrary (though
722       we can probably put an upper bound on it, and it's certainly
723       not going to be more than 32 bits.)
724
725       - function-vectors contain a mixture of code and constants,
726       with a "boundary" word (that doesn't look like a valid
727       constant) in between them.  There are 56 unused bits in the
728       boundary word; the low 8 bits must be = to the constant
729       'function_boundary_marker'.  We can store the byte displacement
730       from the address of the object which references the function
731       (tagged fulltag_misc, fulltag_function, or tra) to the address
732       of the boundary marker when the function vector is first marked
733       and recover that offset when we've finished marking the
734       function vector.  (Note that the offset is signed; it's
735       probably simplest to keep it in the high 32 bits of the
736       boundary word.)
737
738 So:
739
740       - while marking a CONS, the 'this' pointer as a 3-bit tag of
741       tag_list; the 4-bit fulltag indicates which cell is being
742       marked.
743
744       - while marking a gvector (other than a symbol-vector or
745       function-vector), the 'this' pointer is tagged tag_misc.
746       (Obviously, it alternates between fulltag_misc and
747       fulltag_nodeheader_0, arbitrarily.)  When we encounter the
748       gvector header when the 'this' pointer has been tagged as
749       fulltag_misc, we can restore 'this' to the header's address +
750       fulltag_misc and enter the 'climb' state.  (Note that this
751       value happens to be exactly what's in 'this' when the header's
752       encountered.)
753
754       - if we encounter a symbol-vector via the FULLTAG-MISC pointer
755       to the symbol (not very likely, but legal and possible), it's
756       treated exactly like the gvector case above.
757
758       - in the more likely case where a symbol-vector is referenced
759       via a FULLTAG-SYMBOL, we do the same loop as in the general
760       gvector case, backing up through the vector with 'this' tagged
761       as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter
762       the symbol header, 'this' gets fulltag_symbol added to the
763       dnode-aligned address of the header, and we climb.
764
765       - if anything (fulltag_misc, fulltag_function, tra) references
766       an unmarked function function vector, we store the byte offfset
767       from the tagged reference to the address of the boundary word
768       in the high 32 bits of the boundary word, then we back up
769       through the function-vector's constants, with 'this' tagged
770       tag_function/ fulltag_immheader_0, until the (specially-tagged)
771       boundary word is encountered.  The displacement stored in the boundary
772       word is added to the aligned address of the  boundary word (restoring
773       the original 'this' pointer, and we climb.
774
775       Not that bad.
776    */
777       
778    LispObj prev = undefined, this = n, next, *base;
779    natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary;
780
781    if (tag_n == fulltag_cons) goto MarkCons;
782    goto MarkVector;
783
784  ClimbCdr:
785    prev = deref(this,0);
786    deref(this,0) = next;
787
788  Climb:
789    next = this;
790    this = prev;
791    tag_n = fulltag_of(prev);
792    switch(tag_n) {
793    case tag_misc:
794    case fulltag_misc:
795#ifdef X8664
796    case tag_symbol:
797    case fulltag_symbol:
798    case tag_function:
799    case fulltag_function:
800#endif
801      goto ClimbVector;
802
803    case RMARK_PREV_ROOT:
804      return;
805
806    case fulltag_cons:
807      goto ClimbCdr;
808
809    case RMARK_PREV_CAR:
810      goto ClimbCar;
811
812      /* default: abort() */
813    }
814
815  DescendCons:
816    prev = this;
817    this = next;
818
819  MarkCons:
820    next = deref(this,1);
821    this += node_size;
822    tag_n = fulltag_of(next);
823    if (!is_node_fulltag(tag_n)) goto MarkCdr;
824    dnode = gc_area_dnode(next);
825    if (dnode >= GCndnodes_in_area) goto MarkCdr;
826    set_bits_vars(markbits,dnode,bitsp,bits,mask);
827    if (bits & mask) goto MarkCdr;
828    *bitsp = (bits | mask);
829    deref(this,1) = prev;
830    if (tag_n == fulltag_cons) goto DescendCons;
831    goto DescendVector;
832
833  ClimbCar:
834    prev = deref(this,1);
835    deref(this,1) = next;
836
837  MarkCdr:
838    next = deref(this, 0);
839    this -= node_size;
840    tag_n = fulltag_of(next);
841    if (!is_node_fulltag(tag_n)) goto Climb;
842    dnode = gc_area_dnode(next);
843    if (dnode >= GCndnodes_in_area) goto Climb;
844    set_bits_vars(markbits,dnode,bitsp,bits,mask);
845    if (bits & mask) goto Climb;
846    *bitsp = (bits | mask);
847    deref(this, 0) = prev;
848    if (tag_n == fulltag_cons) goto DescendCons;
849    /* goto DescendVector; */
850
851  DescendVector:
852    prev = this;
853    this = next;
854
855  MarkVector:
856#ifdef X8664
857    if ((tag_n == fulltag_tra_0) ||
858        (tag_n == fulltag_tra_1)) {
859      int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH;
860
861      base = (LispObj *) (untag(n-disp));
862      header = *((natural *) base);
863      subtag = header_subtag(header);
864      boundary = base + (int)(base[1]);
865      (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
866      this = (LispObj)(base)+fulltag_function;
867      /* Need to set the initial markbit here */
868      dnode = gc_area_dnode(this);
869      set_bit(markbits,dnode);
870    } else {
871      base = (LispObj *) ptr_from_lispobj(untag(this));
872      header = *((natural *) base);
873      subtag = header_subtag(header);
874      if (subtag == subtag_function) {
875        boundary = base + (int)(base[1]);
876        (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
877      }
878    }
879    element_count = header_element_count(header);
880    tag_n = fulltag_of(header);
881
882    if ((nodeheader_tag_p(tag_n)) ||
883        (tag_n == ivector_class_64_bit)) {
884      total_size_in_bytes = 8 + (element_count<<3);
885    } else if (tag_n == ivector_class_32_bit) {
886      total_size_in_bytes = 8 + (element_count<<2);
887    } else {
888      /* ivector_class_other_bit contains 16-bit arrays & bitvector */
889      if (subtag == subtag_bit_vector) {
890        total_size_in_bytes = 8 + ((element_count+7)>>3);
891      } else if (subtag >= min_8_bit_ivector_subtag) {
892        total_size_in_bytes = 8 + element_count;
893      } else {
894        total_size_in_bytes = 8 + (element_count<<1);
895      }
896    }
897#else
898    if (tag_n == fulltag_tra) {
899      LispObj fn = *(LispObj *)(n + 1);
900
901      base = (LispObj *)untag(fn);
902      header = *(natural *)base;
903      subtag = header_subtag(header);
904      boundary = base + (unsigned short)base[1];
905      /*
906       * On x8632, the upper 24 bits of the boundary word are zero.
907       * Functions on x8632 can be no more than 2^16 words (or 2^24
908       * bytes) long (including the self-reference table but excluding
909       * any constants).  Therefore, we can do the same basic thing
910       * that the x8664 port does: namely, we keep the byte
911       * displacement from the address of the object (tagged tra or
912       * fulltag_misc) that references the function to the address of
913       * the boundary marker in those 24 bits, recovering it when
914       * we've finished marking the function vector.
915       */
916      ((int *)boundary)[1] &= 0xff;
917      ((int *)boundary)[1] |= (this-(LispObj)boundary) << 8;
918      this = (LispObj)(base)+fulltag_misc;
919      dnode = gc_area_dnode(this);
920      set_bit(markbits,dnode);
921    } else {
922      base = (LispObj *) ptr_from_lispobj(untag(this));
923      header = *((natural *) base);
924      subtag = header_subtag(header);
925      if (subtag == subtag_function) {
926        boundary = base + (unsigned short)base[1];
927        ((int *)boundary)[1] &= 0xff;
928        ((int *)boundary)[1] |= (this-((LispObj)boundary)) << 8;
929      }
930    }
931    element_count = header_element_count(header);
932    tag_n = fulltag_of(header);
933
934    if ((tag_n == fulltag_nodeheader) ||
935        (subtag <= max_32_bit_ivector_subtag)) {
936      total_size_in_bytes = 4 + (element_count<<2);
937    } else if (subtag <= max_8_bit_ivector_subtag) {
938      total_size_in_bytes = 4 + element_count;
939    } else if (subtag <= max_16_bit_ivector_subtag) {
940      total_size_in_bytes = 4 + (element_count<<1);
941    } else if (subtag == subtag_double_float_vector) {
942      total_size_in_bytes = 8 + (element_count<<3);
943    } else {
944      total_size_in_bytes = 4 + ((element_count+7)>>3);
945    }
946#endif
947
948    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
949   
950    if (suffix_dnodes) {
951      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
952    }
953   
954    if (!nodeheader_tag_p(tag_n)) goto Climb;
955   
956    if (subtag == subtag_hash_vector) {
957      /* Splice onto weakvll, then climb */
958      LispObj flags = ((hash_table_vector_header *) base)->flags;
959     
960      if (flags & nhash_weak_mask) {
961        ((hash_table_vector_header *) base)->cache_key = undefined;
962        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
963      }
964
965      deref(ptr_to_lispobj(base),1) = GCweakvll;
966      GCweakvll = this;
967      goto Climb;
968    }
969
970    if (subtag == subtag_pool) {
971      deref(this, 1) = lisp_nil;
972    }
973
974    if (subtag == subtag_weak) {
975      natural weak_type = (natural) base[2];
976      if (weak_type >> population_termination_bit)
977        element_count -= 2;
978      else
979        element_count -= 1;
980    }
981
982    this = (LispObj)(base) + (tag_of(this))  + ((element_count+1) << node_shift);
983    goto MarkVectorLoop;
984
985  ClimbVector:
986    prev = indirect_node(this);
987    indirect_node(this) = next;
988
989  MarkVectorLoop:
990    this -= node_size;
991    next = indirect_node(this);
992#ifdef X8664
993    if ((tag_of(this) == tag_function) &&
994        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
995#else
996    if ((tag_of(this) == tag_misc) &&
997        (header_subtag(this) == subtag_function) &&
998        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
999#endif
1000
1001    tag_n = fulltag_of(next);
1002    if (nodeheader_tag_p(tag_n)) goto MarkVectorDone;
1003    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
1004    dnode = gc_area_dnode(next);
1005    if (dnode >= GCndnodes_in_area) goto MarkVectorLoop;
1006    set_bits_vars(markbits,dnode,bitsp,bits,mask);
1007    if (bits & mask) goto MarkVectorLoop;
1008    *bitsp = (bits | mask);
1009    indirect_node(this) = prev;
1010    if (tag_n == fulltag_cons) goto DescendCons;
1011    goto DescendVector;
1012
1013  MarkVectorDone:
1014    /* "next" is vector header; "this" tagged tag_misc or tag_symbol.
1015       If  header subtag = subtag_weak_header, put it on weakvll */
1016    this += node_size;          /* make it fulltag_misc/fulltag_symbol */
1017
1018    if (header_subtag(next) == subtag_weak) {
1019      deref(this, 1) = GCweakvll;
1020      GCweakvll = this;
1021    }
1022    goto Climb;
1023
1024  MarkFunctionDone:
1025    boundary = (LispObj *)(node_aligned(this));
1026#ifdef X8664
1027    this = ((LispObj)boundary) + (((int *)boundary)[1]);
1028    (((int *)boundary)[1]) = 0;
1029#else
1030    this = ((LispObj)boundary) + ((int *)boundary)[1] >> 8;
1031    ((int *)boundary)[1] &= 0xff;
1032    goto Climb;
1033#endif
1034  }
1035}
1036
1037LispObj *
1038skip_over_ivector(natural start, LispObj header)
1039{
1040  natural
1041    element_count = header_element_count(header),
1042    subtag = header_subtag(header),
1043    nbytes;
1044
1045
1046#ifdef X8664
1047  switch (fulltag_of(header)) {
1048  case ivector_class_64_bit:
1049    nbytes = element_count << 3;
1050    break;
1051  case ivector_class_32_bit:
1052    nbytes = element_count << 2;
1053    break;
1054  case ivector_class_other_bit:
1055  default:
1056    if (subtag == subtag_bit_vector) {
1057      nbytes = (element_count+7)>>3;
1058    } else if (subtag >= min_8_bit_ivector_subtag) {
1059      nbytes = element_count;
1060    } else {
1061      nbytes = element_count << 1;
1062    }
1063  }
1064  return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15)));
1065#else
1066  if (subtag <= max_32_bit_ivector_subtag) {
1067    nbytes = element_count << 2;
1068  } else if (subtag <= max_8_bit_ivector_subtag) {
1069    nbytes = element_count;
1070  } else if (subtag <= max_16_bit_ivector_subtag) {
1071    nbytes = element_count << 1;
1072  } else if (subtag == subtag_double_float_vector) {
1073    nbytes = 4 + (element_count << 3);
1074  } else {
1075    nbytes = (element_count+7) >> 3;
1076  }
1077  return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7)));
1078#endif
1079}
1080
1081
1082void
1083check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
1084{
1085  LispObj x1, *base = start, *prev = start;
1086  int tag;
1087  natural ref_dnode, node_dnode;
1088  Boolean intergen_ref;
1089
1090  while (start < end) {
1091    x1 = *start;
1092    prev = start;
1093    tag = fulltag_of(x1);
1094    if (immheader_tag_p(tag)) {
1095      start = skip_over_ivector(ptr_to_lispobj(start), x1);
1096    } else {
1097      if (header_subtag(x1) == subtag_function) {
1098        int skip = (int) deref(start,1);
1099        start += ((1+skip)&~1);
1100        x1 = *start;
1101        tag = fulltag_of(x1);
1102      }
1103      intergen_ref = false;
1104      if (is_node_fulltag(tag)) {       
1105        node_dnode = gc_area_dnode(x1);
1106        if (node_dnode < GCndnodes_in_area) {
1107          intergen_ref = true;
1108        }
1109      }
1110      if (intergen_ref == false) {       
1111        x1 = start[1];
1112        tag = fulltag_of(x1);
1113      if (is_node_fulltag(tag)) {       
1114          node_dnode = gc_area_dnode(x1);
1115          if (node_dnode < GCndnodes_in_area) {
1116            intergen_ref = true;
1117          }
1118        }
1119      }
1120      if (intergen_ref) {
1121        ref_dnode = area_dnode(start, base);
1122        if (!ref_bit(refbits, ref_dnode)) {
1123          Bug(NULL, "Missing memoization in doublenode at 0x%08X", start);
1124          set_bit(refbits, ref_dnode);
1125        }
1126      }
1127      start += 2;
1128    }
1129  }
1130  if (start > end) {
1131    Bug(NULL, "Overran end of range!");
1132  }
1133}
1134
1135
1136
1137void
1138mark_memoized_area(area *a, natural num_memo_dnodes)
1139{
1140  bitvector refbits = a->refbits;
1141  LispObj *p = (LispObj *) a->low, x1, x2;
1142  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
1143  Boolean keep_x1, keep_x2;
1144
1145  if (GCDebug) {
1146    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1147  }
1148
1149  /* The distinction between "inbits" and "outbits" is supposed to help us
1150     detect cases where "uninteresting" setfs have been memoized.  Storing
1151     NIL, fixnums, immediates (characters, etc.) or node pointers to static
1152     or readonly areas is definitely uninteresting, but other cases are
1153     more complicated (and some of these cases are hard to detect.)
1154
1155     Some headers are "interesting", to the forwarder if not to us.
1156
1157     We -don't- give anything any weak treatment here.  Weak things have
1158     to be seen by a full gc, for some value of 'full'.
1159     */
1160
1161  /*
1162    We need to ensure that there are no bits set at or beyond
1163    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
1164    tenures/untenures things.)  We find bits by grabbing a fullword at
1165    a time and doing a cntlzw instruction; and don't want to have to
1166    check for (< memo_dnode num_memo_dnodes) in the loop.
1167    */
1168
1169  {
1170    natural
1171      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
1172      index_of_last_word = (num_memo_dnodes >> bitmap_shift);
1173
1174    if (bits_in_last_word != 0) {
1175      natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L);
1176      refbits[index_of_last_word] &= mask;
1177    }
1178  }
1179       
1180  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1181  inbits = outbits = bits;
1182  while (memo_dnode < num_memo_dnodes) {
1183    if (bits == 0) {
1184      int remain = nbits_in_word - bitidx;
1185      memo_dnode += remain;
1186      p += (remain+remain);
1187      if (outbits != inbits) {
1188        *bitsp = outbits;
1189      }
1190      bits = *++bitsp;
1191      inbits = outbits = bits;
1192      bitidx = 0;
1193    } else {
1194      nextbit = count_leading_zeros(bits);
1195      if ((diff = (nextbit - bitidx)) != 0) {
1196        memo_dnode += diff;
1197        bitidx = nextbit;
1198        p += (diff+diff);
1199      }
1200      x1 = *p++;
1201      x2 = *p++;
1202      bits &= ~(BIT0_MASK >> bitidx);
1203      keep_x1 = mark_ephemeral_root(x1);
1204      keep_x2 = mark_ephemeral_root(x2);
1205      if ((keep_x1 == false) && 
1206          (keep_x2 == false)) {
1207        outbits &= ~(BIT0_MASK >> bitidx);
1208      }
1209      memo_dnode++;
1210      bitidx++;
1211    }
1212  }
1213  if (GCDebug) {
1214    p = (LispObj *) a->low;
1215    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1216  }
1217}
1218
1219void
1220mark_headerless_area_range(LispObj *start, LispObj *end)
1221{
1222  while (start < end) {
1223    mark_root(*start++);
1224  }
1225}
1226
1227void
1228mark_simple_area_range(LispObj *start, LispObj *end)
1229{
1230  LispObj x1, *base;
1231  int tag;
1232
1233  while (start < end) {
1234    x1 = *start;
1235    tag = fulltag_of(x1);
1236    if (immheader_tag_p(tag)) {
1237      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
1238    } else if (!nodeheader_tag_p(tag)) {
1239      ++start;
1240      mark_root(x1);
1241      mark_root(*start++);
1242    } else {
1243      int subtag = header_subtag(x1);
1244      natural element_count = header_element_count(x1);
1245      natural size = (element_count+1 + 1) & ~1;
1246
1247      if (subtag == subtag_hash_vector) {
1248        LispObj flags = ((hash_table_vector_header *) start)->flags;
1249
1250        if (flags & nhash_weak_mask) {
1251          ((hash_table_vector_header *) start)->cache_key = undefined;
1252          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1253        }
1254
1255        start[1] = GCweakvll;
1256        GCweakvll = (LispObj) (((natural) start) + fulltag_misc);
1257      } else {
1258
1259        if (subtag == subtag_pool) {
1260          start[1] = lisp_nil;
1261        }
1262
1263        if (subtag == subtag_weak) {
1264          natural weak_type = (natural) start[2];
1265          if (weak_type >> population_termination_bit)
1266            element_count -= 2;
1267          else
1268            element_count -= 1; 
1269          start[1] = GCweakvll;
1270          GCweakvll = (LispObj) (((natural) start) + fulltag_misc);   
1271        }
1272
1273        base = start + element_count + 1;
1274        if (subtag == subtag_function) {
1275#ifdef X8632
1276          element_count -= (unsigned short)start[1];
1277#else
1278          element_count -= (int)start[1];
1279#endif
1280        }
1281        while(element_count--) {
1282          mark_root(*--base);
1283        }
1284      }
1285      start += size;
1286    }
1287  }
1288}
1289
1290
1291/* Mark a tstack area */
1292void
1293mark_tstack_area(area *a)
1294{
1295  LispObj
1296    *current,
1297    *next,
1298    *start = (LispObj *) (a->active),
1299    *end = start,
1300    *limit = (LispObj *) (a->high);
1301
1302  for (current = start;
1303       end != limit;
1304       current = next) {
1305    next = (LispObj *) ptr_from_lispobj(*current);
1306    end = ((next >= start) && (next < limit)) ? next : limit;
1307    mark_simple_area_range(current+2, end);
1308  }
1309}
1310
1311/*
1312  It's really important that headers never wind up in tagged registers.
1313  Those registers would (possibly) get pushed on the vstack and confuse
1314  the hell out of this routine.
1315
1316  vstacks are just treated as a "simple area range", possibly with
1317  an extra word at the top (where the area's active pointer points.)
1318  */
1319
1320void
1321mark_vstack_area(area *a)
1322{
1323  LispObj
1324    *start = (LispObj *) a->active,
1325    *end = (LispObj *) a->high;
1326
1327#if 0
1328  fprintf(stderr, "mark VSP range: 0x%lx:0x%lx\n", start, end);
1329#endif
1330  mark_headerless_area_range(start, end);
1331}
1332
1333
1334void
1335reapweakv(LispObj weakv)
1336{
1337  /*
1338    element 2 of the weak vector should be tagged as a cons: if it
1339    isn't, just mark it as a root.  if it is, cdr through it until a
1340    "marked" cons is encountered.  If the car of any unmarked cons is
1341    marked, mark the cons which contains it; otherwise, splice the
1342    cons out of the list.  N.B. : elements 0 and 1 are already marked
1343    (or are immediate, etc.)
1344  */
1345  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
1346  LispObj termination_list = lisp_nil;
1347  natural weak_type = (natural) deref(weakv,2);
1348  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
1349    terminatablep = ((weak_type >> population_termination_bit) != 0);
1350  Boolean done = false;
1351  cons *rawcons;
1352  natural dnode, car_dnode;
1353  bitvector markbits = GCmarkbits;
1354
1355  if (terminatablep) {
1356    termination_list = deref(weakv,1+3);
1357  }
1358
1359  if (fulltag_of(cell) != fulltag_cons) {
1360    mark_root(cell);
1361  } else if (alistp) {
1362    /* weak alist */
1363    while (! done) {
1364      dnode = gc_area_dnode(cell);
1365      if ((dnode >= GCndnodes_in_area) ||
1366          (ref_bit(markbits, dnode))) {
1367        done = true;
1368      } else {
1369        /* Cons cell is unmarked. */
1370        LispObj alist_cell, thecar;
1371        unsigned cell_tag;
1372
1373        rawcons = (cons *) ptr_from_lispobj(untag(cell));
1374        alist_cell = rawcons->car;
1375        cell_tag = fulltag_of(alist_cell);
1376
1377        if ((cell_tag == fulltag_cons) &&
1378            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
1379            (! ref_bit(markbits, car_dnode)) &&
1380            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
1381            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
1382            (! ref_bit(markbits, car_dnode))) {
1383          *prev = rawcons->cdr;
1384          if (terminatablep) {
1385            rawcons->cdr = termination_list;
1386            termination_list = cell;
1387          }
1388        } else {
1389          set_bit(markbits, dnode);
1390          prev = (LispObj *)(&(rawcons->cdr));
1391          mark_root(alist_cell);
1392        }
1393        cell = *prev;
1394      }
1395    }
1396  } else {
1397    /* weak list */
1398    while (! done) {
1399      dnode = gc_area_dnode(cell);
1400      if ((dnode >= GCndnodes_in_area) ||
1401          (ref_bit(markbits, dnode))) {
1402        done = true;
1403      } else {
1404        /* Cons cell is unmarked. */
1405        LispObj thecar;
1406        unsigned cartag;
1407
1408        rawcons = (cons *) ptr_from_lispobj(untag(cell));
1409        thecar = rawcons->car;
1410        cartag = fulltag_of(thecar);
1411
1412        if (is_node_fulltag(cartag) &&
1413            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
1414            (! ref_bit(markbits, car_dnode))) {
1415          *prev = rawcons->cdr;
1416          if (terminatablep) {
1417            rawcons->cdr = termination_list;
1418            termination_list = cell;
1419          }
1420        } else {
1421          set_bit(markbits, dnode);
1422          prev = (LispObj *)(&(rawcons->cdr));
1423        }
1424        cell = *prev;
1425      }
1426    }
1427  }
1428
1429  if (terminatablep) {
1430    deref(weakv,1+3) = termination_list;
1431    if (termination_list != lisp_nil) {
1432      deref(weakv,1) = GCweakvll;
1433      GCweakvll = weakv;
1434    }
1435  }
1436}
1437
1438/*
1439  Screw: doesn't deal with finalization.
1440  */
1441
1442void
1443reaphashv(LispObj hashv)
1444{
1445  hash_table_vector_header
1446    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
1447  natural
1448    dnode,
1449    npairs = (header_element_count(hashp->header) - 
1450              ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1;
1451  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
1452  Boolean
1453    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
1454  bitvector markbits = GCmarkbits;
1455  int tag;
1456
1457  while (npairs--) {
1458    if (weak_on_value) {
1459      weakelement = pairp[1];
1460    } else {
1461      weakelement = pairp[0];
1462    }
1463    tag = fulltag_of(weakelement);
1464    if (is_node_fulltag(tag)) {
1465      dnode = gc_area_dnode(weakelement);
1466      if ((dnode < GCndnodes_in_area) && 
1467          ! ref_bit(markbits, dnode)) {
1468        pairp[0] = slot_unbound;
1469        pairp[1] = lisp_nil;
1470        hashp->weak_deletions_count += (1<<fixnumshift);
1471      }
1472    }
1473    pairp += 2;
1474  }
1475}   
1476   
1477
1478
1479Boolean
1480mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
1481{
1482  natural flags = hashp->flags, key_dnode, val_dnode;
1483  Boolean
1484    marked_new = false, 
1485    key_marked,
1486    val_marked,
1487    weak_value = ((flags & nhash_weak_value_mask) != 0);
1488  int 
1489    skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1,
1490    key_tag,
1491    val_tag,
1492    i;
1493  LispObj
1494    *pairp = (LispObj*) (hashp+1),
1495    key,
1496    val;
1497
1498  /* Mark everything in the header */
1499 
1500  for (i = 2; i<= skip; i++) {
1501    mark_root(deref(ptr_to_lispobj(hashp),i));
1502  }
1503
1504  elements -= skip;
1505
1506  for (i = 0; i<elements; i+=2, pairp+=2) {
1507    key = pairp[0];
1508    val = pairp[1];
1509    key_marked = val_marked = true;
1510    key_tag = fulltag_of(key);
1511    val_tag = fulltag_of(val);
1512    if (is_node_fulltag(key_tag)) {
1513      key_dnode = gc_area_dnode(key);
1514      if ((key_dnode < GCndnodes_in_area) &&
1515          ! ref_bit(GCmarkbits,key_dnode)) {
1516        key_marked = false;
1517      }
1518    }
1519    if (is_node_fulltag(val_tag)) {
1520      val_dnode = gc_area_dnode(val);
1521      if ((val_dnode < GCndnodes_in_area) &&
1522          ! ref_bit(GCmarkbits,val_dnode)) {
1523        val_marked = false;
1524      }
1525    }
1526
1527    if (weak_value) {
1528      if (val_marked & !key_marked) {
1529        mark_root(key);
1530        marked_new = true;
1531      }
1532    } else {
1533      if (key_marked & !val_marked) {
1534        mark_root(val);
1535        marked_new = true;
1536      }
1537    }
1538  }
1539  return marked_new;
1540}
1541
1542
1543Boolean
1544mark_weak_alist(LispObj weak_alist, int weak_type)
1545{
1546  natural
1547    elements = header_element_count(header_of(weak_alist)),
1548    dnode;
1549  int pair_tag;
1550  Boolean marked_new = false;
1551  LispObj alist, pair, key, value;
1552  bitvector markbits = GCmarkbits;
1553
1554  if (weak_type >> population_termination_bit) {
1555    elements -= 1;
1556  }
1557  for(alist = deref(weak_alist, elements);
1558      (fulltag_of(alist) == fulltag_cons) &&
1559      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
1560      (! ref_bit(markbits,dnode));
1561      alist = cdr(alist)) {
1562    pair = car(alist);
1563    pair_tag = fulltag_of(pair);
1564    if ((is_node_fulltag(pair_tag)) &&
1565        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
1566        (! ref_bit(markbits,dnode))) {
1567      if (pair_tag == fulltag_cons) {
1568        key = car(pair);
1569        if ((! is_node_fulltag(fulltag_of(key))) ||
1570            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
1571            ref_bit(markbits,dnode)) {
1572          /* key is marked, mark value if necessary */
1573          value = cdr(pair);
1574          if (is_node_fulltag(fulltag_of(value)) &&
1575              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
1576              (! ref_bit(markbits,dnode))) {
1577            mark_root(value);
1578            marked_new = true;
1579          }
1580        }
1581      } else {
1582          mark_root(pair);
1583          marked_new = true;
1584      }
1585    }
1586  }
1587  return marked_new;
1588}
1589 
1590void
1591markhtabvs()
1592{
1593  LispObj this, header, pending;
1594  int subtag;
1595  bitvector markbits = GCmarkbits;
1596  hash_table_vector_header *hashp;
1597  Boolean marked_new;
1598
1599  do {
1600    pending = (LispObj) NULL;
1601    marked_new = false;
1602   
1603    while (GCweakvll) {
1604      this = GCweakvll;
1605      GCweakvll = deref(this,1);
1606     
1607      header = header_of(this);
1608      subtag = header_subtag(header);
1609     
1610      if (subtag == subtag_weak) {
1611        natural weak_type = deref(this,2);
1612        deref(this,1) = pending;
1613        pending = this;
1614        if ((weak_type & population_type_mask) == population_weak_alist) {
1615          if (mark_weak_alist(this, weak_type)) {
1616            marked_new = true;
1617          }
1618        }
1619      } else if (subtag == subtag_hash_vector) {
1620        natural elements = header_element_count(header), i;
1621
1622        hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this));
1623        if (hashp->flags & nhash_weak_mask) {
1624          deref(this,1) = pending;
1625          pending = this;
1626          if (mark_weak_hash_vector(hashp, elements)) {
1627            marked_new = true;
1628          }
1629        } else {
1630          deref(this,1) = (LispObj)NULL;
1631          for (i = 2; i <= elements; i++) {
1632            mark_root(deref(this,i));
1633          }
1634        } 
1635      } else {
1636        Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this);
1637      }
1638    }
1639
1640    if (marked_new) {
1641      GCweakvll = pending;
1642    }
1643  } while (marked_new);
1644
1645  /* Now, everything's marked that's going to be,  and "pending" is a list
1646     of populations and weak hash tables.  CDR down that list and free
1647     anything that isn't marked.
1648     */
1649
1650  while (pending) {
1651    this = pending;
1652    pending = deref(this,1);
1653    deref(this,1) = (LispObj)NULL;
1654
1655    subtag = header_subtag(header_of(this));
1656    if (subtag == subtag_weak) {
1657      reapweakv(this);
1658    } else {
1659      reaphashv(this);
1660    }
1661  }
1662
1663  /* Finally, mark the termination lists in all terminatable weak vectors
1664     They are now linked together on GCweakvll.
1665     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
1666     but it will force terminatable popualations to hold on to each other
1667     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
1668     */
1669  pending = GCweakvll;
1670  GCweakvll = (LispObj)NULL;
1671  while (pending) {
1672    this = pending;
1673    pending = deref(this,1);
1674    deref(this,1) = (LispObj)NULL;
1675    mark_root(deref(this,1+3));
1676  }
1677}
1678
1679/* Mark the lisp objects in an exception frame */
1680#ifdef X8664
1681void
1682mark_xp(ExceptionInformation *xp)
1683{
1684  natural *regs = (natural *) xpGPRvector(xp), dnode;
1685  LispObj rip;
1686   
1687 
1688
1689  mark_root(regs[Iarg_z]);
1690  mark_root(regs[Iarg_y]);
1691  mark_root(regs[Iarg_x]);
1692  mark_root(regs[Isave3]);
1693  mark_root(regs[Isave2]);
1694  mark_root(regs[Isave1]);
1695  mark_root(regs[Isave0]);
1696  mark_root(regs[Ifn]);
1697  mark_root(regs[Itemp0]);
1698  mark_root(regs[Itemp1]);
1699  mark_root(regs[Itemp2]);
1700  /* If the RIP isn't pointing into a marked function,
1701     we can -maybe- recover from that if it's tagged as
1702     a TRA. */
1703  rip = regs[Iip];
1704  dnode = gc_area_dnode(rip);
1705  if ((dnode < GCndnodes_in_area) &&
1706      (! ref_bit(GCmarkbits,dnode))) {
1707    if (tag_of(rip) == tag_tra) {
1708      mark_root(rip);
1709    } else if ((fulltag_of(rip) == fulltag_function) &&
1710               (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) &&
1711               (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) &&
1712               ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) {
1713      mark_root(rip);
1714    } else {
1715      Bug(NULL, "Can't find function for rip 0x%16lx",rip);
1716    }
1717  }
1718}
1719#else
1720void
1721mark_xp(ExceptionInformation *xp, unsigned char node_regs_mask)
1722{
1723  natural *regs = (natural *) xpGPRvector(xp), dnode;
1724  LispObj eip;
1725  int i;
1726
1727  for (i = 0; i < 8; i++)
1728    if (node_regs_mask & (1<<i))
1729      mark_root(regs[i]);
1730
1731  /* If the EIP isn't pointing into a marked function, we're probably
1732     in trouble.  We can -maybe- recover from that if it's tagged as a
1733     TRA. */
1734  eip = regs[Ieip];
1735  dnode = gc_area_dnode(eip);
1736  if ((dnode < GCndnodes_in_area) &&
1737      (! ref_bit(GCmarkbits,dnode))) {
1738    if (fulltag_of(eip) == fulltag_tra) {
1739      mark_root(eip);
1740    } else if ((fulltag_of(eip) == fulltag_misc) &&
1741               (header_subtag(header_of(eip)) == subtag_function) &&
1742               (*(unsigned char *)eip == RECOVER_FN_OPCODE) &&
1743               (*(LispObj *)(eip + 1)) == eip) {
1744      mark_root(eip);
1745    } else {
1746      Bug(NULL, "Can't find function for eip 0x%4x", eip);
1747    }
1748  }
1749}
1750#endif
1751
1752void
1753mark_tcr_tlb(TCR *tcr)
1754{
1755  natural n = tcr->tlb_limit;
1756  LispObj
1757    *start = tcr->tlb_pointer,
1758    *end = (LispObj *) ((BytePtr)start+n),
1759    node;
1760
1761  while (start < end) {
1762    node = *start;
1763    if (node != no_thread_local_binding_marker) {
1764      mark_root(node);
1765    }
1766    start++;
1767  }
1768}
1769
1770/*
1771  Mark things that're only reachable through some (suspended) TCR.
1772  (This basically means the tcr's gc_context and the exception
1773  frames on its xframe_list.)
1774*/
1775
1776void
1777mark_tcr_xframes(TCR *tcr)
1778{
1779  xframe_list *xframes;
1780  ExceptionInformation *xp;
1781
1782  xp = tcr->gc_context;
1783  if (xp) {
1784#ifdef X8664
1785    mark_xp(xp);
1786#else
1787    mark_xp(xp, tcr->node_regs_mask);
1788#endif
1789  }
1790#ifdef X8632
1791  mark_root(tcr->save0);
1792  mark_root(tcr->save1);
1793  mark_root(tcr->save2);
1794  mark_root(tcr->save3);
1795  mark_root(tcr->next_method_context);
1796#endif
1797 
1798  for (xframes = (xframe_list *) tcr->xframe; 
1799       xframes; 
1800       xframes = xframes->prev) {
1801#ifdef X8664
1802      mark_xp(xframes->curr);
1803#else
1804      mark_xp(xframes->curr, xframes->node_regs_mask);
1805#endif
1806  }
1807}
1808     
1809
1810void *postGCptrs = NULL;
1811
1812void
1813postGCfree(void *p)
1814{
1815  *(void **)p = postGCptrs;
1816  postGCptrs = p;
1817}
1818
1819void
1820freeGCptrs()
1821{
1822  void *p, *next;
1823
1824  for (p = postGCptrs; p; p = next) {
1825    next = *((void **)p);
1826    free(p);
1827  }
1828  postGCptrs = NULL;
1829}
1830
1831void
1832reap_gcable_ptrs()
1833{
1834  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
1835  xmacptr_flag flag;
1836  natural dnode;
1837  xmacptr *x;
1838
1839  while((next = *prev) != (LispObj)NULL) {
1840    dnode = gc_area_dnode(next);
1841    x = (xmacptr *) ptr_from_lispobj(untag(next));
1842
1843    if ((dnode >= GCndnodes_in_area) ||
1844        (ref_bit(GCmarkbits,dnode))) {
1845      prev = &(x->link);
1846    } else {
1847      *prev = x->link;
1848      flag = (xmacptr_flag)(x->flags);
1849      ptr = x->address;
1850
1851      if (ptr) {
1852        switch (flag) {
1853        case xmacptr_flag_recursive_lock:
1854          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
1855          break;
1856
1857        case xmacptr_flag_ptr:
1858          postGCfree((void *)ptr_from_lispobj(ptr));
1859          break;
1860
1861        case xmacptr_flag_rwlock:
1862          break;
1863
1864        case xmacptr_flag_semaphore:
1865          destroy_semaphore((void**)&(x->address));
1866          break;
1867
1868        default:
1869          /* (warn "unknown xmacptr_flag: ~s" flag) */
1870          /* Unknowd, and perhaps unknowdable. */
1871          /* Fall in: */
1872        case xmacptr_flag_none:
1873          break;
1874        }
1875      }
1876    }
1877  }
1878}
1879
1880
1881
1882#if  WORD_SIZE == 64
1883unsigned short *_one_bits = NULL;
1884
1885unsigned short
1886logcount16(unsigned short n)
1887{
1888  unsigned short c=0;
1889 
1890  while(n) {
1891    n = n & (n-1);
1892    c++;
1893  }
1894  return c;
1895}
1896
1897void
1898gc_init()
1899{
1900  int i;
1901 
1902  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
1903
1904  for (i = 0; i < (1<<16); i++) {
1905    _one_bits[i] = dnode_size*logcount16(i);
1906  }
1907}
1908
1909#define one_bits(x) _one_bits[x]
1910
1911#else
1912const unsigned char _one_bits[256] = {
1913    0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,
1914    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1915    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1916    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1917    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1918    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1919    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1920    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1921    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1922    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1923    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1924    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1925    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1926    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1927    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1928    4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8
1929};
1930
1931#define one_bits(x) _one_bits[x]
1932
1933void
1934gc_init()
1935{
1936}
1937
1938#endif
1939
1940/* A "pagelet" contains 32 doublewords.  The relocation table contains
1941   a word for each pagelet which defines the lowest address to which
1942   dnodes on that pagelet will be relocated.
1943
1944   The relocation address of a given pagelet is the sum of the relocation
1945   address for the preceding pagelet and the number of bytes occupied by
1946   marked objects on the preceding pagelet.
1947*/
1948
1949LispObj
1950calculate_relocation()
1951{
1952  LispObj *relocptr = GCrelocptr;
1953  LispObj current = GCareadynamiclow;
1954  bitvector
1955    markbits = GCdynamic_markbits;
1956  qnode *q = (qnode *) markbits;
1957  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1958  natural thesebits;
1959  LispObj first = 0;
1960
1961  if (npagelets) {
1962    do {
1963      *relocptr++ = current;
1964      thesebits = *markbits++;
1965      if (thesebits == ALL_ONES) {
1966        current += nbits_in_word*dnode_size;
1967        q += 4; /* sic */
1968      } else {
1969        if (!first) {
1970          first = current;
1971          while (thesebits & BIT0_MASK) {
1972            first += dnode_size;
1973            thesebits += thesebits;
1974          }
1975        }
1976        /* We're counting bits in qnodes in the wrong order here, but
1977           that's OK.  I think ... */
1978        current += one_bits(*q++);
1979        current += one_bits(*q++);
1980        current += one_bits(*q++);
1981        current += one_bits(*q++);
1982      }
1983    } while(--npagelets);
1984  }
1985  *relocptr++ = current;
1986  return first ? first : current;
1987}
1988
1989
1990#if 0
1991LispObj
1992dnode_forwarding_address(natural dnode, int tag_n)
1993{
1994  natural pagelet, nbits;
1995  unsigned int near_bits;
1996  LispObj new;
1997
1998  if (GCDebug) {
1999    if (! ref_bit(GCdynamic_markbits, dnode)) {
2000      Bug(NULL, "unmarked object being forwarded!\n");
2001    }
2002  }
2003
2004  pagelet = dnode >> bitmap_shift;
2005  nbits = dnode & bitmap_shift_count_mask;
2006  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
2007
2008  if (nbits < 32) {
2009    new = GCrelocptr[pagelet] + tag_n;;
2010    /* Increment "new" by the count of 1 bits which precede the dnode */
2011    if (near_bits == 0xffffffff) {
2012      return (new + (nbits << 4));
2013    } else {
2014      near_bits &= (0xffffffff00000000 >> nbits);
2015      if (nbits > 15) {
2016        new += one_bits(near_bits & 0xffff);
2017      }
2018      return (new + (one_bits(near_bits >> 16)));
2019    }
2020  } else {
2021    new = GCrelocptr[pagelet+1] + tag_n;
2022    nbits = 64-nbits;
2023
2024    if (near_bits == 0xffffffff) {
2025      return (new - (nbits << 4));
2026    } else {
2027      near_bits &= (1<<nbits)-1;
2028      if (nbits > 15) {
2029        new -= one_bits(near_bits >> 16);
2030      }
2031      return (new -  one_bits(near_bits & 0xffff));
2032    }
2033  }
2034}
2035#else
2036#ifdef X8664
2037/* Quicker, dirtier */
2038LispObj
2039dnode_forwarding_address(natural dnode, int tag_n)
2040{
2041  natural pagelet, nbits, marked;
2042  LispObj new;
2043
2044  if (GCDebug) {
2045    if (! ref_bit(GCdynamic_markbits, dnode)) {
2046      Bug(NULL, "unmarked object being forwarded!\n");
2047    }
2048  }
2049
2050  pagelet = dnode >> bitmap_shift;
2051  nbits = dnode & bitmap_shift_count_mask;
2052  new = GCrelocptr[pagelet] + tag_n;;
2053  if (nbits) {
2054    marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits);
2055    while (marked) {
2056      new += one_bits((qnode)marked);
2057      marked >>=16;
2058    }
2059  }
2060  return new;
2061}
2062#endif
2063#ifdef X8632
2064LispObj
2065dnode_forwarding_address(natural dnode, int tag_n)
2066{
2067  natural pagelet, nbits;
2068  unsigned short near_bits;
2069  LispObj new;
2070
2071  if (GCDebug) {
2072    if (! ref_bit(GCdynamic_markbits, dnode)) {
2073      Bug(NULL, "unmarked object being forwarded!\n");
2074    }
2075  }
2076
2077  pagelet = dnode >> 5;
2078  nbits = dnode & 0x1f;
2079  /* On little-endian x86, we have to flip the low bit of dnode>>4 to
2080     get the near_bits from the appropriate half-word. */
2081  near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1];
2082
2083  if (nbits < 16) {
2084    new = GCrelocptr[pagelet] + tag_n;;
2085    /* Increment "new" by the count of 1 bits which precede the dnode */
2086    if (near_bits == 0xffff) {
2087      return (new + (nbits << 3));
2088    } else {
2089      near_bits &= (0xffff0000 >> nbits);
2090      if (nbits > 7) {
2091        new += one_bits(near_bits & 0xff);
2092      }
2093      return (new + (one_bits(near_bits >> 8))); 
2094    }
2095  } else {
2096    new = GCrelocptr[pagelet+1] + tag_n;
2097    nbits = 32-nbits;
2098
2099    if (near_bits == 0xffff) {
2100      return (new - (nbits << 3));
2101    } else {
2102      near_bits &= (1<<nbits)-1;
2103      if (nbits > 7) {
2104        new -= one_bits(near_bits >> 8);
2105      }
2106      return (new - one_bits(near_bits & 0xff));
2107    }
2108  }
2109}
2110#endif
2111#endif
2112
2113LispObj
2114locative_forwarding_address(LispObj obj)
2115{
2116  int tag_n = fulltag_of(obj);
2117  natural dnode = gc_dynamic_area_dnode(obj);
2118
2119
2120  if ((dnode >= GCndynamic_dnodes_in_area) ||
2121      (obj < GCfirstunmarked)) {
2122    return obj;
2123  }
2124
2125  return dnode_forwarding_address(dnode, tag_n);
2126}
2127
2128LispObj
2129node_forwarding_address(LispObj node)
2130{
2131  int tag_n;
2132  natural dnode = gc_dynamic_area_dnode(node);
2133
2134  if ((dnode >= GCndynamic_dnodes_in_area) ||
2135      (node < GCfirstunmarked)) {
2136    return node;
2137  }
2138
2139  tag_n = fulltag_of(node);
2140  if (!is_node_fulltag(tag_n)) {
2141    return node;
2142  }
2143
2144  return dnode_forwarding_address(dnode, tag_n);
2145}
2146
2147Boolean
2148update_noderef(LispObj *noderef)
2149{
2150  LispObj
2151    node = *noderef,
2152    new = node_forwarding_address(node);
2153
2154  if (new != node) {
2155    *noderef = new;
2156    return true;
2157  }
2158  return false;
2159}
2160
2161void
2162update_locref(LispObj *locref)
2163{
2164  LispObj
2165    obj = *locref,
2166    new = locative_forwarding_address(obj);
2167
2168  if (new != obj) {
2169    *locref = new;
2170  }
2171}
2172
2173void
2174forward_gcable_ptrs()
2175{
2176  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2177
2178  while ((next = *prev) != (LispObj)NULL) {
2179    *prev = node_forwarding_address(next);
2180    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2181  }
2182}
2183
2184void
2185forward_headerless_range(LispObj *range_start, LispObj *range_end)
2186{
2187  LispObj *p = range_start;
2188
2189  while (p < range_end) {
2190    update_noderef(p);
2191    p++;
2192  }
2193}
2194
2195void
2196forward_range(LispObj *range_start, LispObj *range_end)
2197{
2198  LispObj *p = range_start, node, new;
2199  int tag_n;
2200  natural nwords;
2201  hash_table_vector_header *hashp;
2202
2203  while (p < range_end) {
2204    node = *p;
2205    tag_n = fulltag_of(node);
2206    if (immheader_tag_p(tag_n)) {
2207      p = (LispObj *) skip_over_ivector((natural) p, node);
2208    } else if (nodeheader_tag_p(tag_n)) {
2209      nwords = header_element_count(node);
2210      nwords += (1 - (nwords&1));
2211      if ((header_subtag(node) == subtag_hash_vector) &&
2212          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
2213        natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2214        hashp = (hash_table_vector_header *) p;
2215        p++;
2216        nwords -= skip;
2217        while(skip--) {
2218          update_noderef(p);
2219          p++;
2220        }
2221        /* "nwords" is odd at this point: there are (floor nwords 2)
2222           key/value pairs to look at, and then an extra word for
2223           alignment.  Process them two at a time, then bump "p"
2224           past the alignment word. */
2225        nwords >>= 1;
2226        while(nwords--) {
2227          if (update_noderef(p) && hashp) {
2228            hashp->flags |= nhash_key_moved_mask;
2229            hashp = NULL;
2230          }
2231          p++;
2232          update_noderef(p);
2233          p++;
2234        }
2235        *p++ = 0;
2236      } else {
2237        if (header_subtag(node) == subtag_function) {
2238#ifdef X8632
2239          int skip = (unsigned short)(p[1]);
2240#else
2241          int skip = (int)(p[1]);
2242#endif
2243          p += skip;
2244          nwords -= skip;
2245        }
2246        p++;
2247        while(nwords--) {
2248          update_noderef(p);
2249          p++;
2250        }
2251      }
2252    } else {
2253      new = node_forwarding_address(node);
2254      if (new != node) {
2255        *p = new;
2256      }
2257      p++;
2258      update_noderef(p);
2259      p++;
2260    }
2261  }
2262}
2263
2264
2265void
2266forward_memoized_area(area *a, natural num_memo_dnodes)
2267{
2268  bitvector refbits = a->refbits;
2269  LispObj *p = (LispObj *) a->low, x1, x2, new;
2270  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
2271  int tag_x1;
2272  hash_table_vector_header *hashp = NULL;
2273  Boolean header_p;
2274
2275  if (GCDebug) {
2276    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
2277  }
2278
2279  /* This is pretty straightforward, but we have to note
2280     when we move a key in a hash table vector that wants
2281     us to tell it about that. */
2282
2283  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
2284  while (memo_dnode < num_memo_dnodes) {
2285    if (bits == 0) {
2286      int remain = nbits_in_word - bitidx;
2287      memo_dnode += remain;
2288      p += (remain+remain);
2289      bits = *++bitsp;
2290      bitidx = 0;
2291    } else {
2292      nextbit = count_leading_zeros(bits);
2293      if ((diff = (nextbit - bitidx)) != 0) {
2294        memo_dnode += diff;
2295        bitidx = nextbit;
2296        p += (diff+diff);
2297      }
2298      x1 = p[0];
2299      x2 = p[1];
2300      tag_x1 = fulltag_of(x1);
2301      bits &= ~(BIT0_MASK >> bitidx);
2302      header_p = (nodeheader_tag_p(tag_x1));
2303
2304      if (header_p &&
2305          (header_subtag(x1) == subtag_hash_vector)) {
2306        hashp = (hash_table_vector_header *) p;
2307        if (hashp->flags & nhash_track_keys_mask) {
2308          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
2309        } else {
2310          hashp = NULL;
2311        }
2312      }
2313
2314
2315      if (! header_p) {
2316        new = node_forwarding_address(x1);
2317        if (new != x1) {
2318          *p = new;
2319        }
2320      }
2321      p++;
2322
2323      new = node_forwarding_address(x2);
2324      if (new != x2) {
2325        *p = new;
2326        if (memo_dnode < hash_dnode_limit) {
2327          hashp->flags |= nhash_key_moved_mask;
2328          hash_dnode_limit = 0;
2329          hashp = NULL;
2330        }
2331      }
2332      p++;
2333      memo_dnode++;
2334      bitidx++;
2335
2336    }
2337  }
2338}
2339
2340
2341
2342/* Forward a tstack area */
2343void
2344forward_tstack_area(area *a)
2345{
2346  LispObj
2347    *current,
2348    *next,
2349    *start = (LispObj *) a->active,
2350    *end = start,
2351    *limit = (LispObj *) (a->high);
2352
2353  for (current = start;
2354       end != limit;
2355       current = next) {
2356    next = ptr_from_lispobj(*current);
2357    end = ((next >= start) && (next < limit)) ? next : limit;
2358    forward_range(current+2, end);
2359  }
2360}
2361
2362/* Forward a vstack area */
2363void
2364forward_vstack_area(area *a)
2365{
2366  LispObj
2367    *p = (LispObj *) a->active,
2368    *q = (LispObj *) a->high;
2369
2370  forward_headerless_range(p, q);
2371}
2372
2373void
2374forward_xp(ExceptionInformation *xp)
2375{
2376  natural *regs = (natural *) xpGPRvector(xp);
2377
2378#ifdef X8664
2379  update_noderef(&(regs[Iarg_z]));
2380  update_noderef(&(regs[Iarg_y]));
2381  update_noderef(&(regs[Iarg_x]));
2382  update_noderef(&(regs[Isave3]));
2383  update_noderef(&(regs[Isave2]));
2384  update_noderef(&(regs[Isave1]));
2385  update_noderef(&(regs[Isave0]));
2386  update_noderef(&(regs[Ifn]));
2387  update_noderef(&(regs[Itemp0]));
2388  update_noderef(&(regs[Itemp1]));
2389  update_noderef(&(regs[Itemp2]));
2390  update_locref(&(regs[Iip]));
2391#else
2392  update_noderef(&(regs[Iarg_z]));
2393  update_noderef(&(regs[Iarg_y]));
2394  update_noderef(&(regs[Ifn]));
2395  update_noderef(&(regs[Itemp0]));
2396  update_noderef(&(regs[Itemp1]));
2397  update_locref(&(regs[Iip]));
2398#endif
2399}
2400
2401
2402void
2403forward_tcr_tlb(TCR *tcr)
2404{
2405  natural n = tcr->tlb_limit;
2406  LispObj
2407    *start = tcr->tlb_pointer, 
2408    *end = (LispObj *) ((BytePtr)start+n),
2409    node;
2410
2411  while (start < end) {
2412    node = *start;
2413    if (node != no_thread_local_binding_marker) {
2414      update_noderef(start);
2415    }
2416    start++;
2417  }
2418}
2419
2420void
2421forward_tcr_xframes(TCR *tcr)
2422{
2423  xframe_list *xframes;
2424  ExceptionInformation *xp;
2425
2426  xp = tcr->gc_context;
2427  if (xp) {
2428    forward_xp(xp);
2429  }
2430  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2431    forward_xp(xframes->curr);
2432  }
2433}
2434
2435void
2436forward_and_resolve_static_references(area *a)
2437{
2438  natural
2439    nstatic = static_dnodes_for_area(a),
2440    nstatic_bitmap_words = nstatic >> bitmap_shift;
2441  if (nstatic != 0) {
2442    /* exploit the fact that a cons is the same size as a dnode. */
2443    cons *pagelet_start = (cons *) a->low, *work;
2444    bitvector markbits = GCmarkbits, 
2445      usedbits = tenured_area->static_used;
2446    natural marked, used, used_but_not_marked, ndeleted = 0, i;
2447
2448    while (nstatic_bitmap_words--) {
2449      marked = *markbits++;
2450      used = *usedbits;
2451      if (marked != used) {
2452        *usedbits = marked;
2453      }
2454      used |= marked;
2455      used_but_not_marked = used & ~marked;
2456
2457      while (marked) {
2458        i = count_leading_zeros(marked);
2459        marked &= ~(BIT0_MASK >> i);
2460        work = pagelet_start+i;
2461        update_noderef(&work->cdr);
2462        update_noderef(&work->car);
2463      }
2464
2465      while (used_but_not_marked) {
2466        i = count_leading_zeros(used_but_not_marked);
2467        used_but_not_marked &= ~(BIT0_MASK >> i);
2468        work = pagelet_start+i;
2469        if ((work->cdr != undefined) &&
2470            (work->cdr != slot_unbound)) {
2471          work->car = slot_unbound;
2472          work->cdr = slot_unbound;
2473          ndeleted++;
2474        }
2475      }
2476      usedbits++;
2477      pagelet_start += nbits_in_word;
2478    }
2479    lisp_global(DELETED_STATIC_PAIRS) += box_fixnum(ndeleted);
2480  }
2481}
2482
2483#ifdef X8632
2484void
2485update_self_references(LispObj *node)
2486{
2487  LispObj fn = fulltag_misc + (LispObj)node;
2488  unsigned char *p = (unsigned char *)node;
2489  natural i, offset;
2490
2491  i = ((unsigned short *)node)[2];
2492  offset = node[--i];
2493  while (offset) {
2494    *(LispObj *)(p + offset) = fn;
2495    offset = node[--i];
2496  }   
2497}
2498#endif
2499
2500/*
2501  Compact the dynamic heap (from GCfirstunmarked through its end.)
2502  Return the doublenode address of the new freeptr.
2503  */
2504
2505LispObj
2506compact_dynamic_heap()
2507{
2508  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
2509  natural
2510    elements, 
2511    dnode = gc_area_dnode(GCfirstunmarked), 
2512    node_dnodes = 0, 
2513    imm_dnodes = 0, 
2514    bitidx, 
2515    *bitsp, 
2516    bits, 
2517    nextbit, 
2518    diff;
2519  int tag;
2520  bitvector markbits = GCmarkbits;
2521    /* keep track of whether or not we saw any
2522       code_vector headers, and only flush cache if so. */
2523  Boolean GCrelocated_code_vector = false;
2524
2525  if (dnode < GCndnodes_in_area) {
2526    lisp_global(FWDNUM) += (1<<fixnum_shift);
2527 
2528    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2529    while (dnode < GCndnodes_in_area) {
2530      if (bits == 0) {
2531        int remain = nbits_in_word - bitidx;
2532        dnode += remain;
2533        src += (remain+remain);
2534        bits = *++bitsp;
2535        bitidx = 0;
2536      } else {
2537        /* Have a non-zero markbits word; all bits more significant
2538           than "bitidx" are 0.  Count leading zeros in "bits"
2539           (there'll be at least "bitidx" of them.)  If there are more
2540           than "bitidx" leading zeros, bump "dnode", "bitidx", and
2541           "src" by the difference. */
2542        nextbit = count_leading_zeros(bits);
2543        if ((diff = (nextbit - bitidx)) != 0) {
2544          dnode += diff;
2545          bitidx = nextbit;
2546          src += (diff+diff);
2547        }
2548        prev = current;
2549        current = src;
2550        if (GCDebug) {
2551          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
2552            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
2553                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
2554          }
2555        }
2556
2557        node = *src++;
2558        tag = fulltag_of(node);
2559        if (nodeheader_tag_p(tag)) {
2560          elements = header_element_count(node);
2561          node_dnodes = (elements+2)>>1;
2562          dnode += node_dnodes;
2563          if (header_subtag(node) == subtag_function) {
2564#ifdef X8632
2565            int skip = *((unsigned short *)src);
2566            LispObj *f = dest;
2567#else
2568            int skip = *((int *)src);
2569#endif
2570            *dest++ = node;
2571            elements -= skip;
2572            while(skip--) {
2573              *dest++ = *src++;
2574            }
2575            update_self_references(f);
2576            while(elements--) {
2577              *dest++ = node_forwarding_address(*src++);
2578            }
2579            if (((LispObj)src) & node_size) {
2580              src++;
2581              *dest++ = 0;
2582            }
2583          } else {
2584            if ((header_subtag(node) == subtag_hash_vector) &&
2585                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
2586              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
2587              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2588             
2589              *dest++ = node;
2590              elements -= skip;
2591              while(skip--) {
2592                *dest++ = node_forwarding_address(*src++);
2593              }
2594              /* There should be an even number of (key/value) pairs in elements;
2595                 an extra alignment word follows. */
2596              elements >>= 1;
2597              while (elements--) {
2598                if (hashp) {
2599                  node = *src++;
2600                  new = node_forwarding_address(node);
2601                  if (new != node) {
2602                    hashp->flags |= nhash_key_moved_mask;
2603                    hashp = NULL;
2604                    *dest++ = new;
2605                  } else {
2606                    *dest++ = node;
2607                  }
2608                } else {
2609                  *dest++ = node_forwarding_address(*src++);
2610                }
2611                *dest++ = node_forwarding_address(*src++);
2612              }
2613              *dest++ = 0;
2614              src++;
2615            } else {
2616              *dest++ = node;
2617              *dest++ = node_forwarding_address(*src++);
2618              while(--node_dnodes) {
2619                *dest++ = node_forwarding_address(*src++);
2620                *dest++ = node_forwarding_address(*src++);
2621              }
2622            }
2623          }
2624          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2625        } else if (immheader_tag_p(tag)) {
2626          *dest++ = node;
2627          *dest++ = *src++;
2628          elements = header_element_count(node);
2629          tag = header_subtag(node);
2630
2631#ifdef X8664
2632          switch(fulltag_of(tag)) {
2633          case ivector_class_64_bit:
2634            imm_dnodes = ((elements+1)+1)>>1;
2635            break;
2636          case ivector_class_32_bit:
2637            imm_dnodes = (((elements+2)+3)>>2);
2638            break;
2639          case ivector_class_other_bit:
2640            if (tag == subtag_bit_vector) {
2641              imm_dnodes = (((elements+64)+127)>>7);
2642            } else if (tag >= min_8_bit_ivector_subtag) {
2643              imm_dnodes = (((elements+8)+15)>>4);
2644            } else {
2645              imm_dnodes = (((elements+4)+7)>>3);
2646            }
2647          }
2648#endif
2649#ifdef X8632
2650          if (tag <= max_32_bit_ivector_subtag) {
2651            if (tag == subtag_code_vector) {
2652              GCrelocated_code_vector = true;
2653            }
2654            imm_dnodes = (((elements+1)+1)>>1);
2655          } else if (tag <= max_8_bit_ivector_subtag) {
2656            imm_dnodes = (((elements+4)+7)>>3);
2657          } else if (tag <= max_16_bit_ivector_subtag) {
2658            imm_dnodes = (((elements+2)+3)>>2);
2659          } else if (tag == subtag_bit_vector) {
2660            imm_dnodes = (((elements+32)+63)>>6);
2661          } else {
2662            imm_dnodes = elements+1;
2663          }
2664#endif
2665
2666          dnode += imm_dnodes;
2667          while (--imm_dnodes) {
2668            *dest++ = *src++;
2669            *dest++ = *src++;
2670          }
2671          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2672        } else {
2673          *dest++ = node_forwarding_address(node);
2674          *dest++ = node_forwarding_address(*src++);
2675          bits &= ~(BIT0_MASK >> bitidx);
2676          dnode++;
2677          bitidx++;
2678        }
2679      }
2680    }
2681  }
2682  return ptr_to_lispobj(dest);
2683}
2684
2685
2686Boolean
2687youngest_non_null_area_p (area *a)
2688{
2689  if (a->active == a->high) {
2690    return false;
2691  } else {
2692    for (a = a->younger; a; a = a->younger) {
2693      if (a->active != a->high) {
2694        return false;
2695      }
2696    }
2697  };
2698  return true;
2699}
2700
2701Boolean just_purified_p = false;
2702
2703
2704/*
2705  All thread's stack areas have been "normalized", as
2706  has the dynamic heap.  (The "active" pointer in these areas
2707  matches the stack pointer/freeptr value at the time that
2708  the exception occurred.)
2709*/
2710
2711
2712#define get_time(when) gettimeofday(&when, NULL)
2713
2714
2715
2716#ifdef FORCE_DWS_MARK
2717#warning recursive marker disabled for testing; remember to re-enable it
2718#endif
2719
2720void 
2721gc(TCR *tcr, signed_natural param)
2722{
2723  xframe_list *xframes = (tcr->xframe);
2724  struct timeval start, stop;
2725  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
2726  unsigned timeidx = 1;
2727  paging_info paging_info_start;
2728  xframe_list *x;
2729  LispObj
2730    pkg,
2731    itabvec = 0;
2732  BytePtr oldfree = a->active;
2733  TCR *other_tcr;
2734  natural static_dnodes;
2735
2736#ifndef FORCE_DWS_MARK
2737  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
2738    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
2739  } else {
2740    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
2741  }
2742#else
2743  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
2744#endif
2745
2746  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
2747  if (GCephemeral_low) {
2748    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
2749  } else {
2750    GCn_ephemeral_dnodes = 0;
2751  }
2752 
2753  if (GCn_ephemeral_dnodes) {
2754    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
2755  } else {
2756    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
2757  }
2758
2759  if (GCephemeral_low) {
2760    if ((oldfree-g1_area->low) < g1_area->threshold) {
2761      to = g1_area;
2762      note = a;
2763      timeidx = 4;
2764    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
2765      to = g2_area;
2766      from = g1_area;
2767      note = g1_area;
2768      timeidx = 3;
2769    } else {
2770      to = tenured_area;
2771      from = g2_area;
2772      note = g2_area;
2773      timeidx = 2;
2774    } 
2775  } else {
2776    note = tenured_area;
2777  }
2778
2779  if (GCverbose) {
2780    char buf[16];
2781
2782    sample_paging_info(&paging_info_start);
2783    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
2784    if (GCephemeral_low) {
2785      fprintf(stderr,
2786              "\n\n;;; Starting EGC of generation %d",
2787              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
2788    } else {
2789      fprintf(stderr,"\n\n;;; Starting full GC");
2790    }
2791    fprintf(stderr, ", %s bytes allocated.\n", buf);
2792  }
2793
2794
2795  get_time(start);
2796  lisp_global(IN_GC) = (1<<fixnumshift);
2797
2798
2799  if (just_purified_p) {
2800    just_purified_p = false;
2801    GCDebug = false;
2802  } else {
2803    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
2804    if (GCDebug) {
2805      check_all_areas();
2806    }
2807  }
2808
2809  if (from) {
2810    untenure_from_area(from);
2811  }
2812  static_dnodes = static_dnodes_for_area(a);
2813  GCmarkbits = a->markbits;
2814  GCarealow = ptr_to_lispobj(a->low);
2815  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
2816  GCndnodes_in_area = gc_area_dnode(oldfree);
2817
2818  if (GCndnodes_in_area) {
2819    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
2820    GCdynamic_markbits = 
2821      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
2822
2823    zero_bits(GCmarkbits, GCndnodes_in_area);
2824    GCweakvll = (LispObj)NULL;
2825 
2826
2827    if (GCn_ephemeral_dnodes == 0) {
2828      /* For GCTWA, mark the internal package hash table vector of
2829       *PACKAGE*, but don't mark its contents. */
2830      {
2831        LispObj
2832          itab;
2833        natural
2834          dnode, ndnodes;
2835     
2836        pkg = nrs_PACKAGE.vcell;
2837        if ((fulltag_of(pkg) == fulltag_misc) &&
2838            (header_subtag(header_of(pkg)) == subtag_package)) {
2839          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
2840          itabvec = car(itab);
2841          dnode = gc_area_dnode(itabvec);
2842          if (dnode < GCndnodes_in_area) {
2843            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
2844            set_n_bits(GCmarkbits, dnode, ndnodes);
2845          }
2846        }
2847      }
2848    }
2849
2850    {
2851      area *next_area;
2852      area_code code;
2853
2854      /* Could make a jump table instead of the typecase */
2855
2856      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2857        switch (code) {
2858        case AREA_TSTACK:
2859          mark_tstack_area(next_area);
2860          break;
2861
2862        case AREA_VSTACK:
2863          mark_vstack_area(next_area);
2864          break;
2865
2866        case AREA_STATIC:
2867        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
2868          /* In both of these cases, we -could- use the area's "markbits"
2869             bitvector as a reference map.  It's safe (but slower) to
2870             ignore that map and process the entire area.
2871          */
2872          if (next_area->younger == NULL) {
2873            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
2874          }
2875          break;
2876
2877        default:
2878          break;
2879        }
2880      }
2881    }
2882 
2883    if (lisp_global(OLDEST_EPHEMERAL)) {
2884      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
2885    }
2886
2887    other_tcr = tcr;
2888    do {
2889      mark_tcr_xframes(other_tcr);
2890      mark_tcr_tlb(other_tcr);
2891      other_tcr = other_tcr->next;
2892    } while (other_tcr != tcr);
2893
2894
2895
2896
2897    /* Go back through *package*'s internal symbols, marking
2898       any that aren't worthless.
2899    */
2900   
2901    if (itabvec) {
2902      natural
2903        i,
2904        n = header_element_count(header_of(itabvec));
2905      LispObj
2906        sym,
2907        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
2908
2909      for (i = 0; i < n; i++) {
2910        sym = *raw++;
2911#ifdef X8664
2912        if (fulltag_of(sym) == fulltag_symbol) {
2913#endif
2914#ifdef X8632
2915        if (fulltag_of(sym) == fulltag_misc) {
2916#endif
2917          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
2918          natural dnode = gc_area_dnode(sym);
2919         
2920          if ((dnode < GCndnodes_in_area) &&
2921              (!ref_bit(GCmarkbits,dnode))) {
2922            /* Symbol is in GC area, not marked.
2923               Mark it if fboundp, boundp, or if
2924               it has a plist or another home package.
2925            */
2926           
2927            if (FBOUNDP(rawsym) ||
2928                BOUNDP(rawsym) ||
2929                (rawsym->flags != 0) || /* SPECIAL, etc. */
2930                (rawsym->plist != lisp_nil) ||
2931                ((rawsym->package_predicate != pkg) &&
2932                 (rawsym->package_predicate != lisp_nil))) {
2933              mark_root(sym);
2934            }
2935          }
2936        }
2937      }
2938    }
2939
2940    (void)markhtabvs();
2941
2942    if (itabvec) {
2943      natural
2944        i,
2945        n = header_element_count(header_of(itabvec));
2946      LispObj
2947        sym,
2948        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
2949
2950      for (i = 0; i < n; i++, raw++) {
2951        sym = *raw;
2952#ifdef X8664
2953        if (fulltag_of(sym) == fulltag_symbol) {
2954#endif
2955#ifdef X8632
2956        if (fulltag_of(sym) == fulltag_misc) {
2957#endif
2958          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
2959          natural dnode = gc_area_dnode(sym);
2960
2961          if ((dnode < GCndnodes_in_area) &&
2962              (!ref_bit(GCmarkbits,dnode))) {
2963            *raw = unbound_marker;
2964          }
2965        }
2966      }
2967    }
2968 
2969    reap_gcable_ptrs();
2970
2971    GCrelocptr = global_reloctab;
2972    GCfirstunmarked = calculate_relocation();
2973
2974    forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
2975
2976    other_tcr = tcr;
2977    do {
2978      forward_tcr_xframes(other_tcr);
2979      forward_tcr_tlb(other_tcr);
2980      other_tcr = other_tcr->next;
2981    } while (other_tcr != tcr);
2982
2983 
2984    forward_gcable_ptrs();
2985
2986
2987
2988    {
2989      area *next_area;
2990      area_code code;
2991
2992      /* Could make a jump table instead of the typecase */
2993
2994      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2995        switch (code) {
2996        case AREA_TSTACK:
2997          forward_tstack_area(next_area);
2998          break;
2999
3000        case AREA_VSTACK:
3001          forward_vstack_area(next_area);
3002          break;
3003
3004
3005        case AREA_STATIC:
3006        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
3007          if (next_area->younger == NULL) {
3008            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
3009          }
3010          break;
3011
3012        default:
3013          break;
3014        }
3015      }
3016    }
3017 
3018    if (GCephemeral_low) {
3019      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
3020    } else {
3021      /* Full GC, need to process static space */
3022      forward_and_resolve_static_references(a);
3023    }
3024 
3025    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
3026    if (to) {
3027      tenure_to_area(to);
3028    }
3029
3030    zero_memory_range(a->active, oldfree);
3031
3032    resize_dynamic_heap(a->active,
3033                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
3034
3035    /*
3036      If the EGC is enabled: If there's no room for the youngest
3037      generation, untenure everything.  If this was a full GC and
3038      there's now room for the youngest generation, tenure everything.
3039    */
3040    if (a->older != NULL) {
3041      natural nfree = (a->high - a->active);
3042
3043
3044      if (nfree < a->threshold) {
3045        untenure_from_area(tenured_area);
3046      } else {
3047        if (GCephemeral_low == 0) {
3048          tenure_to_area(tenured_area);
3049        }
3050      }
3051    }
3052  }
3053  lisp_global(GC_NUM) += (1<<fixnumshift);
3054  if (note) {
3055    note->gccount += (1<<fixnumshift);
3056  }
3057
3058  if (GCDebug) {
3059    check_all_areas();
3060  }
3061
3062 
3063  lisp_global(IN_GC) = 0;
3064
3065  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
3066  get_time(stop);
3067
3068  {
3069    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
3070    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
3071    LispObj val;
3072    struct timeval *timeinfo, elapsed;
3073
3074    val = total_gc_microseconds->vcell;
3075    if ((fulltag_of(val) == fulltag_misc) &&
3076        (header_subtag(header_of(val)) == subtag_macptr)) {
3077      timersub(&stop, &start, &elapsed);
3078      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
3079      timeradd(timeinfo,  &elapsed, timeinfo);
3080      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
3081    }
3082
3083    val = total_bytes_freed->vcell;
3084    if ((fulltag_of(val) == fulltag_misc) &&
3085        (header_subtag(header_of(val)) == subtag_macptr)) {
3086      long long justfreed = oldfree - a->active;
3087      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
3088      if (GCverbose) {
3089        char buf[16];
3090        paging_info paging_info_stop;
3091       
3092        sample_paging_info(&paging_info_stop);
3093        if (justfreed <= heap_segment_size) {
3094          justfreed = 0;
3095        }
3096        comma_output_decimal(buf,16,justfreed);
3097        if (note == tenured_area) {
3098          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
3099        } else {
3100          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n", 
3101                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
3102                  buf, 
3103                  elapsed.tv_sec, elapsed.tv_usec);
3104        }
3105        report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
3106      }
3107    }
3108  }
3109}
3110
3111     
3112   
3113/*
3114  Total the (physical) byte sizes of all ivectors in the indicated memory range
3115*/
3116
3117natural
3118unboxed_bytes_in_range(LispObj *start, LispObj *end)
3119{
3120  natural total=0, elements, tag, subtag, bytes;
3121  LispObj header;
3122
3123  while (start < end) {
3124    header = *start;
3125    tag = fulltag_of(header);
3126   
3127    if ((nodeheader_tag_p(tag)) ||
3128        (immheader_tag_p(tag))) {
3129      elements = header_element_count(header);
3130      if (nodeheader_tag_p(tag)) {
3131        start += ((elements+2) & ~1);
3132      } else {
3133        subtag = header_subtag(header);
3134
3135#ifdef X8664
3136        switch(fulltag_of(header)) {
3137        case ivector_class_64_bit:
3138          bytes = 8 + (elements<<3);
3139          break;
3140        case ivector_class_32_bit:
3141          bytes = 8 + (elements<<2);
3142          break;
3143        case ivector_class_other_bit:
3144        default:
3145          if (subtag == subtag_bit_vector) {
3146            bytes = 8 + ((elements+7)>>3);
3147          } else if (subtag >= min_8_bit_ivector_subtag) {
3148            bytes = 8 + elements;
3149          } else {
3150            bytes = 8 + (elements<<1);
3151          }
3152        }
3153#endif
3154#ifdef X8632
3155          if (subtag <= max_32_bit_ivector_subtag) {
3156            bytes = 4 + (elements<<2);
3157          } else if (subtag <= max_8_bit_ivector_subtag) {
3158            bytes = 4 + elements;
3159          } else if (subtag <= max_16_bit_ivector_subtag) {
3160            bytes = 4 + (elements<<1);
3161          } else if (subtag == subtag_double_float_vector) {
3162            bytes = 8 + (elements<<3);
3163          } else {
3164            bytes = 4 + ((elements+7)>>3);
3165          }
3166#endif
3167
3168        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
3169        total += bytes;
3170        start += (bytes >> node_shift);
3171      }
3172    } else {
3173      start += 2;
3174    }
3175  }
3176  return total;
3177}
3178
3179
3180/*
3181  This assumes that it's getting called with a simple-{base,general}-string
3182  or code vector as an argument and that there's room for the object in the
3183  destination area.
3184*/
3185
3186
3187LispObj
3188purify_displaced_object(LispObj obj, area *dest, natural disp)
3189{
3190#ifdef X8664
3191  BytePtr
3192    free = dest->active,
3193    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
3194  LispObj
3195    header = header_of(obj), 
3196    new;
3197  natural
3198    subtag = header_subtag(header), 
3199    element_count = header_element_count(header),
3200    physbytes;
3201
3202  switch(subtag) {
3203  case subtag_simple_base_string:
3204    physbytes = node_size + (element_count << 2);
3205    break;
3206
3207#ifndef X86
3208  case subtag_code_vector:
3209    physbytes = node_size + (element_count << 2);
3210    break;
3211#endif
3212
3213  default:
3214    Bug(NULL, "Can't purify object at 0x%08x", obj);
3215    return obj;
3216  }
3217  physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1);
3218  dest->active += physbytes;
3219
3220  new = ptr_to_lispobj(free)+disp;
3221
3222  memcpy(free, (BytePtr)old, physbytes);
3223  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
3224  /* Actually, it's best to always leave a trail, for two reasons.
3225     a) We may be walking the same heap that we're leaving forwaring
3226     pointers in, so we don't want garbage that we leave behind to
3227     look like a header.
3228     b) We'd like to be able to forward code-vector locatives, and
3229     it's easiest to do so if we leave a {forward_marker, dnode_locative}
3230     pair at every doubleword in the old vector.
3231     */
3232  while(physbytes) {
3233    *old++ = (BytePtr) forward_marker;
3234    *old++ = (BytePtr) free;
3235    free += dnode_size;
3236    physbytes -= dnode_size;
3237  }
3238  return new;
3239#endif
3240}
3241
3242LispObj
3243purify_object(LispObj obj, area *dest)
3244{
3245  return purify_displaced_object(obj, dest, fulltag_of(obj));
3246}
3247
3248
3249#define FORWARD_ONLY 0
3250#define COPY_CODE (1<<0)
3251#define COPY_STRINGS (1<<1)
3252
3253
3254/*
3255  This may overestimate a bit, if the same symbol is accessible from multiple
3256  packages.
3257*/
3258natural
3259interned_pname_bytes_in_range(LispObj *start, LispObj *end)
3260{
3261  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
3262  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
3263  package *p;
3264  cons *c;
3265  natural elements, i, nbytes = 0;
3266
3267#ifdef X8664
3268  while (fulltag_of(pkg_list) == fulltag_cons) {
3269    c = (cons *) ptr_from_lispobj(untag(pkg_list));
3270    p = (package *) ptr_from_lispobj(untag(c->car));
3271    pkg_list = c->cdr;
3272    c = (cons *) ptr_from_lispobj(untag(p->itab));
3273    htab = c->car;
3274    elements = header_element_count(header_of(htab));
3275    for (i = 1; i<= elements; i++) {
3276      obj = deref(htab,i);
3277      if (fulltag_of(obj) == fulltag_symbol) {
3278        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3279        pname = rawsym->pname;
3280
3281        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
3282          pname_header = header_of(pname);
3283          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
3284        }
3285      }
3286    }
3287    c = (cons *) ptr_from_lispobj(untag(p->etab));
3288    htab = c->car;
3289    elements = header_element_count(header_of(htab));
3290    for (i = 1; i<= elements; i++) {
3291      obj = deref(htab,i);
3292      if (fulltag_of(obj) == fulltag_symbol) {
3293        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3294        pname = rawsym->pname;
3295
3296        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
3297          pname_header = header_of(pname);
3298          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
3299        }
3300      }
3301    }
3302  }
3303#endif
3304  return nbytes;
3305}
3306
3307Boolean
3308copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy)
3309{
3310  LispObj obj = *ref, header, new;
3311  natural tag = fulltag_of(obj), header_tag, header_subtag;
3312  Boolean changed = false;
3313
3314#ifdef X8664
3315  if ((tag == fulltag_misc) &&
3316      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
3317      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
3318    header = deref(obj, 0);
3319    if (header == forward_marker) { /* already copied */
3320      *ref = (untag(deref(obj,1)) + tag);
3321      changed = true;
3322    } else {
3323      header_tag = fulltag_of(header);
3324      if (immheader_tag_p(header_tag)) {
3325        header_subtag = header_subtag(header);
3326        if ((what_to_copy & COPY_STRINGS) && 
3327            ((header_subtag == subtag_simple_base_string))) {
3328          new = purify_object(obj, dest);
3329          *ref = new;
3330          changed = (new != obj);
3331        }
3332      }
3333    }
3334  }
3335#endif
3336  return changed;
3337}
3338
3339
3340void purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
3341{
3342  while (start < end) { 
3343    copy_ivector_reference(start, low, high, to, what);
3344    start++;
3345  }
3346}
3347   
3348void
3349purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
3350{
3351  LispObj header;
3352  unsigned tag;
3353  natural nwords;
3354  hash_table_vector_header *hashp;
3355
3356  while (start < end) {
3357    header = *start;
3358    if (header == forward_marker) {
3359      start += 2;
3360    } else {
3361      tag = fulltag_of(header);
3362      if (immheader_tag_p(tag)) {
3363        start = (LispObj *)skip_over_ivector((natural)start, header);
3364      } else if (nodeheader_tag_p(tag)) {
3365        nwords = header_element_count(header);
3366        nwords += (1 - (nwords&1));
3367        if ((header_subtag(header) == subtag_hash_vector) &&
3368          ((((hash_table_vector_header *)start)->flags) & 
3369           nhash_track_keys_mask)) {
3370          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
3371
3372          hashp = (hash_table_vector_header *) start;
3373          start++;
3374          nwords -= skip;
3375          while(skip--) {
3376            copy_ivector_reference(start, low, high, to, what);
3377            start++;
3378          }
3379          /* "nwords" is odd at this point: there are (floor nwords 2)
3380             key/value pairs to look at, and then an extra word for
3381             alignment.  Process them two at a time, then bump "start"
3382             past the alignment word. */
3383          nwords >>= 1;
3384          while(nwords--) {
3385            if (copy_ivector_reference(start, low, high, to, what) && hashp) {
3386              hashp->flags |= nhash_key_moved_mask;
3387              hashp = NULL;
3388            }
3389            start++;
3390            copy_ivector_reference(start, low, high, to, what);
3391            start++;
3392          }
3393          *start++ = 0;
3394        } else {
3395          if (header_subtag(header) == subtag_function) {
3396#ifdef X8632
3397            int skip = (unsigned short)(start[1]);
3398#else
3399            int skip = (int)(start[1]);
3400#endif
3401            start += skip;
3402            nwords -= skip;
3403          }
3404          start++;
3405          while(nwords--) {
3406            copy_ivector_reference(start, low, high, to, what);
3407            start++;
3408          }
3409        }
3410      } else {
3411        /* Not a header, just a cons cell */
3412        copy_ivector_reference(start, low, high, to, what);
3413        start++;
3414        copy_ivector_reference(start, low, high, to, what);
3415        start++;
3416      }
3417    }
3418  }
3419}
3420       
3421/* Purify references from tstack areas */
3422void
3423purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3424{
3425  LispObj
3426    *current,
3427    *next,
3428    *start = (LispObj *) (a->active),
3429    *end = start,
3430    *limit = (LispObj *) (a->high);
3431
3432  for (current = start;
3433       end != limit;
3434       current = next) {
3435    next = (LispObj *) ptr_from_lispobj(*current);
3436    end = ((next >= start) && (next < limit)) ? next : limit;
3437    if (current[1] == 0) {
3438      purify_range(current+2, end, low, high, to, what);
3439    }
3440  }
3441}
3442
3443/* Purify a vstack area */
3444void
3445purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3446{
3447  LispObj
3448    *p = (LispObj *) a->active,
3449    *q = (LispObj *) a->high;
3450 
3451  purify_headerless_range(p, q, low, high, to, what);
3452}
3453
3454
3455void
3456purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what)
3457{
3458  natural *regs = (natural *) xpGPRvector(xp);
3459
3460
3461#ifdef X8664
3462  copy_ivector_reference(&(regs[Iarg_z]), low, high, to, what);
3463  copy_ivector_reference(&(regs[Iarg_y]), low, high, to, what);
3464  copy_ivector_reference(&(regs[Iarg_x]), low, high, to, what);
3465  copy_ivector_reference(&(regs[Isave3]), low, high, to, what);
3466  copy_ivector_reference(&(regs[Isave2]), low, high, to, what);
3467  copy_ivector_reference(&(regs[Isave1]), low, high, to, what);
3468  copy_ivector_reference(&(regs[Isave0]), low, high, to, what);
3469  copy_ivector_reference(&(regs[Ifn]), low, high, to, what);
3470  copy_ivector_reference(&(regs[Itemp0]), low, high, to, what);
3471  copy_ivector_reference(&(regs[Itemp1]), low, high, to, what);
3472  copy_ivector_reference(&(regs[Itemp2]), low, high, to, what);
3473#if 0
3474  purify_locref(&(regs[Iip]), low, high, to, what);
3475#endif
3476#else
3477#endif
3478}
3479
3480void
3481purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3482{
3483  natural n = tcr->tlb_limit;
3484  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3485
3486  purify_range(start, end, low, high, to, what);
3487}
3488
3489void
3490purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3491{
3492  xframe_list *xframes;
3493  ExceptionInformation *xp;
3494 
3495  xp = tcr->gc_context;
3496  if (xp) {
3497    purify_xp(xp, low, high, to, what);
3498  }
3499
3500  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3501    purify_xp(xframes->curr, low, high, to, what);
3502  }
3503}
3504
3505
3506void
3507purify_areas(BytePtr low, BytePtr high, area *target, int what)
3508{
3509  area *next_area;
3510  area_code code;
3511     
3512  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3513    switch (code) {
3514    case AREA_TSTACK:
3515      purify_tstack_area(next_area, low, high, target, what);
3516      break;
3517     
3518    case AREA_VSTACK:
3519      purify_vstack_area(next_area, low, high, target, what);
3520      break;
3521     
3522    case AREA_CSTACK:
3523#ifdef PPC
3524      purify_cstack_area(next_area, low, high, target, what);
3525#endif
3526      break;
3527     
3528    case AREA_STATIC:
3529    case AREA_DYNAMIC:
3530      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what);
3531      break;
3532     
3533    default:
3534      break;
3535    }
3536  }
3537}
3538
3539/*
3540  So far, this is mostly for save_application's benefit.
3541  We -should- be able to return to lisp code after doing this,
3542  however.
3543
3544*/
3545
3546
3547int
3548purify(TCR *tcr, signed_natural param)
3549{
3550  extern area *extend_readonly_area(unsigned);
3551  area
3552    *a = active_dynamic_area,
3553    *new_pure_area;
3554
3555  TCR  *other_tcr;
3556  natural max_pure_size;
3557  OSErr err;
3558  BytePtr new_pure_start;
3559
3560#ifdef X8664
3561
3562  max_pure_size = interned_pname_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
3563                                         (LispObj *) a->active);
3564  new_pure_area = extend_readonly_area(max_pure_size);
3565  if (new_pure_area) {
3566    new_pure_start = new_pure_area->active;
3567    lisp_global(IN_GC) = (1<<fixnumshift);
3568
3569    /*
3570      First, loop thru *all-packages* and purify the pnames of all
3571      interned symbols.  Then walk every place that could reference
3572      a heap-allocated object (all_areas, the xframe_list) and
3573      purify code_vectors (and update the odd case of a shared
3574      reference to a pname.)
3575       
3576      Make the new_pure_area executable, just in case.
3577
3578      Caller will typically GC again (and that should recover quite a bit of
3579      the dynamic heap.)
3580      */
3581
3582    {
3583      lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
3584      LispObj pkg_list = rawsym->vcell, htab, obj;
3585      package *p;
3586      cons *c;
3587      natural elements, i;
3588
3589      while (fulltag_of(pkg_list) == fulltag_cons) {
3590        c = (cons *) ptr_from_lispobj(untag(pkg_list));
3591        p = (package *) ptr_from_lispobj(untag(c->car));
3592        pkg_list = c->cdr;
3593        c = (cons *) ptr_from_lispobj(untag(p->itab));
3594        htab = c->car;
3595        elements = header_element_count(header_of(htab));
3596        for (i = 1; i<= elements; i++) {
3597          obj = deref(htab,i);
3598          if (fulltag_of(obj) == fulltag_symbol) {
3599            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3600            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3601          }
3602        }
3603        c = (cons *) ptr_from_lispobj(untag(p->etab));
3604        htab = c->car;
3605        elements = header_element_count(header_of(htab));
3606        for (i = 1; i<= elements; i++) {
3607          obj = deref(htab,i);
3608          if (fulltag_of(obj) == fulltag_symbol) {
3609            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3610            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3611          }
3612        }
3613      }
3614    }
3615   
3616    purify_areas(a->low, a->active, new_pure_area, FORWARD_ONLY);
3617   
3618    other_tcr = tcr;
3619    do {
3620      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
3621      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
3622      other_tcr = other_tcr->next;
3623    } while (other_tcr != tcr);
3624
3625
3626    {
3627      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
3628      if (puresize != 0) {
3629        xMakeDataExecutable(new_pure_start, puresize);
3630 
3631      }
3632    }
3633    ProtectMemory(new_pure_area->low,
3634                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
3635                                      log2_page_size));
3636    lisp_global(IN_GC) = 0;
3637    just_purified_p = true;
3638    return 0;
3639  }
3640#endif
3641  return -1;
3642}
3643
3644
3645 
3646Boolean
3647impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
3648{
3649  LispObj q = *p;
3650 
3651  if (is_node_fulltag(fulltag_of(q)) &&
3652      (q >= low) && 
3653      (q < high)) {
3654    *p = (q+delta);
3655    return true;
3656  }
3657  return false;
3658}
3659 
3660
3661
3662void
3663impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
3664{
3665  natural *regs = (natural *) xpGPRvector(xp);
3666
3667
3668#ifdef X8664
3669  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
3670  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
3671  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
3672  impurify_noderef(&(regs[Isave3]), low, high, delta);
3673  impurify_noderef(&(regs[Isave2]), low, high, delta);
3674  impurify_noderef(&(regs[Isave1]), low, high, delta);
3675  impurify_noderef(&(regs[Isave0]), low, high, delta);
3676  impurify_noderef(&(regs[Ifn]), low, high, delta);
3677  impurify_noderef(&(regs[Itemp0]), low, high, delta);
3678  impurify_noderef(&(regs[Itemp1]), low, high, delta);
3679#if 0
3680  impurify_locref(&(regs[Iip]), low, high, delta);
3681#endif
3682#else
3683#endif
3684
3685}
3686
3687void
3688impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3689{
3690  while (start < end) {
3691    impurify_noderef(start, low, high, delta);
3692    start++;
3693  }
3694}
3695
3696
3697void
3698impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3699{
3700#ifdef X8664
3701
3702  LispObj header;
3703  unsigned tag;
3704  natural nwords;
3705  hash_table_vector_header *hashp;
3706
3707  while (start < end) {
3708    header = *start;
3709    if (header == forward_marker) {
3710      start += 2;
3711    } else {
3712      tag = fulltag_of(header);
3713      if (immheader_tag_p(tag)) {
3714        start = (LispObj *)skip_over_ivector((natural)start, header);
3715      } else if (nodeheader_tag_p(tag)) {
3716        nwords = header_element_count(header);
3717        nwords += (1 - (nwords&1));
3718        if ((header_subtag(header) == subtag_hash_vector) &&
3719          ((((hash_table_vector_header *)start)->flags) & 
3720           nhash_track_keys_mask)) {
3721          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
3722
3723          hashp = (hash_table_vector_header *) start;
3724          start++;
3725          nwords -= skip;
3726          while(skip--) {
3727            impurify_noderef(start, low, high, delta);
3728            start++;
3729          }
3730          /* "nwords" is odd at this point: there are (floor nwords 2)
3731             key/value pairs to look at, and then an extra word for
3732             alignment.  Process them two at a time, then bump "start"
3733             past the alignment word. */
3734          nwords >>= 1;
3735          while(nwords--) {
3736            if (impurify_noderef(start, low, high, delta) && hashp) {
3737              hashp->flags |= nhash_key_moved_mask;
3738              hashp = NULL;
3739            }
3740            start++;
3741            impurify_noderef(start, low, high, delta);
3742            start++;
3743          }
3744          *start++ = 0;
3745        } else {
3746          if (header_subtag(header) == subtag_function) {
3747            int skip = (int)(start[1]);
3748            start += skip;
3749            nwords -= skip;
3750          }
3751          start++;
3752          while(nwords--) {
3753            impurify_noderef(start, low, high, delta);
3754            start++;
3755          }
3756        }
3757      } else {
3758        /* Not a header, just a cons cell */
3759        impurify_noderef(start, low, high, delta);
3760        start++;
3761        impurify_noderef(start, low, high, delta);
3762        start++;
3763      }
3764    }
3765  }
3766#endif
3767}
3768
3769
3770
3771
3772void
3773impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
3774{
3775  unsigned n = tcr->tlb_limit;
3776  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3777 
3778  impurify_range(start, end, low, high, delta);
3779}
3780
3781void
3782impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
3783{
3784  xframe_list *xframes;
3785  ExceptionInformation *xp;
3786 
3787  xp = tcr->gc_context;
3788  if (xp) {
3789    impurify_xp(xp, low, high, delta);
3790  }
3791
3792  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3793    impurify_xp(xframes->curr, low, high, delta);
3794  }
3795}
3796
3797void
3798impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
3799{
3800  LispObj
3801    *current,
3802    *next,
3803    *start = (LispObj *) (a->active),
3804    *end = start,
3805    *limit = (LispObj *) (a->high);
3806
3807  for (current = start;
3808       end != limit;
3809       current = next) {
3810    next = (LispObj *) ptr_from_lispobj(*current);
3811    end = ((next >= start) && (next < limit)) ? next : limit;
3812    if (current[1] == 0) {
3813      impurify_range(current+2, end, low, high, delta);
3814    }
3815  }
3816}
3817void
3818impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
3819{
3820  LispObj
3821    *p = (LispObj *) a->active,
3822    *q = (LispObj *) a->high;
3823
3824  impurify_headerless_range(p, q, low, high, delta);
3825}
3826
3827
3828void
3829impurify_areas(LispObj low, LispObj high, int delta)
3830{
3831  area *next_area;
3832  area_code code;
3833     
3834  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3835    switch (code) {
3836    case AREA_TSTACK:
3837      impurify_tstack_area(next_area, low, high, delta);
3838      break;
3839     
3840    case AREA_VSTACK:
3841      impurify_vstack_area(next_area, low, high, delta);
3842      break;
3843     
3844    case AREA_CSTACK:
3845#ifdef PPC
3846      impurify_cstack_area(next_area, low, high, delta);
3847#endif
3848      break;
3849     
3850    case AREA_STATIC:
3851    case AREA_DYNAMIC:
3852      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
3853      break;
3854     
3855    default:
3856      break;
3857    }
3858  }
3859}
3860
3861int
3862impurify(TCR *tcr, signed_natural param)
3863{
3864  area *r = find_readonly_area();
3865
3866  if (r) {
3867    area *a = active_dynamic_area;
3868    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
3869      oldhigh = a->high, newhigh; 
3870    unsigned n = ro_limit - ro_base;
3871    int delta = oldfree-ro_base;
3872    TCR *other_tcr;
3873
3874    if (n) {
3875      lisp_global(IN_GC) = 1;
3876      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
3877                                               log2_heap_segment_size));
3878      if (newhigh > oldhigh) {
3879        grow_dynamic_area(newhigh-oldhigh);
3880      }
3881      a->active += n;
3882      bcopy(ro_base, oldfree, n);
3883      munmap((void *)ro_base, n);
3884      a->ndnodes = area_dnode(a, a->active);
3885      pure_space_active = r->active = r->low;
3886      r->ndnodes = 0;
3887
3888      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3889
3890      other_tcr = tcr;
3891      do {
3892        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3893        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3894        other_tcr = other_tcr->next;
3895      } while (other_tcr != tcr);
3896      lisp_global(IN_GC) = 0;
3897    }
3898    return 0;
3899  }
3900  return -1;
3901}
3902
3903
3904void
3905adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
3906{
3907  LispObj p = *loc;
3908 
3909  if (area_dnode(p, base) < limit) {
3910    *loc = p+delta;
3911  }
3912}
3913
3914/* like adjust_locref() above, but only changes the contents of LOC if it's
3915   a tagged lisp pointer */
3916void
3917adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
3918{
3919  LispObj p = *loc;
3920  int tag_n = fulltag_of(p);
3921
3922  if (is_node_fulltag(tag_n)) {
3923    if (area_dnode(p, base) < limit) {
3924      *loc = p+delta;
3925    }
3926  }
3927}
3928
3929/*
3930   If *loc is a tagged pointer into the address range denoted by BASE and LIMIT,
3931   nuke it (set it to NIL.)
3932*/
3933void
3934nuke_noderef(LispObj *loc, LispObj base, LispObj limit)
3935{
3936  LispObj p = *loc;
3937  int tag_n = fulltag_of(p);
3938
3939  if (is_node_fulltag(tag_n)) {
3940    if (area_dnode(p, base) < limit) {
3941      *loc = lisp_nil;
3942    }
3943  }
3944}
3945
3946
3947void
3948adjust_pointers_in_xp(ExceptionInformation *xp, 
3949                      LispObj base, 
3950                      LispObj limit, 
3951                      signed_natural delta) 
3952{
3953  natural *regs = (natural *) xpGPRvector(xp);
3954
3955#ifdef X8664
3956  adjust_noderef((LispObj *) (&(regs[Iarg_z])),base,limit,delta);
3957  adjust_noderef((LispObj *) (&(regs[Iarg_y])),base,limit,delta);
3958  adjust_noderef((LispObj *) (&(regs[Iarg_x])),base,limit,delta);
3959  adjust_noderef((LispObj *) (&(regs[Isave3])),base,limit,delta);
3960  adjust_noderef((LispObj *) (&(regs[Isave2])),base,limit,delta);
3961  adjust_noderef((LispObj *) (&(regs[Isave1])),base,limit,delta);
3962  adjust_noderef((LispObj *) (&(regs[Isave0])),base,limit,delta);
3963  adjust_noderef((LispObj *) (&(regs[Ifn])),base,limit,delta);
3964  adjust_noderef((LispObj *) (&(regs[Itemp0])),base,limit,delta);
3965  adjust_noderef((LispObj *) (&(regs[Itemp1])),base,limit,delta);
3966  adjust_noderef((LispObj *) (&(regs[Itemp2])),base,limit,delta);
3967  adjust_locref((LispObj *) (&(xpPC(xp))),base,limit,delta);
3968#endif
3969}
3970
3971void
3972nuke_pointers_in_xp(ExceptionInformation *xp, 
3973                      LispObj base, 
3974                      LispObj limit) 
3975{
3976  natural *regs = (natural *) xpGPRvector(xp);
3977
3978#ifdef X8664
3979  nuke_noderef((LispObj *) (&(regs[Iarg_z])),base,limit);
3980  nuke_noderef((LispObj *) (&(regs[Iarg_y])),base,limit);
3981  nuke_noderef((LispObj *) (&(regs[Iarg_x])),base,limit);
3982  nuke_noderef((LispObj *) (&(regs[Isave3])),base,limit);
3983  nuke_noderef((LispObj *) (&(regs[Isave2])),base,limit);
3984  nuke_noderef((LispObj *) (&(regs[Isave1])),base,limit);
3985  nuke_noderef((LispObj *) (&(regs[Isave0])),base,limit);
3986  nuke_noderef((LispObj *) (&(regs[Ifn])),base,limit);
3987  nuke_noderef((LispObj *) (&(regs[Itemp0])),base,limit);
3988  nuke_noderef((LispObj *) (&(regs[Itemp1])),base,limit);
3989  nuke_noderef((LispObj *) (&(regs[Itemp2])),base,limit);
3990#endif
3991}
3992
3993void
3994adjust_pointers_in_headerless_range(LispObj *range_start,
3995                                    LispObj *range_end,
3996                                    LispObj base,
3997                                    LispObj limit,
3998                                    signed_natural delta)
3999{
4000  LispObj *p = range_start;
4001
4002  while (p < range_end) {
4003    adjust_noderef(p, base, limit, delta);
4004    p++;
4005  }
4006}
4007
4008
4009void
4010adjust_pointers_in_range(LispObj *range_start,
4011                         LispObj *range_end,
4012                         LispObj base,
4013                         LispObj limit,
4014                         signed_natural delta)
4015{
4016  LispObj *p = range_start, node, new;
4017  int tag_n;
4018  natural nwords;
4019  hash_table_vector_header *hashp;
4020
4021  while (p < range_end) {
4022    node = *p;
4023    tag_n = fulltag_of(node);
4024    if (immheader_tag_p(tag_n)) {
4025      p = (LispObj *) skip_over_ivector((natural) p, node);
4026    } else if (nodeheader_tag_p(tag_n)) {
4027      nwords = header_element_count(node);
4028      nwords += (1 - (nwords&1));
4029      if ((header_subtag(node) == subtag_hash_vector) &&
4030          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
4031        hashp = (hash_table_vector_header *) p;
4032        hashp->flags |= nhash_key_moved_mask;
4033      } else if (header_subtag(node) == subtag_function) {
4034        int skip = (int)(p[1]);
4035        p += skip;
4036        nwords -= skip;
4037      }
4038      p++;
4039      while (nwords--) {
4040        adjust_noderef(p, base, limit, delta);
4041        p++;
4042      }
4043    } else {
4044      /* just a cons */
4045      adjust_noderef(p, base, limit, delta);
4046      p++;
4047      adjust_noderef(p, base, limit, delta);
4048      p++;
4049    }
4050  }
4051}
4052
4053void
4054nuke_pointers_in_headerless_range(LispObj *range_start,
4055                                  LispObj *range_end,
4056                                  LispObj base,
4057                                  LispObj limit)
4058{
4059  LispObj *p = range_start;
4060
4061  while (p < range_end) {
4062    nuke_noderef(p, base, limit);
4063    p++;
4064  }
4065}
4066
4067
4068void
4069nuke_pointers_in_range(LispObj *range_start,
4070                         LispObj *range_end,
4071                         LispObj base,
4072                         LispObj limit)
4073{
4074  LispObj *p = range_start, node, new;
4075  int tag_n;
4076  natural nwords;
4077
4078  while (p < range_end) {
4079    node = *p;
4080    tag_n = fulltag_of(node);
4081    if (immheader_tag_p(tag_n)) {
4082      p = (LispObj *) skip_over_ivector((natural) p, node);
4083    } else if (nodeheader_tag_p(tag_n)) {
4084      nwords = header_element_count(node);
4085      nwords += (1 - (nwords&1));
4086      if (header_subtag(node) == subtag_function) {
4087        int skip = (int)(p[1]);
4088        p += skip;
4089        nwords -= skip;
4090      }
4091      p++;
4092      while (nwords--) {
4093        nuke_noderef(p, base, limit);
4094        p++;
4095      }
4096    } else {
4097      /* just a cons */
4098      nuke_noderef(p, base, limit);
4099      p++;
4100      nuke_noderef(p, base, limit);
4101      p++;
4102    }
4103  }
4104}
4105
4106void
4107adjust_pointers_in_tstack_area(area *a,
4108                               LispObj base,
4109                               LispObj limit,
4110                               LispObj delta)
4111{
4112  LispObj
4113    *current,
4114    *next,
4115    *start = (LispObj *) a->active,
4116    *end = start,
4117    *area_limit = (LispObj *) (a->high);
4118
4119  for (current = start;
4120       end != area_limit;
4121       current = next) {
4122    next = ptr_from_lispobj(*current);
4123    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
4124    adjust_pointers_in_range(current+2, end, base, limit, delta);
4125  }
4126}
4127
4128void
4129nuke_pointers_in_tstack_area(area *a,
4130                             LispObj base,
4131                             LispObj limit)
4132{
4133  LispObj
4134    *current,
4135    *next,
4136    *start = (LispObj *) a->active,
4137    *end = start,
4138    *area_limit = (LispObj *) (a->high);
4139
4140  for (current = start;
4141       end != area_limit;
4142       current = next) {
4143    next = ptr_from_lispobj(*current);
4144    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
4145    if (current[1] == 0) {
4146      nuke_pointers_in_range(current+2, end, base, limit);
4147    }
4148  }
4149}
4150
4151void
4152adjust_pointers_in_vstack_area(area *a,
4153                               LispObj base,
4154                               LispObj limit,
4155                               LispObj delta)
4156{
4157  LispObj
4158    *p = (LispObj *) a->active,
4159    *q = (LispObj *) a->high;
4160
4161  adjust_pointers_in_headerless_range(p, q, base, limit, delta);
4162}
4163
4164void
4165nuke_pointers_in_vstack_area(area *a,
4166                             LispObj base,
4167                             LispObj limit)
4168{
4169  LispObj
4170    *p = (LispObj *) a->active,
4171    *q = (LispObj *) a->high;
4172
4173  nuke_pointers_in_headerless_range(p, q, base, limit);
4174}
4175
4176#ifdef PPC
4177void
4178adjust_pointers_in_cstack_area(area *a,
4179                               LispObj base,
4180                               LispObj limit,
4181                               LispObj delta)
4182{
4183  BytePtr
4184    current,
4185    next,
4186    area_limit = a->high,
4187    low = a->low;
4188
4189  for (current = a->active; (current >= low) && (current < area_limit); current = next) {
4190    next = *((BytePtr *)current);
4191    if (next == NULL) break;
4192    if (((next - current) == sizeof(lisp_frame)) &&
4193        (((((lisp_frame *)current)->savefn) == 0) ||
4194         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
4195      adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta);
4196      adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta);
4197    }
4198  }
4199}
4200#endif
4201
4202
4203
4204void
4205adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta)
4206{
4207  TCR *tcr = current;
4208  xframe_list *xframes;
4209  LispObj *tlb_start, *tlb_end;
4210  ExceptionInformation *xp;
4211
4212  do {
4213    xp = tcr->gc_context;
4214    if (xp) {
4215      adjust_pointers_in_xp(xp, base, limit, delta);
4216    }
4217    for (xframes = (xframe_list *) tcr->xframe;
4218         xframes;
4219         xframes = xframes->prev) {
4220      adjust_pointers_in_xp(xframes->curr, base, limit, delta);
4221    }
4222    adjust_pointers_in_range(tcr->tlb_pointer,
4223                             (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
4224                             base,
4225                             limit,
4226                             delta);
4227    tcr = tcr->next;
4228  } while (tcr != current);
4229}
4230
4231void
4232nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit)
4233{
4234  TCR *tcr = current;
4235  xframe_list *xframes;
4236  LispObj *tlb_start, *tlb_end;
4237  ExceptionInformation *xp;
4238
4239  do {
4240    xp = tcr->gc_context;
4241    if (xp) {
4242      nuke_pointers_in_xp(xp, base, limit);
4243    }
4244    for (xframes = (xframe_list *) tcr->xframe;
4245         xframes;
4246         xframes = xframes->prev) {
4247      nuke_pointers_in_xp(xframes->curr, base, limit);
4248    }
4249    nuke_pointers_in_range(tcr->tlb_pointer,
4250                           (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
4251                           base,
4252                           limit);
4253    tcr = tcr->next;
4254  } while (tcr != current);
4255}
4256
4257void
4258adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta)
4259{
4260  /* These need to be special-cased, because xmacptrs are immediate
4261     objects that contain (in their "link" fields") tagged pointers
4262     to other xmacptrs */
4263  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
4264
4265  while ((next = *prev) != (LispObj)NULL) {
4266    adjust_noderef(prev, base, limit, delta);
4267    if (delta < 0) {
4268      /* Assume that we've already moved things */
4269      next = *prev;
4270    }
4271    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
4272  }
4273}
4274   
4275
4276void
4277adjust_pointers_in_dynamic_area(area *a, 
4278                                LispObj base, 
4279                                LispObj limit,
4280                                signed_natural delta)
4281{
4282  natural
4283    nstatic = static_dnodes_for_area(a),
4284    nstatic_bitmap_words = nstatic >> bitmap_shift;
4285  LispObj
4286    *low = (LispObj *) (a->low),
4287    *active = (LispObj *) (a->active),
4288    *dynamic_low = low + (2 * nstatic);
4289
4290  adjust_pointers_in_range(dynamic_low, active, base, limit, delta);
4291
4292  if (nstatic && (nstatic <= a->ndnodes)) {
4293    cons *pagelet_start = (cons *) a->low, *work;
4294    bitvector usedbits = tenured_area->static_used;
4295    natural used, i;
4296   
4297    while (nstatic_bitmap_words--) {
4298      used = *usedbits++;
4299
4300      while (used) {
4301        i = count_leading_zeros(used);
4302        used &= ~(BIT0_MASK >> i);
4303        work = pagelet_start+i;
4304        adjust_noderef(&(work->cdr), base, limit, delta);
4305        adjust_noderef(&(work->car), base, limit, delta);
4306      }
4307      pagelet_start += nbits_in_word;
4308    }
4309  }
4310}
4311
4312void
4313nuke_pointers_in_dynamic_area(area *a, 
4314                              LispObj base, 
4315                              LispObj limit)
4316{
4317  natural
4318    nstatic = static_dnodes_for_area(a),
4319    nstatic_bitmap_words = nstatic >> bitmap_shift;
4320  LispObj
4321    *low = (LispObj *) (a->low),
4322    *active = (LispObj *) (a->active),
4323    *dynamic_low = low + (2 * nstatic);
4324
4325  nuke_pointers_in_range(dynamic_low, active, base, limit);
4326
4327  if (nstatic && (nstatic <= a->ndnodes)) {
4328    cons *pagelet_start = (cons *) a->low, *work;
4329    bitvector usedbits = tenured_area->static_used;
4330    natural used, i;
4331   
4332    while (nstatic_bitmap_words--) {
4333      used = *usedbits++;
4334
4335      while (used) {
4336        i = count_leading_zeros(used);
4337        used &= ~(BIT0_MASK >> i);
4338        work = pagelet_start+i;
4339        nuke_noderef(&(work->cdr), base, limit);
4340        nuke_noderef(&(work->car), base, limit);
4341      }
4342      pagelet_start += nbits_in_word;
4343    }
4344  }
4345}
4346
4347   
4348void
4349adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta)
4350{
4351  area *next_area;
4352  area_code code;
4353
4354  for (next_area = active_dynamic_area; 
4355       (code = next_area->code) != AREA_VOID;
4356       next_area = next_area->succ) {
4357    switch (code) {
4358    case AREA_TSTACK:
4359      adjust_pointers_in_tstack_area(next_area, base, limit, delta);
4360      break;
4361     
4362    case AREA_VSTACK:
4363      adjust_pointers_in_vstack_area(next_area, base, limit, delta);
4364      break;
4365
4366    case AREA_CSTACK:
4367#ifndef X86
4368      adjust_pointers_in_cstack_area(next_area, base, limit, delta);
4369#endif
4370      break;
4371
4372    case AREA_STATIC:
4373    case AREA_MANAGED_STATIC:
4374      adjust_pointers_in_range((LispObj *) (next_area->low),
4375                               (LispObj *) (next_area->active),
4376                               base,
4377                               limit,
4378                               delta);
4379      break;
4380
4381    case AREA_DYNAMIC:
4382      adjust_pointers_in_dynamic_area(next_area, base, limit, delta);
4383      break;
4384    }
4385  }
4386  adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta);
4387  adjust_gcable_ptrs(base, limit, delta);
4388}
4389
4390void
4391nuke_all_pointers(LispObj base, LispObj limit)
4392{
4393  area *next_area;
4394  area_code code;
4395
4396  for (next_area = active_dynamic_area; 
4397       (code = next_area->code) != AREA_VOID;
4398       next_area = next_area->succ) {
4399    switch (code) {
4400    case AREA_TSTACK:
4401      nuke_pointers_in_tstack_area(next_area, base, limit);
4402      break;
4403     
4404    case AREA_VSTACK:
4405      nuke_pointers_in_vstack_area(next_area, base, limit);
4406      break;
4407
4408    case AREA_CSTACK:
4409      /* There aren't any "nukable" pointers in a cstack area */
4410      break;
4411
4412    case AREA_STATIC:
4413    case AREA_MANAGED_STATIC:
4414      nuke_pointers_in_range((LispObj *) (next_area->low),
4415                               (LispObj *) (next_area->active),
4416                               base,
4417                               limit);
4418      break;
4419
4420    case AREA_DYNAMIC:
4421      nuke_pointers_in_dynamic_area(next_area, base, limit);
4422      break;
4423    }
4424  }
4425  nuke_pointers_in_tcrs(get_tcr(false), base, limit);
4426}
4427
4428#ifndef MREMAP_MAYMOVE
4429#define MREMAP_MAYMOVE 1
4430#endif
4431
4432#if defined(FREEBSD) || defined(SOLARIS)
4433void *
4434freebsd_mremap(void *old_address, 
4435               size_t old_size, 
4436               size_t new_size, 
4437               unsigned long flags)
4438{
4439  return old_address;
4440}
4441#define mremap freebsd_mremap
4442
4443#endif
4444
4445#ifdef DARWIN
4446void *
4447darwin_mremap(void *old_address, 
4448              size_t old_size, 
4449              size_t new_size, 
4450              unsigned long flags)
4451{
4452  void *end = (void *) ((char *)old_address+old_size);
4453
4454  if (old_size == new_size) {
4455    return old_address;
4456  }
4457  if (new_size < old_size) {
4458    munmap(end, old_size-new_size);
4459    return old_address;
4460  }
4461  {
4462    void * new_address = mmap(NULL,
4463                              new_size,
4464                              PROT_READ|PROT_WRITE,
4465                              MAP_PRIVATE | MAP_ANON,
4466                              -1,
4467                              0);
4468    if (new_address !=  MAP_FAILED) {
4469      vm_copy(mach_task_self(),
4470              (vm_address_t)old_address,
4471              old_size,
4472              (vm_address_t)new_address);
4473      munmap(old_address, old_size);
4474    }
4475    return new_address;
4476  }
4477}
4478
4479#define mremap darwin_mremap
4480#endif
4481
4482Boolean
4483resize_used_bitvector(natural new_dnodes, bitvector *newbits)
4484{
4485  natural
4486    old_dnodes = tenured_area->static_dnodes,
4487    old_page_aligned_size =
4488    (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3),
4489                         log2_page_size)),
4490    new_page_aligned_size =
4491    (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3),
4492                         log2_page_size));
4493  bitvector old_used = tenured_area->static_used, new_used = NULL;
4494
4495  if (old_page_aligned_size == new_page_aligned_size) {
4496    *newbits = old_used;
4497    return true;
4498  }
4499
4500  if (old_used == NULL) {
4501    new_used = (bitvector)mmap(NULL,
4502                               new_page_aligned_size,
4503                               PROT_READ|PROT_WRITE,
4504                               MAP_PRIVATE | MAP_ANON,
4505                               -1,
4506                               0);
4507    if (new_used == MAP_FAILED) {
4508      *newbits = NULL;
4509      return false;
4510    } else {
4511      *newbits = new_used;
4512      return true;
4513    }
4514  }
4515  if (new_page_aligned_size == 0) {
4516    munmap((void *)old_used, old_page_aligned_size);
4517    *newbits = NULL;
4518    return true;
4519  }
4520   
4521  /* Have to try to remap the old bitmap.  That's implementation-dependent,
4522     and (naturally) Mach sucks, but no one understands how.
4523  */
4524  new_used = mremap(old_used, 
4525                    old_page_aligned_size, 
4526                    new_page_aligned_size, 
4527                    MREMAP_MAYMOVE);
4528  if (new_used == MAP_FAILED) {
4529    *newbits = NULL;
4530    return false;
4531  }
4532  *newbits = new_used;
4533  return true;
4534}
4535
4536 
4537int
4538grow_hons_area(signed_natural delta_in_bytes)
4539{
4540  bitvector new_used;
4541  area *ada = active_dynamic_area;
4542  natural
4543    delta_in_dnodes = delta_in_bytes >> dnode_shift,
4544    current_static_dnodes = tenured_area->static_dnodes,
4545    new_static_dnodes;
4546   
4547  delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word);
4548  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
4549  delta_in_bytes = delta_in_dnodes << dnode_shift;
4550  if (grow_dynamic_area((natural) delta_in_bytes)) {
4551    LispObj
4552      base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)),
4553      oldactive = (LispObj) ada->active,
4554      limit = area_dnode(oldactive, base);
4555    if (!resize_used_bitvector(new_static_dnodes, &new_used)) {
4556      shrink_dynamic_area(delta_in_bytes);
4557      return -1;
4558    }
4559    tenured_area->static_used = new_used;
4560    adjust_all_pointers(base, limit, delta_in_bytes);
4561    memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base);
4562    ada->ndnodes = area_dnode(ada->high, ada->low);
4563    ada->active += delta_in_bytes;
4564    {
4565      LispObj *p;
4566      natural i;
4567      for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0;
4568           i< delta_in_dnodes;
4569           i++ ) {
4570        *p++ = undefined;
4571        *p++ = undefined;
4572      }
4573      tenured_area->static_dnodes += delta_in_dnodes;
4574         
4575    }
4576    return 0;
4577  }
4578  return -1;
4579}
4580
4581int 
4582shrink_hons_area(signed_natural delta_in_bytes)
4583{
4584  area *ada = active_dynamic_area;
4585  signed_natural
4586    delta_in_dnodes = delta_in_bytes >> dnode_shift;
4587  natural
4588    current_static_dnodes = tenured_area->static_dnodes,
4589    new_static_dnodes;
4590  LispObj base, limit, oldactive;
4591  bitvector newbits;
4592
4593   
4594  delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word);
4595  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
4596  delta_in_bytes = delta_in_dnodes << dnode_shift;
4597  oldactive = (LispObj) (ada->active);
4598
4599  resize_used_bitvector(new_static_dnodes, &newbits);
4600  tenured_area->static_used = newbits; /* redundant */
4601
4602  memmove(ada->low+(new_static_dnodes << dnode_shift),
4603          ada->low+(current_static_dnodes << dnode_shift),
4604          oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift)));
4605  tenured_area->static_dnodes = new_static_dnodes;
4606  ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */
4607  shrink_dynamic_area(-delta_in_bytes);
4608
4609  base = (LispObj) (tenured_area->low + 
4610                    (new_static_dnodes << dnode_shift));
4611  limit = area_dnode(tenured_area->low + 
4612                     (current_static_dnodes << dnode_shift), base);
4613  nuke_all_pointers(base, limit);
4614
4615  base = (LispObj) (tenured_area->low + 
4616                    (current_static_dnodes << dnode_shift));
4617  limit = area_dnode(oldactive, base);
4618  adjust_all_pointers(base, limit, delta_in_bytes);
4619
4620  xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift),
4621                      ada->active-(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift)));
4622  return 0;
4623}
4624
4625int
4626change_hons_area_size(TCR *tcr, signed_natural delta_in_bytes)
4627{
4628  if (delta_in_bytes > 0) {
4629    return grow_hons_area(delta_in_bytes);
4630  }
4631  if (delta_in_bytes < 0) {
4632    return shrink_hons_area(delta_in_bytes);
4633  }
4634  return 0;
4635}
4636
Note: See TracBrowser for help on using the repository browser.