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

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

Call update_self_references() on x8632 only.

  • 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 = false, GCverbose = false;
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#ifdef X8632
2576            update_self_references(f);
2577#endif
2578            while(elements--) {
2579              *dest++ = node_forwarding_address(*src++);
2580            }
2581            if (((LispObj)src) & node_size) {
2582              src++;
2583              *dest++ = 0;
2584            }
2585          } else {
2586            if ((header_subtag(node) == subtag_hash_vector) &&
2587                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
2588              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
2589              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2590             
2591              *dest++ = node;
2592              elements -= skip;
2593              while(skip--) {
2594                *dest++ = node_forwarding_address(*src++);
2595              }
2596              /* There should be an even number of (key/value) pairs in elements;
2597                 an extra alignment word follows. */
2598              elements >>= 1;
2599              while (elements--) {
2600                if (hashp) {
2601                  node = *src++;
2602                  new = node_forwarding_address(node);
2603                  if (new != node) {
2604                    hashp->flags |= nhash_key_moved_mask;
2605                    hashp = NULL;
2606                    *dest++ = new;
2607                  } else {
2608                    *dest++ = node;
2609                  }
2610                } else {
2611                  *dest++ = node_forwarding_address(*src++);
2612                }
2613                *dest++ = node_forwarding_address(*src++);
2614              }
2615              *dest++ = 0;
2616              src++;
2617            } else {
2618              *dest++ = node;
2619              *dest++ = node_forwarding_address(*src++);
2620              while(--node_dnodes) {
2621                *dest++ = node_forwarding_address(*src++);
2622                *dest++ = node_forwarding_address(*src++);
2623              }
2624            }
2625          }
2626          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2627        } else if (immheader_tag_p(tag)) {
2628          *dest++ = node;
2629          *dest++ = *src++;
2630          elements = header_element_count(node);
2631          tag = header_subtag(node);
2632
2633#ifdef X8664
2634          switch(fulltag_of(tag)) {
2635          case ivector_class_64_bit:
2636            imm_dnodes = ((elements+1)+1)>>1;
2637            break;
2638          case ivector_class_32_bit:
2639            imm_dnodes = (((elements+2)+3)>>2);
2640            break;
2641          case ivector_class_other_bit:
2642            if (tag == subtag_bit_vector) {
2643              imm_dnodes = (((elements+64)+127)>>7);
2644            } else if (tag >= min_8_bit_ivector_subtag) {
2645              imm_dnodes = (((elements+8)+15)>>4);
2646            } else {
2647              imm_dnodes = (((elements+4)+7)>>3);
2648            }
2649          }
2650#endif
2651#ifdef X8632
2652          if (tag <= max_32_bit_ivector_subtag) {
2653            if (tag == subtag_code_vector) {
2654              GCrelocated_code_vector = true;
2655            }
2656            imm_dnodes = (((elements+1)+1)>>1);
2657          } else if (tag <= max_8_bit_ivector_subtag) {
2658            imm_dnodes = (((elements+4)+7)>>3);
2659          } else if (tag <= max_16_bit_ivector_subtag) {
2660            imm_dnodes = (((elements+2)+3)>>2);
2661          } else if (tag == subtag_bit_vector) {
2662            imm_dnodes = (((elements+32)+63)>>6);
2663          } else {
2664            imm_dnodes = elements+1;
2665          }
2666#endif
2667
2668          dnode += imm_dnodes;
2669          while (--imm_dnodes) {
2670            *dest++ = *src++;
2671            *dest++ = *src++;
2672          }
2673          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2674        } else {
2675          *dest++ = node_forwarding_address(node);
2676          *dest++ = node_forwarding_address(*src++);
2677          bits &= ~(BIT0_MASK >> bitidx);
2678          dnode++;
2679          bitidx++;
2680        }
2681      }
2682    }
2683  }
2684  return ptr_to_lispobj(dest);
2685}
2686
2687
2688Boolean
2689youngest_non_null_area_p (area *a)
2690{
2691  if (a->active == a->high) {
2692    return false;
2693  } else {
2694    for (a = a->younger; a; a = a->younger) {
2695      if (a->active != a->high) {
2696        return false;
2697      }
2698    }
2699  };
2700  return true;
2701}
2702
2703Boolean just_purified_p = false;
2704
2705
2706/*
2707  All thread's stack areas have been "normalized", as
2708  has the dynamic heap.  (The "active" pointer in these areas
2709  matches the stack pointer/freeptr value at the time that
2710  the exception occurred.)
2711*/
2712
2713
2714#define get_time(when) gettimeofday(&when, NULL)
2715
2716
2717
2718#ifdef FORCE_DWS_MARK
2719#warning recursive marker disabled for testing; remember to re-enable it
2720#endif
2721
2722void 
2723gc(TCR *tcr, signed_natural param)
2724{
2725  xframe_list *xframes = (tcr->xframe);
2726  struct timeval start, stop;
2727  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
2728  unsigned timeidx = 1;
2729  paging_info paging_info_start;
2730  xframe_list *x;
2731  LispObj
2732    pkg,
2733    itabvec = 0;
2734  BytePtr oldfree = a->active;
2735  TCR *other_tcr;
2736  natural static_dnodes;
2737
2738#ifndef FORCE_DWS_MARK
2739  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
2740    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
2741  } else {
2742    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
2743  }
2744#else
2745  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
2746#endif
2747
2748  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
2749  if (GCephemeral_low) {
2750    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
2751  } else {
2752    GCn_ephemeral_dnodes = 0;
2753  }
2754 
2755  if (GCn_ephemeral_dnodes) {
2756    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
2757  } else {
2758    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
2759  }
2760
2761  if (GCephemeral_low) {
2762    if ((oldfree-g1_area->low) < g1_area->threshold) {
2763      to = g1_area;
2764      note = a;
2765      timeidx = 4;
2766    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
2767      to = g2_area;
2768      from = g1_area;
2769      note = g1_area;
2770      timeidx = 3;
2771    } else {
2772      to = tenured_area;
2773      from = g2_area;
2774      note = g2_area;
2775      timeidx = 2;
2776    } 
2777  } else {
2778    note = tenured_area;
2779  }
2780
2781  if (GCverbose) {
2782    char buf[16];
2783
2784    sample_paging_info(&paging_info_start);
2785    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
2786    if (GCephemeral_low) {
2787      fprintf(stderr,
2788              "\n\n;;; Starting EGC of generation %d",
2789              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
2790    } else {
2791      fprintf(stderr,"\n\n;;; Starting full GC");
2792    }
2793    fprintf(stderr, ", %s bytes allocated.\n", buf);
2794  }
2795
2796
2797  get_time(start);
2798  lisp_global(IN_GC) = (1<<fixnumshift);
2799
2800
2801  if (just_purified_p) {
2802    just_purified_p = false;
2803    GCDebug = false;
2804  } else {
2805    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
2806    if (GCDebug) {
2807      check_all_areas();
2808    }
2809  }
2810
2811  if (from) {
2812    untenure_from_area(from);
2813  }
2814  static_dnodes = static_dnodes_for_area(a);
2815  GCmarkbits = a->markbits;
2816  GCarealow = ptr_to_lispobj(a->low);
2817  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
2818  GCndnodes_in_area = gc_area_dnode(oldfree);
2819
2820  if (GCndnodes_in_area) {
2821    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
2822    GCdynamic_markbits = 
2823      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
2824
2825    zero_bits(GCmarkbits, GCndnodes_in_area);
2826    GCweakvll = (LispObj)NULL;
2827 
2828
2829    if (GCn_ephemeral_dnodes == 0) {
2830      /* For GCTWA, mark the internal package hash table vector of
2831       *PACKAGE*, but don't mark its contents. */
2832      {
2833        LispObj
2834          itab;
2835        natural
2836          dnode, ndnodes;
2837     
2838        pkg = nrs_PACKAGE.vcell;
2839        if ((fulltag_of(pkg) == fulltag_misc) &&
2840            (header_subtag(header_of(pkg)) == subtag_package)) {
2841          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
2842          itabvec = car(itab);
2843          dnode = gc_area_dnode(itabvec);
2844          if (dnode < GCndnodes_in_area) {
2845            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
2846            set_n_bits(GCmarkbits, dnode, ndnodes);
2847          }
2848        }
2849      }
2850    }
2851
2852    {
2853      area *next_area;
2854      area_code code;
2855
2856      /* Could make a jump table instead of the typecase */
2857
2858      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2859        switch (code) {
2860        case AREA_TSTACK:
2861          mark_tstack_area(next_area);
2862          break;
2863
2864        case AREA_VSTACK:
2865          mark_vstack_area(next_area);
2866          break;
2867
2868        case AREA_STATIC:
2869        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
2870          /* In both of these cases, we -could- use the area's "markbits"
2871             bitvector as a reference map.  It's safe (but slower) to
2872             ignore that map and process the entire area.
2873          */
2874          if (next_area->younger == NULL) {
2875            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
2876          }
2877          break;
2878
2879        default:
2880          break;
2881        }
2882      }
2883    }
2884 
2885    if (lisp_global(OLDEST_EPHEMERAL)) {
2886      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
2887    }
2888
2889    other_tcr = tcr;
2890    do {
2891      mark_tcr_xframes(other_tcr);
2892      mark_tcr_tlb(other_tcr);
2893      other_tcr = other_tcr->next;
2894    } while (other_tcr != tcr);
2895
2896
2897
2898
2899    /* Go back through *package*'s internal symbols, marking
2900       any that aren't worthless.
2901    */
2902   
2903    if (itabvec) {
2904      natural
2905        i,
2906        n = header_element_count(header_of(itabvec));
2907      LispObj
2908        sym,
2909        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
2910
2911      for (i = 0; i < n; i++) {
2912        sym = *raw++;
2913#ifdef X8664
2914        if (fulltag_of(sym) == fulltag_symbol) {
2915#endif
2916#ifdef X8632
2917        if (fulltag_of(sym) == fulltag_misc) {
2918#endif
2919          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
2920          natural dnode = gc_area_dnode(sym);
2921         
2922          if ((dnode < GCndnodes_in_area) &&
2923              (!ref_bit(GCmarkbits,dnode))) {
2924            /* Symbol is in GC area, not marked.
2925               Mark it if fboundp, boundp, or if
2926               it has a plist or another home package.
2927            */
2928           
2929            if (FBOUNDP(rawsym) ||
2930                BOUNDP(rawsym) ||
2931                (rawsym->flags != 0) || /* SPECIAL, etc. */
2932                (rawsym->plist != lisp_nil) ||
2933                ((rawsym->package_predicate != pkg) &&
2934                 (rawsym->package_predicate != lisp_nil))) {
2935              mark_root(sym);
2936            }
2937          }
2938        }
2939      }
2940    }
2941
2942    (void)markhtabvs();
2943
2944    if (itabvec) {
2945      natural
2946        i,
2947        n = header_element_count(header_of(itabvec));
2948      LispObj
2949        sym,
2950        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
2951
2952      for (i = 0; i < n; i++, raw++) {
2953        sym = *raw;
2954#ifdef X8664
2955        if (fulltag_of(sym) == fulltag_symbol) {
2956#endif
2957#ifdef X8632
2958        if (fulltag_of(sym) == fulltag_misc) {
2959#endif
2960          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
2961          natural dnode = gc_area_dnode(sym);
2962
2963          if ((dnode < GCndnodes_in_area) &&
2964              (!ref_bit(GCmarkbits,dnode))) {
2965            *raw = unbound_marker;
2966          }
2967        }
2968      }
2969    }
2970 
2971    reap_gcable_ptrs();
2972
2973    GCrelocptr = global_reloctab;
2974    GCfirstunmarked = calculate_relocation();
2975
2976    forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
2977
2978    other_tcr = tcr;
2979    do {
2980      forward_tcr_xframes(other_tcr);
2981      forward_tcr_tlb(other_tcr);
2982      other_tcr = other_tcr->next;
2983    } while (other_tcr != tcr);
2984
2985 
2986    forward_gcable_ptrs();
2987
2988
2989
2990    {
2991      area *next_area;
2992      area_code code;
2993
2994      /* Could make a jump table instead of the typecase */
2995
2996      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2997        switch (code) {
2998        case AREA_TSTACK:
2999          forward_tstack_area(next_area);
3000          break;
3001
3002        case AREA_VSTACK:
3003          forward_vstack_area(next_area);
3004          break;
3005
3006
3007        case AREA_STATIC:
3008        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
3009          if (next_area->younger == NULL) {
3010            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
3011          }
3012          break;
3013
3014        default:
3015          break;
3016        }
3017      }
3018    }
3019 
3020    if (GCephemeral_low) {
3021      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
3022    } else {
3023      /* Full GC, need to process static space */
3024      forward_and_resolve_static_references(a);
3025    }
3026 
3027    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
3028    if (to) {
3029      tenure_to_area(to);
3030    }
3031
3032    zero_memory_range(a->active, oldfree);
3033
3034    resize_dynamic_heap(a->active,
3035                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
3036
3037    /*
3038      If the EGC is enabled: If there's no room for the youngest
3039      generation, untenure everything.  If this was a full GC and
3040      there's now room for the youngest generation, tenure everything.
3041    */
3042    if (a->older != NULL) {
3043      natural nfree = (a->high - a->active);
3044
3045
3046      if (nfree < a->threshold) {
3047        untenure_from_area(tenured_area);
3048      } else {
3049        if (GCephemeral_low == 0) {
3050          tenure_to_area(tenured_area);
3051        }
3052      }
3053    }
3054  }
3055  lisp_global(GC_NUM) += (1<<fixnumshift);
3056  if (note) {
3057    note->gccount += (1<<fixnumshift);
3058  }
3059
3060  if (GCDebug) {
3061    check_all_areas();
3062  }
3063
3064 
3065  lisp_global(IN_GC) = 0;
3066
3067  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
3068  get_time(stop);
3069
3070  {
3071    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
3072    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
3073    LispObj val;
3074    struct timeval *timeinfo, elapsed;
3075
3076    val = total_gc_microseconds->vcell;
3077    if ((fulltag_of(val) == fulltag_misc) &&
3078        (header_subtag(header_of(val)) == subtag_macptr)) {
3079      timersub(&stop, &start, &elapsed);
3080      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
3081      timeradd(timeinfo,  &elapsed, timeinfo);
3082      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
3083    }
3084
3085    val = total_bytes_freed->vcell;
3086    if ((fulltag_of(val) == fulltag_misc) &&
3087        (header_subtag(header_of(val)) == subtag_macptr)) {
3088      long long justfreed = oldfree - a->active;
3089      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
3090      if (GCverbose) {
3091        char buf[16];
3092        paging_info paging_info_stop;
3093       
3094        sample_paging_info(&paging_info_stop);
3095        if (justfreed <= heap_segment_size) {
3096          justfreed = 0;
3097        }
3098        comma_output_decimal(buf,16,justfreed);
3099        if (note == tenured_area) {
3100          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
3101        } else {
3102          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n", 
3103                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
3104                  buf, 
3105                  elapsed.tv_sec, elapsed.tv_usec);
3106        }
3107        report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
3108      }
3109    }
3110  }
3111}
3112
3113     
3114   
3115/*
3116  Total the (physical) byte sizes of all ivectors in the indicated memory range
3117*/
3118
3119natural
3120unboxed_bytes_in_range(LispObj *start, LispObj *end)
3121{
3122  natural total=0, elements, tag, subtag, bytes;
3123  LispObj header;
3124
3125  while (start < end) {
3126    header = *start;
3127    tag = fulltag_of(header);
3128   
3129    if ((nodeheader_tag_p(tag)) ||
3130        (immheader_tag_p(tag))) {
3131      elements = header_element_count(header);
3132      if (nodeheader_tag_p(tag)) {
3133        start += ((elements+2) & ~1);
3134      } else {
3135        subtag = header_subtag(header);
3136
3137#ifdef X8664
3138        switch(fulltag_of(header)) {
3139        case ivector_class_64_bit:
3140          bytes = 8 + (elements<<3);
3141          break;
3142        case ivector_class_32_bit:
3143          bytes = 8 + (elements<<2);
3144          break;
3145        case ivector_class_other_bit:
3146        default:
3147          if (subtag == subtag_bit_vector) {
3148            bytes = 8 + ((elements+7)>>3);
3149          } else if (subtag >= min_8_bit_ivector_subtag) {
3150            bytes = 8 + elements;
3151          } else {
3152            bytes = 8 + (elements<<1);
3153          }
3154        }
3155#endif
3156#ifdef X8632
3157          if (subtag <= max_32_bit_ivector_subtag) {
3158            bytes = 4 + (elements<<2);
3159          } else if (subtag <= max_8_bit_ivector_subtag) {
3160            bytes = 4 + elements;
3161          } else if (subtag <= max_16_bit_ivector_subtag) {
3162            bytes = 4 + (elements<<1);
3163          } else if (subtag == subtag_double_float_vector) {
3164            bytes = 8 + (elements<<3);
3165          } else {
3166            bytes = 4 + ((elements+7)>>3);
3167          }
3168#endif
3169
3170        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
3171        total += bytes;
3172        start += (bytes >> node_shift);
3173      }
3174    } else {
3175      start += 2;
3176    }
3177  }
3178  return total;
3179}
3180
3181
3182/*
3183  This assumes that it's getting called with a simple-{base,general}-string
3184  or code vector as an argument and that there's room for the object in the
3185  destination area.
3186*/
3187
3188
3189LispObj
3190purify_displaced_object(LispObj obj, area *dest, natural disp)
3191{
3192#ifdef X8664
3193  BytePtr
3194    free = dest->active,
3195    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
3196  LispObj
3197    header = header_of(obj), 
3198    new;
3199  natural
3200    subtag = header_subtag(header), 
3201    element_count = header_element_count(header),
3202    physbytes;
3203
3204  switch(subtag) {
3205  case subtag_simple_base_string:
3206    physbytes = node_size + (element_count << 2);
3207    break;
3208
3209#ifndef X86
3210  case subtag_code_vector:
3211    physbytes = node_size + (element_count << 2);
3212    break;
3213#endif
3214
3215  default:
3216    Bug(NULL, "Can't purify object at 0x%08x", obj);
3217    return obj;
3218  }
3219  physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1);
3220  dest->active += physbytes;
3221
3222  new = ptr_to_lispobj(free)+disp;
3223
3224  memcpy(free, (BytePtr)old, physbytes);
3225  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
3226  /* Actually, it's best to always leave a trail, for two reasons.
3227     a) We may be walking the same heap that we're leaving forwaring
3228     pointers in, so we don't want garbage that we leave behind to
3229     look like a header.
3230     b) We'd like to be able to forward code-vector locatives, and
3231     it's easiest to do so if we leave a {forward_marker, dnode_locative}
3232     pair at every doubleword in the old vector.
3233     */
3234  while(physbytes) {
3235    *old++ = (BytePtr) forward_marker;
3236    *old++ = (BytePtr) free;
3237    free += dnode_size;
3238    physbytes -= dnode_size;
3239  }
3240  return new;
3241#endif
3242}
3243
3244LispObj
3245purify_object(LispObj obj, area *dest)
3246{
3247  return purify_displaced_object(obj, dest, fulltag_of(obj));
3248}
3249
3250
3251#define FORWARD_ONLY 0
3252#define COPY_CODE (1<<0)
3253#define COPY_STRINGS (1<<1)
3254
3255
3256/*
3257  This may overestimate a bit, if the same symbol is accessible from multiple
3258  packages.
3259*/
3260natural
3261interned_pname_bytes_in_range(LispObj *start, LispObj *end)
3262{
3263  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
3264  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
3265  package *p;
3266  cons *c;
3267  natural elements, i, nbytes = 0;
3268
3269#ifdef X8664
3270  while (fulltag_of(pkg_list) == fulltag_cons) {
3271    c = (cons *) ptr_from_lispobj(untag(pkg_list));
3272    p = (package *) ptr_from_lispobj(untag(c->car));
3273    pkg_list = c->cdr;
3274    c = (cons *) ptr_from_lispobj(untag(p->itab));
3275    htab = c->car;
3276    elements = header_element_count(header_of(htab));
3277    for (i = 1; i<= elements; i++) {
3278      obj = deref(htab,i);
3279      if (fulltag_of(obj) == fulltag_symbol) {
3280        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3281        pname = rawsym->pname;
3282
3283        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
3284          pname_header = header_of(pname);
3285          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
3286        }
3287      }
3288    }
3289    c = (cons *) ptr_from_lispobj(untag(p->etab));
3290    htab = c->car;
3291    elements = header_element_count(header_of(htab));
3292    for (i = 1; i<= elements; i++) {
3293      obj = deref(htab,i);
3294      if (fulltag_of(obj) == fulltag_symbol) {
3295        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3296        pname = rawsym->pname;
3297
3298        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
3299          pname_header = header_of(pname);
3300          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
3301        }
3302      }
3303    }
3304  }
3305#endif
3306  return nbytes;
3307}
3308
3309Boolean
3310copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy)
3311{
3312  LispObj obj = *ref, header, new;
3313  natural tag = fulltag_of(obj), header_tag, header_subtag;
3314  Boolean changed = false;
3315
3316#ifdef X8664
3317  if ((tag == fulltag_misc) &&
3318      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
3319      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
3320    header = deref(obj, 0);
3321    if (header == forward_marker) { /* already copied */
3322      *ref = (untag(deref(obj,1)) + tag);
3323      changed = true;
3324    } else {
3325      header_tag = fulltag_of(header);
3326      if (immheader_tag_p(header_tag)) {
3327        header_subtag = header_subtag(header);
3328        if ((what_to_copy & COPY_STRINGS) && 
3329            ((header_subtag == subtag_simple_base_string))) {
3330          new = purify_object(obj, dest);
3331          *ref = new;
3332          changed = (new != obj);
3333        }
3334      }
3335    }
3336  }
3337#endif
3338  return changed;
3339}
3340
3341
3342void purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
3343{
3344  while (start < end) { 
3345    copy_ivector_reference(start, low, high, to, what);
3346    start++;
3347  }
3348}
3349   
3350void
3351purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
3352{
3353  LispObj header;
3354  unsigned tag;
3355  natural nwords;
3356  hash_table_vector_header *hashp;
3357
3358  while (start < end) {
3359    header = *start;
3360    if (header == forward_marker) {
3361      start += 2;
3362    } else {
3363      tag = fulltag_of(header);
3364      if (immheader_tag_p(tag)) {
3365        start = (LispObj *)skip_over_ivector((natural)start, header);
3366      } else if (nodeheader_tag_p(tag)) {
3367        nwords = header_element_count(header);
3368        nwords += (1 - (nwords&1));
3369        if ((header_subtag(header) == subtag_hash_vector) &&
3370          ((((hash_table_vector_header *)start)->flags) & 
3371           nhash_track_keys_mask)) {
3372          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
3373
3374          hashp = (hash_table_vector_header *) start;
3375          start++;
3376          nwords -= skip;
3377          while(skip--) {
3378            copy_ivector_reference(start, low, high, to, what);
3379            start++;
3380          }
3381          /* "nwords" is odd at this point: there are (floor nwords 2)
3382             key/value pairs to look at, and then an extra word for
3383             alignment.  Process them two at a time, then bump "start"
3384             past the alignment word. */
3385          nwords >>= 1;
3386          while(nwords--) {
3387            if (copy_ivector_reference(start, low, high, to, what) && hashp) {
3388              hashp->flags |= nhash_key_moved_mask;
3389              hashp = NULL;
3390            }
3391            start++;
3392            copy_ivector_reference(start, low, high, to, what);
3393            start++;
3394          }
3395          *start++ = 0;
3396        } else {
3397          if (header_subtag(header) == subtag_function) {
3398#ifdef X8632
3399            int skip = (unsigned short)(start[1]);
3400#else
3401            int skip = (int)(start[1]);
3402#endif
3403            start += skip;
3404            nwords -= skip;
3405          }
3406          start++;
3407          while(nwords--) {
3408            copy_ivector_reference(start, low, high, to, what);
3409            start++;
3410          }
3411        }
3412      } else {
3413        /* Not a header, just a cons cell */
3414        copy_ivector_reference(start, low, high, to, what);
3415        start++;
3416        copy_ivector_reference(start, low, high, to, what);
3417        start++;
3418      }
3419    }
3420  }
3421}
3422       
3423/* Purify references from tstack areas */
3424void
3425purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3426{
3427  LispObj
3428    *current,
3429    *next,
3430    *start = (LispObj *) (a->active),
3431    *end = start,
3432    *limit = (LispObj *) (a->high);
3433
3434  for (current = start;
3435       end != limit;
3436       current = next) {
3437    next = (LispObj *) ptr_from_lispobj(*current);
3438    end = ((next >= start) && (next < limit)) ? next : limit;
3439    if (current[1] == 0) {
3440      purify_range(current+2, end, low, high, to, what);
3441    }
3442  }
3443}
3444
3445/* Purify a vstack area */
3446void
3447purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3448{
3449  LispObj
3450    *p = (LispObj *) a->active,
3451    *q = (LispObj *) a->high;
3452 
3453  purify_headerless_range(p, q, low, high, to, what);
3454}
3455
3456
3457void
3458purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what)
3459{
3460  natural *regs = (natural *) xpGPRvector(xp);
3461
3462
3463#ifdef X8664
3464  copy_ivector_reference(&(regs[Iarg_z]), low, high, to, what);
3465  copy_ivector_reference(&(regs[Iarg_y]), low, high, to, what);
3466  copy_ivector_reference(&(regs[Iarg_x]), low, high, to, what);
3467  copy_ivector_reference(&(regs[Isave3]), low, high, to, what);
3468  copy_ivector_reference(&(regs[Isave2]), low, high, to, what);
3469  copy_ivector_reference(&(regs[Isave1]), low, high, to, what);
3470  copy_ivector_reference(&(regs[Isave0]), low, high, to, what);
3471  copy_ivector_reference(&(regs[Ifn]), low, high, to, what);
3472  copy_ivector_reference(&(regs[Itemp0]), low, high, to, what);
3473  copy_ivector_reference(&(regs[Itemp1]), low, high, to, what);
3474  copy_ivector_reference(&(regs[Itemp2]), low, high, to, what);
3475#if 0
3476  purify_locref(&(regs[Iip]), low, high, to, what);
3477#endif
3478#else
3479#endif
3480}
3481
3482void
3483purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3484{
3485  natural n = tcr->tlb_limit;
3486  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3487
3488  purify_range(start, end, low, high, to, what);
3489}
3490
3491void
3492purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3493{
3494  xframe_list *xframes;
3495  ExceptionInformation *xp;
3496 
3497  xp = tcr->gc_context;
3498  if (xp) {
3499    purify_xp(xp, low, high, to, what);
3500  }
3501
3502  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3503    purify_xp(xframes->curr, low, high, to, what);
3504  }
3505}
3506
3507
3508void
3509purify_areas(BytePtr low, BytePtr high, area *target, int what)
3510{
3511  area *next_area;
3512  area_code code;
3513     
3514  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3515    switch (code) {
3516    case AREA_TSTACK:
3517      purify_tstack_area(next_area, low, high, target, what);
3518      break;
3519     
3520    case AREA_VSTACK:
3521      purify_vstack_area(next_area, low, high, target, what);
3522      break;
3523     
3524    case AREA_CSTACK:
3525#ifdef PPC
3526      purify_cstack_area(next_area, low, high, target, what);
3527#endif
3528      break;
3529     
3530    case AREA_STATIC:
3531    case AREA_DYNAMIC:
3532      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what);
3533      break;
3534     
3535    default:
3536      break;
3537    }
3538  }
3539}
3540
3541/*
3542  So far, this is mostly for save_application's benefit.
3543  We -should- be able to return to lisp code after doing this,
3544  however.
3545
3546*/
3547
3548
3549int
3550purify(TCR *tcr, signed_natural param)
3551{
3552  extern area *extend_readonly_area(unsigned);
3553  area
3554    *a = active_dynamic_area,
3555    *new_pure_area;
3556
3557  TCR  *other_tcr;
3558  natural max_pure_size;
3559  OSErr err;
3560  BytePtr new_pure_start;
3561
3562#ifdef X8664
3563
3564  max_pure_size = interned_pname_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
3565                                         (LispObj *) a->active);
3566  new_pure_area = extend_readonly_area(max_pure_size);
3567  if (new_pure_area) {
3568    new_pure_start = new_pure_area->active;
3569    lisp_global(IN_GC) = (1<<fixnumshift);
3570
3571    /*
3572      First, loop thru *all-packages* and purify the pnames of all
3573      interned symbols.  Then walk every place that could reference
3574      a heap-allocated object (all_areas, the xframe_list) and
3575      purify code_vectors (and update the odd case of a shared
3576      reference to a pname.)
3577       
3578      Make the new_pure_area executable, just in case.
3579
3580      Caller will typically GC again (and that should recover quite a bit of
3581      the dynamic heap.)
3582      */
3583
3584    {
3585      lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
3586      LispObj pkg_list = rawsym->vcell, htab, obj;
3587      package *p;
3588      cons *c;
3589      natural elements, i;
3590
3591      while (fulltag_of(pkg_list) == fulltag_cons) {
3592        c = (cons *) ptr_from_lispobj(untag(pkg_list));
3593        p = (package *) ptr_from_lispobj(untag(c->car));
3594        pkg_list = c->cdr;
3595        c = (cons *) ptr_from_lispobj(untag(p->itab));
3596        htab = c->car;
3597        elements = header_element_count(header_of(htab));
3598        for (i = 1; i<= elements; i++) {
3599          obj = deref(htab,i);
3600          if (fulltag_of(obj) == fulltag_symbol) {
3601            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3602            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3603          }
3604        }
3605        c = (cons *) ptr_from_lispobj(untag(p->etab));
3606        htab = c->car;
3607        elements = header_element_count(header_of(htab));
3608        for (i = 1; i<= elements; i++) {
3609          obj = deref(htab,i);
3610          if (fulltag_of(obj) == fulltag_symbol) {
3611            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3612            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3613          }
3614        }
3615      }
3616    }
3617   
3618    purify_areas(a->low, a->active, new_pure_area, FORWARD_ONLY);
3619   
3620    other_tcr = tcr;
3621    do {
3622      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
3623      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
3624      other_tcr = other_tcr->next;
3625    } while (other_tcr != tcr);
3626
3627
3628    {
3629      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
3630      if (puresize != 0) {
3631        xMakeDataExecutable(new_pure_start, puresize);
3632 
3633      }
3634    }
3635    ProtectMemory(new_pure_area->low,
3636                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
3637                                      log2_page_size));
3638    lisp_global(IN_GC) = 0;
3639    just_purified_p = true;
3640    return 0;
3641  }
3642#endif
3643  return -1;
3644}
3645
3646
3647 
3648Boolean
3649impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
3650{
3651  LispObj q = *p;
3652 
3653  if (is_node_fulltag(fulltag_of(q)) &&
3654      (q >= low) && 
3655      (q < high)) {
3656    *p = (q+delta);
3657    return true;
3658  }
3659  return false;
3660}
3661 
3662
3663
3664void
3665impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
3666{
3667  natural *regs = (natural *) xpGPRvector(xp);
3668
3669
3670#ifdef X8664
3671  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
3672  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
3673  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
3674  impurify_noderef(&(regs[Isave3]), low, high, delta);
3675  impurify_noderef(&(regs[Isave2]), low, high, delta);
3676  impurify_noderef(&(regs[Isave1]), low, high, delta);
3677  impurify_noderef(&(regs[Isave0]), low, high, delta);
3678  impurify_noderef(&(regs[Ifn]), low, high, delta);
3679  impurify_noderef(&(regs[Itemp0]), low, high, delta);
3680  impurify_noderef(&(regs[Itemp1]), low, high, delta);
3681#if 0
3682  impurify_locref(&(regs[Iip]), low, high, delta);
3683#endif
3684#else
3685#endif
3686
3687}
3688
3689void
3690impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3691{
3692  while (start < end) {
3693    impurify_noderef(start, low, high, delta);
3694    start++;
3695  }
3696}
3697
3698
3699void
3700impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3701{
3702#ifdef X8664
3703
3704  LispObj header;
3705  unsigned tag;
3706  natural nwords;
3707  hash_table_vector_header *hashp;
3708
3709  while (start < end) {
3710    header = *start;
3711    if (header == forward_marker) {
3712      start += 2;
3713    } else {
3714      tag = fulltag_of(header);
3715      if (immheader_tag_p(tag)) {
3716        start = (LispObj *)skip_over_ivector((natural)start, header);
3717      } else if (nodeheader_tag_p(tag)) {
3718        nwords = header_element_count(header);
3719        nwords += (1 - (nwords&1));
3720        if ((header_subtag(header) == subtag_hash_vector) &&
3721          ((((hash_table_vector_header *)start)->flags) & 
3722           nhash_track_keys_mask)) {
3723          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
3724
3725          hashp = (hash_table_vector_header *) start;
3726          start++;
3727          nwords -= skip;
3728          while(skip--) {
3729            impurify_noderef(start, low, high, delta);
3730            start++;
3731          }
3732          /* "nwords" is odd at this point: there are (floor nwords 2)
3733             key/value pairs to look at, and then an extra word for
3734             alignment.  Process them two at a time, then bump "start"
3735             past the alignment word. */
3736          nwords >>= 1;
3737          while(nwords--) {
3738            if (impurify_noderef(start, low, high, delta) && hashp) {
3739              hashp->flags |= nhash_key_moved_mask;
3740              hashp = NULL;
3741            }
3742            start++;
3743            impurify_noderef(start, low, high, delta);
3744            start++;
3745          }
3746          *start++ = 0;
3747        } else {
3748          if (header_subtag(header) == subtag_function) {
3749            int skip = (int)(start[1]);
3750            start += skip;
3751            nwords -= skip;
3752          }
3753          start++;
3754          while(nwords--) {
3755            impurify_noderef(start, low, high, delta);
3756            start++;
3757          }
3758        }
3759      } else {
3760        /* Not a header, just a cons cell */
3761        impurify_noderef(start, low, high, delta);
3762        start++;
3763        impurify_noderef(start, low, high, delta);
3764        start++;
3765      }
3766    }
3767  }
3768#endif
3769}
3770
3771
3772
3773
3774void
3775impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
3776{
3777  unsigned n = tcr->tlb_limit;
3778  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3779 
3780  impurify_range(start, end, low, high, delta);
3781}
3782
3783void
3784impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
3785{
3786  xframe_list *xframes;
3787  ExceptionInformation *xp;
3788 
3789  xp = tcr->gc_context;
3790  if (xp) {
3791    impurify_xp(xp, low, high, delta);
3792  }
3793
3794  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3795    impurify_xp(xframes->curr, low, high, delta);
3796  }
3797}
3798
3799void
3800impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
3801{
3802  LispObj
3803    *current,
3804    *next,
3805    *start = (LispObj *) (a->active),
3806    *end = start,
3807    *limit = (LispObj *) (a->high);
3808
3809  for (current = start;
3810       end != limit;
3811       current = next) {
3812    next = (LispObj *) ptr_from_lispobj(*current);
3813    end = ((next >= start) && (next < limit)) ? next : limit;
3814    if (current[1] == 0) {
3815      impurify_range(current+2, end, low, high, delta);
3816    }
3817  }
3818}
3819void
3820impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
3821{
3822  LispObj
3823    *p = (LispObj *) a->active,
3824    *q = (LispObj *) a->high;
3825
3826  impurify_headerless_range(p, q, low, high, delta);
3827}
3828
3829
3830void
3831impurify_areas(LispObj low, LispObj high, int delta)
3832{
3833  area *next_area;
3834  area_code code;
3835     
3836  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3837    switch (code) {
3838    case AREA_TSTACK:
3839      impurify_tstack_area(next_area, low, high, delta);
3840      break;
3841     
3842    case AREA_VSTACK:
3843      impurify_vstack_area(next_area, low, high, delta);
3844      break;
3845     
3846    case AREA_CSTACK:
3847#ifdef PPC
3848      impurify_cstack_area(next_area, low, high, delta);
3849#endif
3850      break;
3851     
3852    case AREA_STATIC:
3853    case AREA_DYNAMIC:
3854      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
3855      break;
3856     
3857    default:
3858      break;
3859    }
3860  }
3861}
3862
3863int
3864impurify(TCR *tcr, signed_natural param)
3865{
3866  area *r = find_readonly_area();
3867
3868  if (r) {
3869    area *a = active_dynamic_area;
3870    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
3871      oldhigh = a->high, newhigh; 
3872    unsigned n = ro_limit - ro_base;
3873    int delta = oldfree-ro_base;
3874    TCR *other_tcr;
3875
3876    if (n) {
3877      lisp_global(IN_GC) = 1;
3878      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
3879                                               log2_heap_segment_size));
3880      if (newhigh > oldhigh) {
3881        grow_dynamic_area(newhigh-oldhigh);
3882      }
3883      a->active += n;
3884      bcopy(ro_base, oldfree, n);
3885      munmap((void *)ro_base, n);
3886      a->ndnodes = area_dnode(a, a->active);
3887      pure_space_active = r->active = r->low;
3888      r->ndnodes = 0;
3889
3890      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3891
3892      other_tcr = tcr;
3893      do {
3894        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3895        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3896        other_tcr = other_tcr->next;
3897      } while (other_tcr != tcr);
3898      lisp_global(IN_GC) = 0;
3899    }
3900    return 0;
3901  }
3902  return -1;
3903}
3904
3905
3906void
3907adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
3908{
3909  LispObj p = *loc;
3910 
3911  if (area_dnode(p, base) < limit) {
3912    *loc = p+delta;
3913  }
3914}
3915
3916/* like adjust_locref() above, but only changes the contents of LOC if it's
3917   a tagged lisp pointer */
3918void
3919adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
3920{
3921  LispObj p = *loc;
3922  int tag_n = fulltag_of(p);
3923
3924  if (is_node_fulltag(tag_n)) {
3925    if (area_dnode(p, base) < limit) {
3926      *loc = p+delta;
3927    }
3928  }
3929}
3930
3931/*
3932   If *loc is a tagged pointer into the address range denoted by BASE and LIMIT,
3933   nuke it (set it to NIL.)
3934*/
3935void
3936nuke_noderef(LispObj *loc, LispObj base, LispObj limit)
3937{
3938  LispObj p = *loc;
3939  int tag_n = fulltag_of(p);
3940
3941  if (is_node_fulltag(tag_n)) {
3942    if (area_dnode(p, base) < limit) {
3943      *loc = lisp_nil;
3944    }
3945  }
3946}
3947
3948
3949void
3950adjust_pointers_in_xp(ExceptionInformation *xp, 
3951                      LispObj base, 
3952                      LispObj limit, 
3953                      signed_natural delta) 
3954{
3955  natural *regs = (natural *) xpGPRvector(xp);
3956
3957#ifdef X8664
3958  adjust_noderef((LispObj *) (&(regs[Iarg_z])),base,limit,delta);
3959  adjust_noderef((LispObj *) (&(regs[Iarg_y])),base,limit,delta);
3960  adjust_noderef((LispObj *) (&(regs[Iarg_x])),base,limit,delta);
3961  adjust_noderef((LispObj *) (&(regs[Isave3])),base,limit,delta);
3962  adjust_noderef((LispObj *) (&(regs[Isave2])),base,limit,delta);
3963  adjust_noderef((LispObj *) (&(regs[Isave1])),base,limit,delta);
3964  adjust_noderef((LispObj *) (&(regs[Isave0])),base,limit,delta);
3965  adjust_noderef((LispObj *) (&(regs[Ifn])),base,limit,delta);
3966  adjust_noderef((LispObj *) (&(regs[Itemp0])),base,limit,delta);
3967  adjust_noderef((LispObj *) (&(regs[Itemp1])),base,limit,delta);
3968  adjust_noderef((LispObj *) (&(regs[Itemp2])),base,limit,delta);
3969  adjust_locref((LispObj *) (&(xpPC(xp))),base,limit,delta);
3970#endif
3971}
3972
3973void
3974nuke_pointers_in_xp(ExceptionInformation *xp, 
3975                      LispObj base, 
3976                      LispObj limit) 
3977{
3978  natural *regs = (natural *) xpGPRvector(xp);
3979
3980#ifdef X8664
3981  nuke_noderef((LispObj *) (&(regs[Iarg_z])),base,limit);
3982  nuke_noderef((LispObj *) (&(regs[Iarg_y])),base,limit);
3983  nuke_noderef((LispObj *) (&(regs[Iarg_x])),base,limit);
3984  nuke_noderef((LispObj *) (&(regs[Isave3])),base,limit);
3985  nuke_noderef((LispObj *) (&(regs[Isave2])),base,limit);
3986  nuke_noderef((LispObj *) (&(regs[Isave1])),base,limit);
3987  nuke_noderef((LispObj *) (&(regs[Isave0])),base,limit);
3988  nuke_noderef((LispObj *) (&(regs[Ifn])),base,limit);
3989  nuke_noderef((LispObj *) (&(regs[Itemp0])),base,limit);
3990  nuke_noderef((LispObj *) (&(regs[Itemp1])),base,limit);
3991  nuke_noderef((LispObj *) (&(regs[Itemp2])),base,limit);
3992#endif
3993}
3994
3995void
3996adjust_pointers_in_headerless_range(LispObj *range_start,
3997                                    LispObj *range_end,
3998                                    LispObj base,
3999                                    LispObj limit,
4000                                    signed_natural delta)
4001{
4002  LispObj *p = range_start;
4003
4004  while (p < range_end) {
4005    adjust_noderef(p, base, limit, delta);
4006    p++;
4007  }
4008}
4009
4010
4011void
4012adjust_pointers_in_range(LispObj *range_start,
4013                         LispObj *range_end,
4014                         LispObj base,
4015                         LispObj limit,
4016                         signed_natural delta)
4017{
4018  LispObj *p = range_start, node, new;
4019  int tag_n;
4020  natural nwords;
4021  hash_table_vector_header *hashp;
4022
4023  while (p < range_end) {
4024    node = *p;
4025    tag_n = fulltag_of(node);
4026    if (immheader_tag_p(tag_n)) {
4027      p = (LispObj *) skip_over_ivector((natural) p, node);
4028    } else if (nodeheader_tag_p(tag_n)) {
4029      nwords = header_element_count(node);
4030      nwords += (1 - (nwords&1));
4031      if ((header_subtag(node) == subtag_hash_vector) &&
4032          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
4033        hashp = (hash_table_vector_header *) p;
4034        hashp->flags |= nhash_key_moved_mask;
4035      } else if (header_subtag(node) == subtag_function) {
4036        int skip = (int)(p[1]);
4037        p += skip;
4038        nwords -= skip;
4039      }
4040      p++;
4041      while (nwords--) {
4042        adjust_noderef(p, base, limit, delta);
4043        p++;
4044      }
4045    } else {
4046      /* just a cons */
4047      adjust_noderef(p, base, limit, delta);
4048      p++;
4049      adjust_noderef(p, base, limit, delta);
4050      p++;
4051    }
4052  }
4053}
4054
4055void
4056nuke_pointers_in_headerless_range(LispObj *range_start,
4057                                  LispObj *range_end,
4058                                  LispObj base,
4059                                  LispObj limit)
4060{
4061  LispObj *p = range_start;
4062
4063  while (p < range_end) {
4064    nuke_noderef(p, base, limit);
4065    p++;
4066  }
4067}
4068
4069
4070void
4071nuke_pointers_in_range(LispObj *range_start,
4072                         LispObj *range_end,
4073                         LispObj base,
4074                         LispObj limit)
4075{
4076  LispObj *p = range_start, node, new;
4077  int tag_n;
4078  natural nwords;
4079
4080  while (p < range_end) {
4081    node = *p;
4082    tag_n = fulltag_of(node);
4083    if (immheader_tag_p(tag_n)) {
4084      p = (LispObj *) skip_over_ivector((natural) p, node);
4085    } else if (nodeheader_tag_p(tag_n)) {
4086      nwords = header_element_count(node);
4087      nwords += (1 - (nwords&1));
4088      if (header_subtag(node) == subtag_function) {
4089        int skip = (int)(p[1]);
4090        p += skip;
4091        nwords -= skip;
4092      }
4093      p++;
4094      while (nwords--) {
4095        nuke_noderef(p, base, limit);
4096        p++;
4097      }
4098    } else {
4099      /* just a cons */
4100      nuke_noderef(p, base, limit);
4101      p++;
4102      nuke_noderef(p, base, limit);
4103      p++;
4104    }
4105  }
4106}
4107
4108void
4109adjust_pointers_in_tstack_area(area *a,
4110                               LispObj base,
4111                               LispObj limit,
4112                               LispObj delta)
4113{
4114  LispObj
4115    *current,
4116    *next,
4117    *start = (LispObj *) a->active,
4118    *end = start,
4119    *area_limit = (LispObj *) (a->high);
4120
4121  for (current = start;
4122       end != area_limit;
4123       current = next) {
4124    next = ptr_from_lispobj(*current);
4125    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
4126    adjust_pointers_in_range(current+2, end, base, limit, delta);
4127  }
4128}
4129
4130void
4131nuke_pointers_in_tstack_area(area *a,
4132                             LispObj base,
4133                             LispObj limit)
4134{
4135  LispObj
4136    *current,
4137    *next,
4138    *start = (LispObj *) a->active,
4139    *end = start,
4140    *area_limit = (LispObj *) (a->high);
4141
4142  for (current = start;
4143       end != area_limit;
4144       current = next) {
4145    next = ptr_from_lispobj(*current);
4146    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
4147    if (current[1] == 0) {
4148      nuke_pointers_in_range(current+2, end, base, limit);
4149    }
4150  }
4151}
4152
4153void
4154adjust_pointers_in_vstack_area(area *a,
4155                               LispObj base,
4156                               LispObj limit,
4157                               LispObj delta)
4158{
4159  LispObj
4160    *p = (LispObj *) a->active,
4161    *q = (LispObj *) a->high;
4162
4163  adjust_pointers_in_headerless_range(p, q, base, limit, delta);
4164}
4165
4166void
4167nuke_pointers_in_vstack_area(area *a,
4168                             LispObj base,
4169                             LispObj limit)
4170{
4171  LispObj
4172    *p = (LispObj *) a->active,
4173    *q = (LispObj *) a->high;
4174
4175  nuke_pointers_in_headerless_range(p, q, base, limit);
4176}
4177
4178#ifdef PPC
4179void
4180adjust_pointers_in_cstack_area(area *a,
4181                               LispObj base,
4182                               LispObj limit,
4183                               LispObj delta)
4184{
4185  BytePtr
4186    current,
4187    next,
4188    area_limit = a->high,
4189    low = a->low;
4190
4191  for (current = a->active; (current >= low) && (current < area_limit); current = next) {
4192    next = *((BytePtr *)current);
4193    if (next == NULL) break;
4194    if (((next - current) == sizeof(lisp_frame)) &&
4195        (((((lisp_frame *)current)->savefn) == 0) ||
4196         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
4197      adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta);
4198      adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta);
4199    }
4200  }
4201}
4202#endif
4203
4204
4205
4206void
4207adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta)
4208{
4209  TCR *tcr = current;
4210  xframe_list *xframes;
4211  LispObj *tlb_start, *tlb_end;
4212  ExceptionInformation *xp;
4213
4214  do {
4215    xp = tcr->gc_context;
4216    if (xp) {
4217      adjust_pointers_in_xp(xp, base, limit, delta);
4218    }
4219    for (xframes = (xframe_list *) tcr->xframe;
4220         xframes;
4221         xframes = xframes->prev) {
4222      adjust_pointers_in_xp(xframes->curr, base, limit, delta);
4223    }
4224    adjust_pointers_in_range(tcr->tlb_pointer,
4225                             (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
4226                             base,
4227                             limit,
4228                             delta);
4229    tcr = tcr->next;
4230  } while (tcr != current);
4231}
4232
4233void
4234nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit)
4235{
4236  TCR *tcr = current;
4237  xframe_list *xframes;
4238  LispObj *tlb_start, *tlb_end;
4239  ExceptionInformation *xp;
4240
4241  do {
4242    xp = tcr->gc_context;
4243    if (xp) {
4244      nuke_pointers_in_xp(xp, base, limit);
4245    }
4246    for (xframes = (xframe_list *) tcr->xframe;
4247         xframes;
4248         xframes = xframes->prev) {
4249      nuke_pointers_in_xp(xframes->curr, base, limit);
4250    }
4251    nuke_pointers_in_range(tcr->tlb_pointer,
4252                           (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
4253                           base,
4254                           limit);
4255    tcr = tcr->next;
4256  } while (tcr != current);
4257}
4258
4259void
4260adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta)
4261{
4262  /* These need to be special-cased, because xmacptrs are immediate
4263     objects that contain (in their "link" fields") tagged pointers
4264     to other xmacptrs */
4265  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
4266
4267  while ((next = *prev) != (LispObj)NULL) {
4268    adjust_noderef(prev, base, limit, delta);
4269    if (delta < 0) {
4270      /* Assume that we've already moved things */
4271      next = *prev;
4272    }
4273    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
4274  }
4275}
4276   
4277
4278void
4279adjust_pointers_in_dynamic_area(area *a, 
4280                                LispObj base, 
4281                                LispObj limit,
4282                                signed_natural delta)
4283{
4284  natural
4285    nstatic = static_dnodes_for_area(a),
4286    nstatic_bitmap_words = nstatic >> bitmap_shift;
4287  LispObj
4288    *low = (LispObj *) (a->low),
4289    *active = (LispObj *) (a->active),
4290    *dynamic_low = low + (2 * nstatic);
4291
4292  adjust_pointers_in_range(dynamic_low, active, base, limit, delta);
4293
4294  if (nstatic && (nstatic <= a->ndnodes)) {
4295    cons *pagelet_start = (cons *) a->low, *work;
4296    bitvector usedbits = tenured_area->static_used;
4297    natural used, i;
4298   
4299    while (nstatic_bitmap_words--) {
4300      used = *usedbits++;
4301
4302      while (used) {
4303        i = count_leading_zeros(used);
4304        used &= ~(BIT0_MASK >> i);
4305        work = pagelet_start+i;
4306        adjust_noderef(&(work->cdr), base, limit, delta);
4307        adjust_noderef(&(work->car), base, limit, delta);
4308      }
4309      pagelet_start += nbits_in_word;
4310    }
4311  }
4312}
4313
4314void
4315nuke_pointers_in_dynamic_area(area *a, 
4316                              LispObj base, 
4317                              LispObj limit)
4318{
4319  natural
4320    nstatic = static_dnodes_for_area(a),
4321    nstatic_bitmap_words = nstatic >> bitmap_shift;
4322  LispObj
4323    *low = (LispObj *) (a->low),
4324    *active = (LispObj *) (a->active),
4325    *dynamic_low = low + (2 * nstatic);
4326
4327  nuke_pointers_in_range(dynamic_low, active, base, limit);
4328
4329  if (nstatic && (nstatic <= a->ndnodes)) {
4330    cons *pagelet_start = (cons *) a->low, *work;
4331    bitvector usedbits = tenured_area->static_used;
4332    natural used, i;
4333   
4334    while (nstatic_bitmap_words--) {
4335      used = *usedbits++;
4336
4337      while (used) {
4338        i = count_leading_zeros(used);
4339        used &= ~(BIT0_MASK >> i);
4340        work = pagelet_start+i;
4341        nuke_noderef(&(work->cdr), base, limit);
4342        nuke_noderef(&(work->car), base, limit);
4343      }
4344      pagelet_start += nbits_in_word;
4345    }
4346  }
4347}
4348
4349   
4350void
4351adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta)
4352{
4353  area *next_area;
4354  area_code code;
4355
4356  for (next_area = active_dynamic_area; 
4357       (code = next_area->code) != AREA_VOID;
4358       next_area = next_area->succ) {
4359    switch (code) {
4360    case AREA_TSTACK:
4361      adjust_pointers_in_tstack_area(next_area, base, limit, delta);
4362      break;
4363     
4364    case AREA_VSTACK:
4365      adjust_pointers_in_vstack_area(next_area, base, limit, delta);
4366      break;
4367
4368    case AREA_CSTACK:
4369#ifndef X86
4370      adjust_pointers_in_cstack_area(next_area, base, limit, delta);
4371#endif
4372      break;
4373
4374    case AREA_STATIC:
4375    case AREA_MANAGED_STATIC:
4376      adjust_pointers_in_range((LispObj *) (next_area->low),
4377                               (LispObj *) (next_area->active),
4378                               base,
4379                               limit,
4380                               delta);
4381      break;
4382
4383    case AREA_DYNAMIC:
4384      adjust_pointers_in_dynamic_area(next_area, base, limit, delta);
4385      break;
4386    }
4387  }
4388  adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta);
4389  adjust_gcable_ptrs(base, limit, delta);
4390}
4391
4392void
4393nuke_all_pointers(LispObj base, LispObj limit)
4394{
4395  area *next_area;
4396  area_code code;
4397
4398  for (next_area = active_dynamic_area; 
4399       (code = next_area->code) != AREA_VOID;
4400       next_area = next_area->succ) {
4401    switch (code) {
4402    case AREA_TSTACK:
4403      nuke_pointers_in_tstack_area(next_area, base, limit);
4404      break;
4405     
4406    case AREA_VSTACK:
4407      nuke_pointers_in_vstack_area(next_area, base, limit);
4408      break;
4409
4410    case AREA_CSTACK:
4411      /* There aren't any "nukable" pointers in a cstack area */
4412      break;
4413
4414    case AREA_STATIC:
4415    case AREA_MANAGED_STATIC:
4416      nuke_pointers_in_range((LispObj *) (next_area->low),
4417                               (LispObj *) (next_area->active),
4418                               base,
4419                               limit);
4420      break;
4421
4422    case AREA_DYNAMIC:
4423      nuke_pointers_in_dynamic_area(next_area, base, limit);
4424      break;
4425    }
4426  }
4427  nuke_pointers_in_tcrs(get_tcr(false), base, limit);
4428}
4429
4430#ifndef MREMAP_MAYMOVE
4431#define MREMAP_MAYMOVE 1
4432#endif
4433
4434#if defined(FREEBSD) || defined(SOLARIS)
4435void *
4436freebsd_mremap(void *old_address, 
4437               size_t old_size, 
4438               size_t new_size, 
4439               unsigned long flags)
4440{
4441  return old_address;
4442}
4443#define mremap freebsd_mremap
4444
4445#endif
4446
4447#ifdef DARWIN
4448void *
4449darwin_mremap(void *old_address, 
4450              size_t old_size, 
4451              size_t new_size, 
4452              unsigned long flags)
4453{
4454  void *end = (void *) ((char *)old_address+old_size);
4455
4456  if (old_size == new_size) {
4457    return old_address;
4458  }
4459  if (new_size < old_size) {
4460    munmap(end, old_size-new_size);
4461    return old_address;
4462  }
4463  {
4464    void * new_address = mmap(NULL,
4465                              new_size,
4466                              PROT_READ|PROT_WRITE,
4467                              MAP_PRIVATE | MAP_ANON,
4468                              -1,
4469                              0);
4470    if (new_address !=  MAP_FAILED) {
4471      vm_copy(mach_task_self(),
4472              (vm_address_t)old_address,
4473              old_size,
4474              (vm_address_t)new_address);
4475      munmap(old_address, old_size);
4476    }
4477    return new_address;
4478  }
4479}
4480
4481#define mremap darwin_mremap
4482#endif
4483
4484Boolean
4485resize_used_bitvector(natural new_dnodes, bitvector *newbits)
4486{
4487  natural
4488    old_dnodes = tenured_area->static_dnodes,
4489    old_page_aligned_size =
4490    (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3),
4491                         log2_page_size)),
4492    new_page_aligned_size =
4493    (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3),
4494                         log2_page_size));
4495  bitvector old_used = tenured_area->static_used, new_used = NULL;
4496
4497  if (old_page_aligned_size == new_page_aligned_size) {
4498    *newbits = old_used;
4499    return true;
4500  }
4501
4502  if (old_used == NULL) {
4503    new_used = (bitvector)mmap(NULL,
4504                               new_page_aligned_size,
4505                               PROT_READ|PROT_WRITE,
4506                               MAP_PRIVATE | MAP_ANON,
4507                               -1,
4508                               0);
4509    if (new_used == MAP_FAILED) {
4510      *newbits = NULL;
4511      return false;
4512    } else {
4513      *newbits = new_used;
4514      return true;
4515    }
4516  }
4517  if (new_page_aligned_size == 0) {
4518    munmap((void *)old_used, old_page_aligned_size);
4519    *newbits = NULL;
4520    return true;
4521  }
4522   
4523  /* Have to try to remap the old bitmap.  That's implementation-dependent,
4524     and (naturally) Mach sucks, but no one understands how.
4525  */
4526  new_used = mremap(old_used, 
4527                    old_page_aligned_size, 
4528                    new_page_aligned_size, 
4529                    MREMAP_MAYMOVE);
4530  if (new_used == MAP_FAILED) {
4531    *newbits = NULL;
4532    return false;
4533  }
4534  *newbits = new_used;
4535  return true;
4536}
4537
4538 
4539int
4540grow_hons_area(signed_natural delta_in_bytes)
4541{
4542  bitvector new_used;
4543  area *ada = active_dynamic_area;
4544  natural
4545    delta_in_dnodes = delta_in_bytes >> dnode_shift,
4546    current_static_dnodes = tenured_area->static_dnodes,
4547    new_static_dnodes;
4548   
4549  delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word);
4550  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
4551  delta_in_bytes = delta_in_dnodes << dnode_shift;
4552  if (grow_dynamic_area((natural) delta_in_bytes)) {
4553    LispObj
4554      base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)),
4555      oldactive = (LispObj) ada->active,
4556      limit = area_dnode(oldactive, base);
4557    if (!resize_used_bitvector(new_static_dnodes, &new_used)) {
4558      shrink_dynamic_area(delta_in_bytes);
4559      return -1;
4560    }
4561    tenured_area->static_used = new_used;
4562    adjust_all_pointers(base, limit, delta_in_bytes);
4563    memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base);
4564    ada->ndnodes = area_dnode(ada->high, ada->low);
4565    ada->active += delta_in_bytes;
4566    {
4567      LispObj *p;
4568      natural i;
4569      for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0;
4570           i< delta_in_dnodes;
4571           i++ ) {
4572        *p++ = undefined;
4573        *p++ = undefined;
4574      }
4575      tenured_area->static_dnodes += delta_in_dnodes;
4576         
4577    }
4578    return 0;
4579  }
4580  return -1;
4581}
4582
4583int 
4584shrink_hons_area(signed_natural delta_in_bytes)
4585{
4586  area *ada = active_dynamic_area;
4587  signed_natural
4588    delta_in_dnodes = delta_in_bytes >> dnode_shift;
4589  natural
4590    current_static_dnodes = tenured_area->static_dnodes,
4591    new_static_dnodes;
4592  LispObj base, limit, oldactive;
4593  bitvector newbits;
4594
4595   
4596  delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word);
4597  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
4598  delta_in_bytes = delta_in_dnodes << dnode_shift;
4599  oldactive = (LispObj) (ada->active);
4600
4601  resize_used_bitvector(new_static_dnodes, &newbits);
4602  tenured_area->static_used = newbits; /* redundant */
4603
4604  memmove(ada->low+(new_static_dnodes << dnode_shift),
4605          ada->low+(current_static_dnodes << dnode_shift),
4606          oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift)));
4607  tenured_area->static_dnodes = new_static_dnodes;
4608  ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */
4609  shrink_dynamic_area(-delta_in_bytes);
4610
4611  base = (LispObj) (tenured_area->low + 
4612                    (new_static_dnodes << dnode_shift));
4613  limit = area_dnode(tenured_area->low + 
4614                     (current_static_dnodes << dnode_shift), base);
4615  nuke_all_pointers(base, limit);
4616
4617  base = (LispObj) (tenured_area->low + 
4618                    (current_static_dnodes << dnode_shift));
4619  limit = area_dnode(oldactive, base);
4620  adjust_all_pointers(base, limit, delta_in_bytes);
4621
4622  xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift),
4623                      ada->active-(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift)));
4624  return 0;
4625}
4626
4627int
4628change_hons_area_size(TCR *tcr, signed_natural delta_in_bytes)
4629{
4630  if (delta_in_bytes > 0) {
4631    return grow_hons_area(delta_in_bytes);
4632  }
4633  if (delta_in_bytes < 0) {
4634    return shrink_hons_area(delta_in_bytes);
4635  }
4636  return 0;
4637}
4638
Note: See TracBrowser for help on using the repository browser.