source: branches/1.1/ccl/lisp-kernel/x86-gc.c @ 8227

Last change on this file since 8227 was 8227, checked in by gb, 13 years ago

Report paging stats when gc verbose.

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