source: trunk/ccl/lisp-kernel/gc.c @ 54

Last change on this file since 54 was 54, checked in by gb, 16 years ago

Fix botch in mark_tcr_tlb().

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 87.3 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
18
19#ifdef LINUX
20#include <sys/time.h>
21#endif
22
23#ifdef DARWIN
24#include <sys/time.h>
25#endif
26
27
28#include "lisp.h"
29#include "lisp_globals.h"
30#include "bits.h"
31#include "gc.h"
32#include "area.h"
33#include <stddef.h>
34#include <stdlib.h>
35#include <string.h>
36
37
38
39/* area management */
40
41
42Boolean GCDebug = false;
43
44area *
45new_area(BytePtr lowaddr, BytePtr highaddr, area_code code)
46{
47  area *a = (area *) (zalloc(sizeof(area)));
48  if (a) {
49    unsigned ndwords = area_dword(highaddr, lowaddr);
50    a->low = lowaddr;
51    a->high = highaddr;
52    a->active = (code == AREA_DYNAMIC) ? lowaddr : highaddr;
53    a->code = code;
54    a->ndwords = ndwords;
55    /* Caller must allocate markbits when allocating heap ! */
56   
57  }
58  return a;
59}
60
61static area *
62add_area_before(area *new_area, area *before)
63{
64  area *before_before = before->pred;
65
66  new_area->pred = before_before;
67  new_area->succ = before;
68  before_before->succ = new_area;
69  before->pred = new_area;
70  return new_area;
71}
72
73/*
74  The active dynamic area comes first.
75  Static areas follow dynamic areas.
76  Stack areas follow static areas.
77  Readonly areas come last.
78*/
79
80void
81add_area(area *new_area)
82{
83  area *that = all_areas;
84  int
85    thiscode = (int)(new_area->code),
86    thatcode;
87
88  /* Cdr down the linked list */
89  do {
90    that = that->succ;
91    thatcode = (int)(that->code);
92  } while (thiscode < thatcode);
93  add_area_before(new_area, that);
94}
95
96/*
97  Search areas "forward" from the header's successor, until
98  an area containing ADDR is found or an area with code < MINCODE
99  is encountered.
100  This walks the area list visiting heaps (dynamic, then static)
101  first, then stacks.
102
103*/
104static area *
105find_area_forward(BytePtr addr, area_code mincode)
106{
107  area *p, *header = all_areas;
108
109  for (p = header->succ; p != header; p = p->succ) {
110    area_code pcode = p->code;
111    if (pcode < mincode) {
112      return NULL;
113    }
114    if (pcode >= AREA_READONLY) {
115      if ((addr >= p->low) &&
116          (addr < p->active)) {
117        return p;
118      }
119    } else {
120      if ((addr >= p->active) &&
121          (addr < p->high)) {
122        return p;
123      }
124    }
125  }
126  return NULL;
127}
128
129static area *
130find_area_backward(BytePtr addr, area_code maxcode)
131{
132  area *p, *header = all_areas;
133
134  for (p = header->pred; p != header; p = p->pred) {
135    area_code pcode = p->code;
136
137    if (pcode > maxcode) {
138      return NULL;
139    }
140    if (pcode >= AREA_READONLY) {
141      if ((addr >= p->low) &&
142          (addr < p->active)) {
143        return p;
144      }
145    } else {
146      if ((addr >= p->active) &&
147          (addr < p->high)) {
148        return p;
149      }
150    }
151  }
152  return NULL;
153}
154
155area *
156area_containing(BytePtr addr)
157{
158  return find_area_forward(addr, AREA_VOID);
159}
160
161area *
162heap_area_containing(BytePtr addr)
163{
164  return find_area_forward(addr, AREA_READONLY);
165}
166
167area *
168stack_area_containing(BytePtr addr)
169{
170  return find_area_backward(addr, AREA_TSTACK);
171}
172
173/* Heap sanity checking. */
174
175void
176check_node(LispObj n)
177{
178  int tag = fulltag_of(n), header_tag;
179  area *a;
180  LispObj header;
181
182  switch (tag) {
183  case fulltag_even_fixnum:
184  case fulltag_odd_fixnum:
185  case fulltag_imm:
186    return;
187
188  case fulltag_nil:
189    if (n != lisp_nil) {
190      Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n);
191    }
192    return;
193
194  case fulltag_nodeheader:
195  case fulltag_immheader:
196    Bug(NULL, "Header not expected : 0x%08x", n);
197    return;
198
199  case fulltag_misc:
200  case fulltag_cons:
201    a = heap_area_containing((BytePtr)n);
202   
203    if (a == NULL) {
204      /* Can't do as much sanity checking as we'd like to
205         if object is a defunct stack-consed object.
206         If a dangling reference to the heap, that's
207         bad .. */
208      a = active_dynamic_area;
209      if ((n > ((LispObj)a->active)) &&
210          (n < ((LispObj)a->high))) {
211        Bug(NULL, "Node points to heap free space: 0x%08x", n);
212      }
213      return;
214    }
215    break;
216  }
217  /* Node points to heap area, so check header/lack thereof. */
218  header = header_of(n);
219  header_tag = fulltag_of(header);
220  if (tag == fulltag_cons) {
221    if ((header_tag == fulltag_nodeheader) ||
222        (header_tag == fulltag_immheader)) {
223      Bug(NULL, "Cons cell at 0x%08x has bogus header : 0x%08x", n, header);
224    }
225    return;
226  }
227
228  if ((header_tag != fulltag_nodeheader) &&
229      (header_tag != fulltag_immheader)) {
230    Bug(NULL,"Vector at 0x%08x has bogus header : 0x%08x", n, header);
231  }
232  return;
233}
234
235void
236check_range(LispObj *start, LispObj *end)
237{
238  LispObj node, *current = start, *prev;
239  int tag;
240  unsigned elements;
241
242  while (current < end) {
243    prev = current;
244    node = *current++;
245    tag = fulltag_of(node);
246    if (tag == fulltag_immheader) {
247      current = (LispObj *)skip_over_ivector((unsigned)prev, node);
248    } else if (tag == fulltag_nodeheader) {
249      elements = header_element_count(node) | 1;
250      while (elements--) {
251        check_node(*current++);
252      }
253    } else {
254      check_node(node);
255      check_node(*current++);
256    }
257  }
258
259  if (current != end) {
260    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
261        start, end, prev, current);
262  }
263}
264
265void
266check_all_areas()
267{
268  area *a = active_dynamic_area;
269  area_code code = a->code;
270
271  while (code != AREA_VOID) {
272    switch (code) {
273    case AREA_DYNAMIC:
274    case AREA_STATIC:
275    case AREA_STATICLIB:
276      check_range((LispObj *)a->low, (LispObj *)a->active);
277      break;
278
279    case AREA_VSTACK:
280      {
281        LispObj* low = (LispObj *)a->active;
282        LispObj* high = (LispObj *)a->high;
283       
284        if (((int)low) & 4) {
285          check_node(*low++);
286        }
287        check_range(low, high);
288      }
289      break;
290
291    case AREA_TSTACK:
292      {
293        LispObj *current, *next,
294                *start = (LispObj *) a->active,
295                *end = start,
296                *limit = (LispObj *) a->high;
297                 
298        for (current = start;
299             end != limit;
300             current = next) {
301          next = (LispObj *) *current;
302          end = ((next >= start) && (next < limit)) ? next : limit;
303          if (current[1] == 0) {
304            check_range(current+2, end);
305          }
306        }
307      }
308      break;
309    }
310    a = a->succ;
311    code = (a->code);
312  }
313}
314
315/*
316  Scan forward from the object boundary P until a node address >= to
317   PAGE is found.
318*/
319LispObj *
320first_node_on_page(LispObj *p, LispObj *page, pageentry *bucket, LispObj *limit)
321{
322  LispObj *q, *nextpage = (LispObj *) ((BytePtr)page + 4096), header;
323  int tag;
324
325  while (p < limit) {
326    header = *p;
327    tag = fulltag_of(header);
328
329    if (p >= nextpage) {
330      bucket->halfword = 0;
331      return p;
332    }
333   
334    if (tag == fulltag_immheader) {
335      q = (LispObj *)skip_over_ivector((LispObj)p, header);
336      if (q >= nextpage) {
337        bucket->halfword = 0;
338        return q;
339      }
340    } else if (tag == fulltag_nodeheader) {
341      q = p + ((2 + header_element_count(header)) & ~1);
342      if (p >= page) {
343        bucket->bits.hasnode = 1;
344        bucket->bits.offset = (p-page);
345        if (q > nextpage) {
346          return p;
347        }
348        return q;
349      }
350      if (q >= page) {
351        bucket->bits.hasnode = 1;
352        bucket->bits.offset = 0;
353        if (q > nextpage) {
354          return p;
355        }
356        return q;
357      }
358    } else {
359      q = p + 2;
360      if (p >= page) {
361        bucket->bits.hasnode = 1;
362        bucket->bits.offset = (p-page);
363        return q;
364      }
365    }
366    p = q;
367  }
368  bucket->halfword = 0;
369  return p;
370}
371
372
373void
374make_page_node_map(LispObj *start, LispObj *end)
375{
376  LispObj *p, *page = (LispObj *)truncate_to_power_of_2(start,12);
377  pageentry
378    *buckets = pagemap + (((LispObj)page - lisp_global(HEAP_START)) >> 12);
379
380  if (start != page) {
381    if (buckets->bits.hasnode) {
382      /* We already know (from having built older generation's page_node_map)
383         where the first node on this page is.  We're more interested in
384         the next page(s) */
385      buckets++;
386      page += (4096/sizeof(LispObj *));
387    }
388  }
389  for (p = start;
390       p < end;
391       page += (4096/sizeof(LispObj *)), buckets++) {
392    p = first_node_on_page(p, page, buckets, end);
393  }
394}
395
396void
397update_refmap_for_range(LispObj *start, 
398                        LispObj *end,
399                        LispObj ephemeral_start,
400                        unsigned long ephemeral_dwords)
401{
402  LispObj node, oldspacestart = lisp_global(HEAP_START);
403  int tag;
404  bitvector refbits = tenured_area->refbits;
405
406  while (start < end) {
407    node = *start;
408    tag = fulltag_of(node);
409    if (tag == fulltag_immheader) {     /* An ivector */
410      start = (LispObj *)skip_over_ivector((LispObj)start, node);
411    } else {
412      if ((header_subtag(node) == subtag_hash_vector) ||
413          /* Need to memoize location of hash vector headers, at
414             least if we have to track key movement */
415          (((tag == fulltag_cons) || (tag == fulltag_misc)) &&
416           (area_dword(node, ephemeral_start) < ephemeral_dwords))) {
417        /* Tagged pointer to (some) younger generation; update refmap */
418        set_bit(refbits,area_dword(start, oldspacestart));
419      } else {
420        node = start[1];
421        tag = fulltag_of(node);
422        if (((tag == fulltag_cons) || (tag == fulltag_misc)) &&
423            (area_dword(node, ephemeral_start) < ephemeral_dwords)) {
424          set_bit(refbits,area_dword(start, oldspacestart));
425        }
426      }
427      start += 2;
428    }
429  }
430}
431                       
432void
433update_refmap_for_page(pageentry *bucket,
434                       LispObj *page,
435                       LispObj ephemeral_start,
436                       unsigned ephemeral_dwords)
437{
438  LispObj *start;
439  if (bucket->bits.modified) {          /* Page was written to since last GC */
440    if (bucket->bits.hasnode) {         /* Some nodes on this page */
441      start = page + bucket->bits.offset;
442      update_refmap_for_range(start,
443                              (LispObj *) align_to_power_of_2((LispObj)start+1,12),
444                              ephemeral_start,
445                              ephemeral_dwords);
446    }
447  }
448}
449
450
451void
452update_refmap_for_area(area *a, BytePtr curfree)
453{
454  if (a->ndwords) {
455    LispObj
456      *start = (LispObj *) a->low,
457      *limit = (LispObj *) a->active,
458      *last_whole_page_end = (LispObj *) truncate_to_power_of_2(limit,12),
459      *first_partial_page_start = (LispObj *) truncate_to_power_of_2(start,12);
460    pageentry *p = pagemap + ((LispObj)start - lisp_global(HEAP_START) >> 12);
461    unsigned younger_dwords = area_dword((LispObj)curfree,(LispObj)limit);
462   
463    if (last_whole_page_end == first_partial_page_start) {
464      if (p->bits.modified && p->bits.hasnode) {
465        update_refmap_for_range(start,limit,(LispObj)limit,younger_dwords);
466      }
467    } else {
468      if (start != first_partial_page_start) {
469        LispObj
470          *page_end = first_partial_page_start + (4096 / sizeof(LispObj *));
471        if (p->bits.modified && p->bits.hasnode) {
472          update_refmap_for_range(start,page_end,(LispObj)limit,younger_dwords);
473        }
474        start = page_end;
475        p++;
476      }
477      for (; 
478           start < last_whole_page_end;
479           start += (4096 / sizeof(LispObj *)), p++) {
480        update_refmap_for_page(p,start,(LispObj)limit,younger_dwords);
481      }
482      if (start < limit) {
483        if (p->bits.modified && p->bits.hasnode) {
484          update_refmap_for_range(start+p->bits.offset,limit,(LispObj)limit,younger_dwords);
485        }
486      }
487    }
488  }
489}
490
491void
492update_area_refmaps(BytePtr curfree)
493{
494  unprotect_area(oldspace_protected_area);
495  update_refmap_for_area(tenured_area,curfree);
496  update_refmap_for_area(g2_area,curfree);
497  update_refmap_for_area(g1_area,curfree);
498}
499     
500
501
502/*
503  Make everything "younger" than the start of the target area
504  belong to that area; all younger areas will become empty, and
505  the dynamic area will have to lose some of its markbits (they
506  get zeroed and become part of the tenured area's refbits.)
507
508  The active dynamic area must have been "normalized" (e.g., its
509  active pointer must match the free pointer) before this is called.
510
511  If the target area is 'tenured_area' (the oldest ephemeral generation),
512  zero its refbits and update YOUNGEST_EPHEMERAL.
513
514*/
515
516void
517tenure_to_area(area *target)
518{
519  area *a = active_dynamic_area, *child;
520  BytePtr
521    curfree = a->active,
522    target_low = target->low,
523    tenured_low = tenured_area->low;
524  unsigned 
525    dynamic_dwords = area_dword(curfree, a->low),
526    new_tenured_dwords = area_dword(curfree, tenured_area->low);
527  bitvector
528    refbits = tenured_area->refbits,
529    markbits = a->markbits,
530    new_markbits;
531
532  target->high = target->active = curfree;
533  target->ndwords = area_dword(curfree, target_low);
534
535  for (child = target->younger; child != a; child = child->younger) {
536    child->high = child->low = child->active = curfree;
537    child->ndwords = 0;
538  }
539
540  a->low = curfree;
541  a->ndwords = area_dword(a->high, curfree);
542
543  new_markbits = refbits + ((new_tenured_dwords + 31) >> 5);
544 
545  if (target == tenured_area) {
546    zero_bits(refbits, new_tenured_dwords);
547    lisp_global(OLDEST_EPHEMERAL) = (LispObj) curfree;
548  } else {
549    /* Need more (zeroed) refbits & fewer markbits */
550    zero_bits(markbits, ((new_markbits-markbits)<<5));
551  }
552   
553  a->markbits = new_markbits;
554  make_page_node_map((LispObj *)target_low, (LispObj *)curfree);
555  protect_oldspace(curfree);
556}
557
558/*
559  Make everything younger than the oldest byte in 'from' belong to
560  the youngest generation.  If 'from' is 'tenured_area', this means
561  that nothing's ephemeral any more (and OLDEST_EPHEMERAL can be set
562  to 0 to indicate this.)
563 
564  Some tenured_area refbits become dynamic area markbits in the process;
565  it's not necessary to zero them, since the GC will do that.
566*/
567
568void
569untenure_from_area(area *from)
570{
571  if (lisp_global(OLDEST_EPHEMERAL) != 0) {
572    area *a = active_dynamic_area, *child;
573    BytePtr curlow = from->low;
574    unsigned new_tenured_dwords = area_dword(curlow, tenured_area->low);
575   
576    for (child = from; child != a; child = child->younger) {
577      child->low = child->active = child->high = curlow;
578      child->ndwords = 0;
579    }
580   
581    a->low = curlow;
582    a->ndwords = area_dword(a->high, curlow);
583   
584    a->markbits = (tenured_area->refbits) + ((new_tenured_dwords+31)>>5);
585    if (from == tenured_area) {
586      /* Everything's in the dynamic area */
587      lisp_global(OLDEST_EPHEMERAL) = 0;
588    }
589  }
590}
591
592
593Boolean
594egc_control(Boolean activate, BytePtr curfree)
595{
596  area *a = active_dynamic_area;
597  Boolean egc_is_active = (a->older != NULL);
598
599  if (activate != egc_is_active) {
600    if (curfree != NULL) {
601      a->active = curfree;
602    }
603    if (activate) {
604      LispObj *heap_start = (LispObj *)lisp_global(HEAP_START);
605
606      a->older = g1_area;
607      tenure_to_area(tenured_area);
608      egc_is_active = true;
609    } else {
610      untenure_from_area(tenured_area);
611      a->older = NULL;
612      unprotect_area(oldspace_protected_area);
613      egc_is_active = false;
614    }
615  }
616  return egc_is_active;
617}
618
619/*
620  Lisp ff-calls this; it needs to set the active area's active pointer
621  correctly.
622*/
623
624Boolean
625lisp_egc_control(Boolean activate)
626{
627  area *a = active_dynamic_area;
628  return egc_control(activate, (BytePtr) a->active);
629}
630
631
632 
633/* Splice the protected_area_ptr out of the list and dispose of it. */
634void
635delete_protected_area(protected_area_ptr p)
636{
637  BytePtr start = p->start;
638  int nbytes = p->nprot;
639  protected_area_ptr *prev = &AllProtectedAreas, q;
640
641  if (nbytes) {
642    UnProtectMemory((LogicalAddress)start, nbytes);
643  }
644 
645  while ((q = *prev) != NULL) {
646    if (p == q) {
647      *prev = p->next;
648      break;
649    } else {
650      prev = &(q->next);
651    }
652  }
653
654  deallocate((Ptr)p);
655}
656
657
658/*
659  Unlink the area from all_areas.
660  Unprotect and dispose of any hard/soft protected_areas.
661  If the area has a handle, dispose of that as well.
662  */
663
664void
665condemn_area(area *a)
666{
667  void free_stack(void *);
668  area *prev = a->pred, *next = a->succ;
669  Ptr h = a->h;
670  protected_area_ptr p;
671
672  prev->succ = next;
673  next->pred = prev;
674
675  p = a->softprot;
676  if (p) delete_protected_area(p);
677
678  p = a->hardprot;
679
680  if (p) delete_protected_area(p);
681
682  if (h) free_stack(h);
683  deallocate((Ptr)a);
684}
685
686
687/*
688  condemn an area and all the other areas that can be reached
689  via the area.older & area.younger links.
690  This is the function in the ppc::kernel-import-condemn-area slot,
691  called by free-stack-area
692  */
693void
694condemn_area_chain(area *a)
695{
696  area *older;
697  for (; a->younger; a = a->younger) ;
698  for (;a;) {
699    older = a->older;
700    condemn_area(a);
701    a = older;
702  }
703}
704
705
706
707bitvector GCmarkbits = NULL;
708LispObj GCarealow;
709unsigned GCndwords_in_area;
710LispObj GCweakvll = (LispObj)NULL;
711LispObj GCephemeral_low;
712unsigned GCn_ephemeral_dwords;
713
714
715/* Sooner or later, this probably wants to be in assembler */
716/* Return false if n is definitely not an ephemeral node, true if
717   it might be */
718void
719mark_root(LispObj n)
720{
721  int tag_n = fulltag_of(n);
722  unsigned dword, bits, *bitsp, mask;
723
724  if (!is_node_fulltag(tag_n)) {
725    return;
726  }
727
728  dword = gc_area_dword(n);
729  if (dword >= GCndwords_in_area) {
730    return;
731  }
732  set_bits_vars(GCmarkbits,dword,bitsp,bits,mask);
733  if (bits & mask) {
734    return;
735  }
736  *bitsp = (bits | mask);
737
738  if (tag_n == fulltag_cons) {
739    cons *c = (cons *) untag(n);
740    rmark(c->car);
741    rmark(c->cdr);
742    return;
743  }
744  {
745    LispObj *base = (LispObj *) untag(n);
746    unsigned
747      header = *((unsigned *) base),
748      subtag = header_subtag(header),
749      element_count = header_element_count(header),
750      total_size_in_bytes,      /* including 4-byte header */
751      suffix_dwords;
752
753    tag_n = fulltag_of(header);
754
755    if ((tag_n == fulltag_nodeheader) ||
756        (subtag <= max_32_bit_ivector_subtag)) {
757      total_size_in_bytes = 4 + (element_count<<2);
758    } else if (subtag <= max_8_bit_ivector_subtag) {
759      total_size_in_bytes = 4 + element_count;
760    } else if (subtag <= max_16_bit_ivector_subtag) {
761      total_size_in_bytes = 4 + (element_count<<1);
762    } else if (subtag == subtag_double_float_vector) {
763      total_size_in_bytes = 8 + (element_count<<3);
764    } else {
765      total_size_in_bytes = 4 + ((element_count+7)>>3);
766    }
767    suffix_dwords = ((total_size_in_bytes+7)>>3) -1;
768
769    if (suffix_dwords) {
770      set_n_bits(GCmarkbits, dword+1, suffix_dwords);
771    }
772
773    if (tag_n == fulltag_nodeheader) {
774      if (subtag == subtag_hash_vector) {
775        ((hash_table_vector_header *) base)->cache_key = undefined;
776        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
777        deref(base,1) = GCweakvll;
778        GCweakvll = n;
779        return;
780      }
781
782      if (subtag == subtag_pool) {
783        deref(base, 1) = lisp_nil;
784      }
785     
786      if (subtag == subtag_weak) {
787        int weak_type = (unsigned) base[2];
788        if (weak_type >> population_termination_bit) {
789          element_count -= 2;
790        } else {
791          element_count -= 1;
792        }
793      }
794
795      base += (1+element_count);
796      while(element_count--) {
797        rmark(*--base);
798      }
799      if (subtag == subtag_weak) {
800        deref(base,1) = GCweakvll;
801        GCweakvll = n;
802      }
803    }
804  }
805}
806
807
808/*
809  This marks the node if it needs to; it returns true if the node
810  is either a hash table vector header or a cons/misc-tagged pointer
811  to ephemeral space.
812  Note that it  might be a pointer to ephemeral space even if it's
813  not pointing to the current generation.
814*/
815
816Boolean
817mark_ephemeral_root(LispObj n)
818{
819  int tag_n = fulltag_of(n);
820  unsigned eph_dword;
821
822  if (tag_n == fulltag_nodeheader) {
823    return (header_subtag(n) == subtag_hash_vector);
824  }
825 
826  if ((tag_n == fulltag_cons) ||
827      (tag_n == fulltag_misc)) {
828    eph_dword = area_dword(n, GCephemeral_low);
829    if (eph_dword < GCn_ephemeral_dwords) {
830      mark_root(n);             /* May or may not mark it */
831      return true;              /* but return true 'cause it's an ephemeral node */
832    }
833  }
834  return false;                 /* Not a heap pointer or not ephemeral */
835}
836 
837
838/*
839  Some objects (saved LRs on the control stack, the LR, PC, and CTR
840  in exception frames) may be tagged as fixnums but are really
841  locatives into code_vectors.
842
843  If "pc" is not tagged as a fixnum, mark it as a "normal" root.
844  If "pc" doesn't point at an unmarked doubleword in the area
845  being GCed, return.
846  Else back up until the code_vector's header is found and mark
847  all doublewords in the code_vector.
848*/
849void
850mark_pc_root(LispObj pc)
851{
852  if (tag_of(pc) != tag_fixnum) {
853    mark_root(pc);
854  } else {
855    unsigned dword = gc_area_dword(pc);
856    if ((dword < GCndwords_in_area) &&
857        !ref_bit(GCmarkbits,dword)) {
858      LispObj
859        *headerP,
860        header;
861
862      for(headerP = (LispObj*)(untag(pc));
863          dword < GCndwords_in_area;
864          headerP-=2, --dword) {
865        header = *headerP;
866
867        if ((header & code_header_mask) == subtag_code_vector) {
868          set_n_bits(GCmarkbits, dword, (2+header_element_count(header))>>1);
869          return;
870        }
871      }
872      /*
873        Expected to have found a header by now, but didn't.
874        That's a bug.
875        */
876      Bug(NULL, "code_vector header not found!");
877    }
878  }
879}
880
881
882/*
883  This wants to be in assembler even more than "mark_root" does.
884  For now, it does link-inversion: hard as that is to express in C,
885  reliable stack-overflow detection may be even harder ...
886*/
887void
888rmark(LispObj n)
889{
890  int tag_n = fulltag_of(n);
891  bitvector markbits = GCmarkbits;
892  unsigned dword, bits, *bitsp, mask;
893
894  if (!is_node_fulltag(tag_n)) {
895    return;
896  }
897
898  dword = gc_area_dword(n);
899  if (dword >= GCndwords_in_area) {
900    return;
901  }
902  set_bits_vars(markbits,dword,bitsp,bits,mask);
903  if (bits & mask) {
904    return;
905  }
906  *bitsp = (bits | mask);
907  {
908    LispObj prev = undefined;
909    LispObj this = n, next;
910    /*
911      This is an FSM.  The basic states are:
912      (0) Just marked the cdr of a cons; mark the car next;
913      (1) Just marked the car of a cons; back up.
914      (2) Hit a gvector header.  Back up.
915      (3) Marked a gvector element; mark the preceding one.
916      (4) Backed all the way up to the object that got us here.
917     
918      This is all encoded in the fulltag of the "prev" pointer.
919      */
920
921    if (tag_n == fulltag_cons) goto MarkCons;
922    goto MarkVector;
923
924  ClimbCdr:
925    prev = deref(this,0);
926    deref(this,0) = next;
927
928  Climb:
929    next = this;
930    this = prev;
931    tag_n = fulltag_of(prev);
932    switch(tag_n) {
933    case fulltag_odd_fixnum:
934    case fulltag_even_fixnum:
935      goto ClimbVector;
936
937    case fulltag_imm:
938      return;
939
940    case fulltag_cons:
941      goto ClimbCdr;
942
943    case fulltag_nil:
944      goto ClimbCar;
945
946      /* default: abort() */
947    }
948
949  DescendCons:
950    prev = this;
951    this = next;
952
953  MarkCons:
954    next = deref(this,1);
955    this += 4;
956    tag_n = fulltag_of(next);
957    if (!is_node_fulltag(tag_n)) goto MarkCdr;
958    dword = gc_area_dword(next);
959    if (dword >= GCndwords_in_area) goto MarkCdr;
960    set_bits_vars(markbits,dword,bitsp,bits,mask);
961    if (bits & mask) goto MarkCdr;
962    *bitsp = (bits | mask);
963    deref(this,1) = prev;
964    if (tag_n == fulltag_cons) goto DescendCons;
965    goto DescendVector;
966
967  ClimbCar:
968    prev = deref(this,1);
969    deref(this,1) = next;
970
971  MarkCdr:
972    next = deref(this, 0);
973    this -= 4;
974    tag_n = fulltag_of(next);
975    if (!is_node_fulltag(tag_n)) goto Climb;
976    dword = gc_area_dword(next);
977    if (dword >= GCndwords_in_area) goto Climb;
978    set_bits_vars(markbits,dword,bitsp,bits,mask);
979    if (bits & mask) goto Climb;
980    *bitsp = (bits | mask);
981    deref(this, 0) = prev;
982    if (tag_n == fulltag_cons) goto DescendCons;
983    /* goto DescendVector; */
984
985  DescendVector:
986    prev = this;
987    this = next;
988
989  MarkVector:
990    {
991      LispObj *base = (LispObj *) untag(this);
992      unsigned
993        header = *((unsigned *) base),
994      subtag = header_subtag(header),
995      element_count = header_element_count(header),
996      total_size_in_bytes,
997      suffix_dwords;
998
999      tag_n = fulltag_of(header);
1000
1001      if ((tag_n == fulltag_nodeheader) ||
1002          (subtag <= max_32_bit_ivector_subtag)) {
1003        total_size_in_bytes = 4 + (element_count<<2);
1004      } else if (subtag <= max_8_bit_ivector_subtag) {
1005        total_size_in_bytes = 4 + element_count;
1006      } else if (subtag <= max_16_bit_ivector_subtag) {
1007        total_size_in_bytes = 4 + (element_count<<1);
1008      } else if (subtag == subtag_double_float_vector) {
1009        total_size_in_bytes = 8 + (element_count<<3);
1010      } else {
1011        total_size_in_bytes = 4 + ((element_count+7)>>3);
1012      }
1013      suffix_dwords = ((total_size_in_bytes+7)>>3)-1;
1014
1015      if (suffix_dwords) {
1016        set_n_bits(GCmarkbits, dword+1, suffix_dwords);
1017      }
1018
1019      if (tag_n != fulltag_nodeheader) goto Climb;
1020
1021      if (subtag == subtag_hash_vector) {
1022        /* Splice onto weakvll, then climb */
1023        ((hash_table_vector_header *) base)->cache_key = undefined;
1024        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
1025        deref(base,1) = GCweakvll;
1026        GCweakvll = this;
1027        goto Climb;
1028      }
1029
1030      if (subtag == subtag_pool) {
1031        deref(this, 1) = lisp_nil;
1032      }
1033
1034      if (subtag == subtag_weak) {
1035        int weak_type = (unsigned) base[2];
1036        if (weak_type >> population_termination_bit)
1037          element_count -= 2;
1038        else
1039        element_count -= 1;
1040      }
1041
1042      this = untag(this) + ((element_count+1) << 2);
1043      goto MarkVectorLoop;
1044    }
1045
1046  ClimbVector:
1047    prev = *((LispObj *) this);
1048    *((LispObj *) this) = next;
1049
1050  MarkVectorLoop:
1051    this -= 4;
1052    next = *((LispObj *) this);
1053    tag_n = fulltag_of(next);
1054    if (tag_n == fulltag_nodeheader) goto MarkVectorDone;
1055    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
1056    dword = gc_area_dword(next);
1057    if (dword >= GCndwords_in_area) goto MarkVectorLoop;
1058    set_bits_vars(markbits,dword,bitsp,bits,mask);
1059    if (bits & mask) goto MarkVectorLoop;
1060    *bitsp = (bits | mask);
1061    *((LispObj *) this) = prev;
1062    if (tag_n == fulltag_cons) goto DescendCons;
1063    goto DescendVector;
1064
1065  MarkVectorDone:
1066    /* "next" is vector header; "this" is fixnum-aligned.
1067       If  header subtag = subtag_weak_header, put it on weakvll */
1068    this += fulltag_misc;
1069
1070    if (header_subtag(next) == subtag_weak) {
1071      deref(this, 1) = GCweakvll;
1072      GCweakvll = this;
1073    }
1074    goto Climb;
1075  }
1076}
1077
1078unsigned
1079skip_over_ivector(unsigned start, LispObj header)
1080{
1081  unsigned
1082    element_count = header_element_count(header),
1083    subtag = header_subtag(header),
1084    nbytes;
1085
1086  if (subtag <= max_32_bit_ivector_subtag) {
1087    nbytes = element_count << 2;
1088  } else if (subtag <= max_8_bit_ivector_subtag) {
1089    nbytes = element_count;
1090  } else if (subtag <= max_16_bit_ivector_subtag) {
1091    nbytes = element_count << 1;
1092  } else if (subtag == subtag_double_float_vector) {
1093    nbytes = 4 + (element_count << 3);
1094  } else {
1095    nbytes = (element_count+7) >> 3;
1096  }
1097  return start+(~7 & (nbytes + 4 + 7));
1098}
1099
1100
1101void
1102check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
1103{
1104  LispObj x1, *base = start;
1105  int tag;
1106  unsigned ref_dword, node_dword;
1107  Boolean intergen_ref;
1108
1109  while (start < end) {
1110    x1 = *start;
1111    if ((tag = fulltag_of(x1)) == fulltag_immheader) {
1112      start = (LispObj *)skip_over_ivector((unsigned) start, x1);
1113    } else {
1114      intergen_ref = false;
1115      if ((tag == fulltag_misc) || (tag == fulltag_cons)) {       
1116        node_dword = gc_area_dword(x1);
1117        if (node_dword < GCndwords_in_area) {
1118          intergen_ref = true;
1119        }
1120      }
1121      if (intergen_ref == false) {       
1122        x1 = start[1];
1123        tag = fulltag_of(x1);
1124        if ((tag == fulltag_misc) || (tag == fulltag_cons)) {
1125          node_dword = gc_area_dword(x1);
1126          if (node_dword < GCndwords_in_area) {
1127            intergen_ref = true;
1128          }
1129        }
1130      }
1131      if (intergen_ref) {
1132        ref_dword = area_dword(start, base);
1133        if (!ref_bit(refbits, ref_dword)) {
1134          Bug(NULL, "Missing memoization in doubleword at 0x%08X", start);
1135          set_bit(refbits, ref_dword);
1136        }
1137      }
1138      start += 2;
1139    }
1140  }
1141}
1142
1143
1144
1145void
1146mark_memoized_area(area *a, unsigned num_memo_dwords)
1147{
1148  bitvector refbits = a->refbits;
1149  LispObj *p = (LispObj *) a->low, x1, x2;
1150  unsigned inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dword = 0;
1151  Boolean keep_x1, keep_x2;
1152
1153  if (GCDebug) {
1154    check_refmap_consistency(p, p+(num_memo_dwords << 1), refbits);
1155  }
1156
1157  /* The distinction between "inbits" and "outbits" is supposed to help us
1158     detect cases where "uninteresting" setfs have been memoized.  Storing
1159     NIL, fixnums, immediates (characters, etc.) or node pointers to static
1160     or readonly areas is definitely uninteresting, but other cases are
1161     more complicated (and some of these cases are hard to detect.)
1162
1163     Some headers are "interesting", to the forwarder if not to us.
1164
1165     We -don't- give anything any weak treatment here.  Weak things have
1166     to be seen by a full gc, for some value of 'full'.
1167     */
1168
1169  /*
1170    We need to ensure that there are no bits set at or beyond "num_memo_dwords"
1171    in the bitvector.  (This can happen as the EGC tenures/untenures things.)
1172    We find bits by grabbing a fullword at a time and doing a cntlzw instruction;
1173    and don't want to have to check for (< memo_dword num_memo_dwords) in the loop.
1174    */
1175
1176  {
1177    unsigned 
1178      bits_in_last_word = (num_memo_dwords & 0x1f),
1179      index_of_last_word = (num_memo_dwords >> 5);
1180
1181    if (bits_in_last_word != 0) {
1182      refbits[index_of_last_word] &= ~((1<<(32-bits_in_last_word))-1);
1183    }
1184  }
1185       
1186  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1187  inbits = outbits = bits;
1188  while (memo_dword < num_memo_dwords) {
1189    if (bits == 0) {
1190      int remain = 0x20 - bitidx;
1191      memo_dword += remain;
1192      p += (remain+remain);
1193      if (outbits != inbits) {
1194        *bitsp = outbits;
1195      }
1196      bits = *++bitsp;
1197      inbits = outbits = bits;
1198      bitidx = 0;
1199    } else {
1200      nextbit = count_leading_zeros(bits);
1201      if ((diff = (nextbit - bitidx)) != 0) {
1202        memo_dword += diff;
1203        bitidx = nextbit;
1204        p += (diff+diff);
1205      }
1206      x1 = *p++;
1207      x2 = *p++;
1208      bits &= ~(BIT0_MASK >> bitidx);
1209      keep_x1 = mark_ephemeral_root(x1);
1210      keep_x2 = mark_ephemeral_root(x2);
1211      if ((keep_x1 == false) && 
1212          (keep_x2 == false)) {
1213        outbits &= ~(BIT0_MASK >> bitidx);
1214      }
1215      memo_dword++;
1216      bitidx++;
1217    }
1218  }
1219  if (GCDebug) {
1220    p = (LispObj *) a->low;
1221    check_refmap_consistency(p, p+(num_memo_dwords << 1), refbits);
1222  }
1223}
1224
1225
1226
1227void
1228mark_simple_area_range(LispObj *start, LispObj *end)
1229{
1230  LispObj x1, *base;
1231  int tag;
1232
1233  while (start < end) {
1234    x1 = *start;
1235    if ((tag = fulltag_of(x1)) == fulltag_immheader) {
1236      start = (LispObj *)skip_over_ivector((unsigned) start, x1);
1237    } else if (tag != fulltag_nodeheader) {
1238      ++start;
1239      mark_root(x1);
1240      mark_root(*start++);
1241    } else {
1242      int subtag = header_subtag(x1);
1243      int element_count = header_element_count(x1);
1244      int size = (element_count+1 + 1) & ~1;
1245
1246      if (subtag == subtag_hash_vector) {
1247        ((hash_table_vector_header *) start)->cache_key = undefined;
1248        ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1249        start[1] = GCweakvll;
1250        GCweakvll = (LispObj) (((unsigned) start) + fulltag_misc);
1251      } else {
1252
1253        if (subtag == subtag_pool) {
1254          start[1] = lisp_nil;
1255        }
1256
1257        if (subtag == subtag_weak) {
1258          int weak_type = (unsigned) start[2];
1259          if (weak_type >> population_termination_bit)
1260            element_count -= 2;
1261          else
1262            element_count -= 1; 
1263          start[1] = GCweakvll;
1264          GCweakvll = (LispObj) (((unsigned) start) + fulltag_misc);   
1265        }
1266
1267        base = start + element_count + 1;
1268        while(element_count--) {
1269          mark_root(*--base);
1270        }
1271      }
1272      start += size;
1273    }
1274  }
1275}
1276
1277void
1278mark_dohs( void )
1279{
1280  doh_block_ptr doh_block = (doh_block_ptr) lisp_global(DOH_HEAD);
1281  while( doh_block ) {
1282    mark_simple_area_range( &doh_block->data[0], &doh_block->data[doh_block_slots] );
1283    doh_block = doh_block->link;
1284  }
1285}
1286
1287/* Mark a tstack area */
1288void
1289mark_tstack_area(area *a)
1290{
1291  LispObj
1292    *current,
1293    *next,
1294    *start = (LispObj *) (a->active),
1295    *end = start,
1296    *limit = (LispObj *) (a->high);
1297
1298  for (current = start;
1299       end != limit;
1300       current = next) {
1301    next = (LispObj *) *current;
1302    end = ((next >= start) && (next < limit)) ? next : limit;
1303    if (current[1] == 0) {
1304      mark_simple_area_range(current+2, end);
1305    }
1306  }
1307}
1308
1309/*
1310  It's really important that headers never wind up in tagged registers.
1311  Those registers would (possibly) get pushed on the vstack and confuse
1312  the hell out of this routine.
1313
1314  vstacks are just treated as a "simple area range", possibly with
1315  an extra word at the top (where the area's active pointer points.)
1316  */
1317
1318void
1319mark_vstack_area(area *a)
1320{
1321  LispObj
1322    *start = (LispObj *) a->active,
1323    *end = (LispObj *) a->high;
1324
1325  if ((((unsigned)end) - ((unsigned)start)) & 4) {
1326    /* Odd number of words.  Mark the first (can't be a header) */
1327    mark_root(*start);
1328    ++start;
1329  }
1330  mark_simple_area_range(start, end);
1331}
1332
1333/*
1334  Mark lisp frames on the control stack.
1335  Ignore emulator frames (odd backpointer) and C frames (size != 4).
1336*/
1337
1338void
1339mark_cstack_area(area *a)
1340{
1341  BytePtr
1342    current,
1343    next,
1344    limit = a->high,
1345    low = a->low;
1346
1347  for (current = a->active; (current >= low) && (current < limit); current = next) {
1348    next = *((BytePtr *)current);
1349#if 0
1350    if (next < current) {
1351      Bug(NULL, "Child stack frame older than parent");
1352    }
1353#endif
1354    if (next == NULL) break;
1355    if (((next - current) == sizeof(lisp_frame)) &&
1356        (((((lisp_frame *)current)->savefn) == 0) ||
1357         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
1358      /* mark fn, then saved lr */
1359      mark_root(((lisp_frame *)current)->savefn);
1360      mark_pc_root(((lisp_frame *)current)->savelr);
1361    } else {
1362      /* Clear low 2 bits of "next", just in case */
1363      next = (BytePtr) (((unsigned)next) & ~3);
1364    }
1365  }
1366}
1367
1368
1369void
1370reapweakv(LispObj weakv)
1371{
1372  /*
1373    element 2 of the weak vector should be tagged as a cons: if it isn't, just mark it as a root.
1374    if it is, cdr through it until a "marked" cons is encountered.  If the car of any unmarked
1375    cons is marked, mark the cons which contains it; otherwise, splice the cons out of the list.
1376    N.B. : elements 0 and 1 are already marked (or are immediate, etc.)
1377    */
1378  LispObj *prev = ((LispObj *) untag(weakv))+(1+2), cell = *prev;
1379  LispObj termination_list = lisp_nil;
1380  int weak_type = (int) deref(weakv,2);
1381  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
1382          terminatablep = ((weak_type >> population_termination_bit) != 0);
1383  Boolean done = false;
1384  cons *rawcons;
1385  unsigned dword, car_dword;
1386  bitvector markbits = GCmarkbits;
1387
1388  if (terminatablep) {
1389    termination_list = deref(weakv,1+3);
1390  }
1391
1392  if (tag_of(cell) != tag_list) {
1393    mark_root(cell);
1394  } else if (alistp) {
1395    /* weak alist */
1396    while (! done) {
1397      dword = gc_area_dword(cell);
1398      if ((dword >= GCndwords_in_area) ||
1399          (ref_bit(markbits, dword))) {
1400        done = true;
1401      } else {
1402        /* Cons cell is unmarked. */
1403        LispObj alist_cell, thecar;
1404        unsigned cell_tag;
1405
1406        rawcons = (cons *) untag(cell);
1407        alist_cell = rawcons->car;
1408        cell_tag = fulltag_of(alist_cell);
1409
1410        if ((cell_tag == fulltag_cons) &&
1411            ((car_dword = gc_area_dword(alist_cell)) < GCndwords_in_area) &&
1412            (! ref_bit(markbits, car_dword)) &&
1413            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
1414            ((car_dword = gc_area_dword(thecar)) < GCndwords_in_area) &&
1415            (! ref_bit(markbits, car_dword))) {
1416          *prev = rawcons->cdr;
1417          if (terminatablep) {
1418            rawcons->cdr = termination_list;
1419            termination_list = cell;
1420          }
1421        } else {
1422          set_bit(markbits, dword);
1423          prev = (LispObj *)(&(rawcons->cdr));
1424          mark_root(alist_cell);
1425        }
1426        cell = *prev;
1427      }
1428    }
1429  } else {
1430    /* weak list */
1431    while (! done) {
1432      dword = gc_area_dword(cell);
1433      if ((dword >= GCndwords_in_area) ||
1434          (ref_bit(markbits, dword))) {
1435        done = true;
1436      } else {
1437        /* Cons cell is unmarked. */
1438        LispObj thecar;
1439        unsigned cartag;
1440
1441        rawcons = (cons *) untag(cell);
1442        thecar = rawcons->car;
1443        cartag = fulltag_of(thecar);
1444
1445        if (is_node_fulltag(cartag) &&
1446            ((car_dword = gc_area_dword(thecar)) < GCndwords_in_area) &&
1447            (! ref_bit(markbits, car_dword))) {
1448          *prev = rawcons->cdr;
1449          if (terminatablep) {
1450            rawcons->cdr = termination_list;
1451            termination_list = cell;
1452          }
1453        } else {
1454          set_bit(markbits, dword);
1455          prev = (LispObj *)(&(rawcons->cdr));
1456        }
1457        cell = *prev;
1458      }
1459    }
1460  }
1461
1462  if (terminatablep) {
1463    deref(weakv,1+3) = termination_list;
1464    if (termination_list != lisp_nil) {
1465      deref(weakv,1) = GCweakvll;
1466      GCweakvll = weakv;
1467    }
1468  }
1469}
1470
1471/*
1472  Screw: doesn't deal with finalization.
1473  */
1474
1475void
1476reaphashv(LispObj hashv)
1477{
1478  hash_table_vector_header *hashp = (hash_table_vector_header *) untag(hashv);
1479  unsigned 
1480    dword,
1481    npairs = (header_element_count(hashp->header) - 
1482              ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1;
1483  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
1484  Boolean
1485    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
1486  bitvector markbits = GCmarkbits;
1487  int tag;
1488
1489  while (npairs--) {
1490    if (weak_on_value) {
1491      weakelement = pairp[1];
1492    } else {
1493      weakelement = pairp[0];
1494    }
1495    tag = fulltag_of(weakelement);
1496    if (is_node_fulltag(tag)) {
1497      dword = gc_area_dword(weakelement);
1498      if ((dword < GCndwords_in_area) && 
1499          ! ref_bit(markbits, dword)) {
1500        pairp[0] = undefined;
1501        pairp[1] = lisp_nil;
1502        hashp->weak_deletions_count += (1<<fixnumshift);
1503      }
1504    }
1505    pairp += 2;
1506  }
1507}   
1508   
1509
1510
1511Boolean
1512mark_weak_hash_vector(hash_table_vector_header *hashp, unsigned elements)
1513{
1514  unsigned flags = hashp->flags, key_dword, val_dword;
1515  Boolean
1516    marked_new = false, 
1517    key_marked,
1518    val_marked,
1519    weak_value = ((flags & nhash_weak_value_mask) != 0);
1520  int 
1521    skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1,
1522    key_tag,
1523    val_tag,
1524    i;
1525  LispObj
1526    *pairp = (LispObj*) (hashp+1),
1527    key,
1528    val;
1529
1530  /* Mark everything in the header */
1531 
1532  for (i = 2; i<= skip; i++) {
1533    mark_root(deref(hashp,i));
1534  }
1535
1536  elements -= skip;
1537
1538  for (i = 0; i<elements; i+=2, pairp+=2) {
1539    key = pairp[0];
1540    val = pairp[1];
1541    key_marked = val_marked = true;
1542    key_tag = fulltag_of(key);
1543    val_tag = fulltag_of(val);
1544    if (is_node_fulltag(key_tag)) {
1545      key_dword = gc_area_dword(key);
1546      if ((key_dword < GCndwords_in_area) &&
1547          ! ref_bit(GCmarkbits,key_dword)) {
1548        key_marked = false;
1549      }
1550    }
1551    if (is_node_fulltag(val_tag)) {
1552      val_dword = gc_area_dword(val);
1553      if ((val_dword < GCndwords_in_area) &&
1554          ! ref_bit(GCmarkbits,val_dword)) {
1555        val_marked = false;
1556      }
1557    }
1558
1559    if (weak_value) {
1560      if (val_marked & !key_marked) {
1561        mark_root(key);
1562        marked_new = true;
1563      }
1564    } else {
1565      if (key_marked & !val_marked) {
1566        mark_root(val);
1567        marked_new = true;
1568      }
1569    }
1570  }
1571  return marked_new;
1572}
1573
1574
1575Boolean
1576mark_weak_alist(LispObj weak_alist, int weak_type)
1577{
1578  int elements = header_element_count(header_of(weak_alist));
1579  unsigned dword;
1580  int pair_tag;
1581  Boolean marked_new = false;
1582  LispObj alist, pair, key, value;
1583  bitvector markbits = GCmarkbits;
1584
1585  if (weak_type >> population_termination_bit) {
1586    elements -= 1;
1587  }
1588  for(alist = deref(weak_alist, elements);
1589      (fulltag_of(alist) == fulltag_cons) &&
1590      ((dword = gc_area_dword(alist)) < GCndwords_in_area) &&
1591      (! ref_bit(markbits,dword));
1592      alist = cdr(alist)) {
1593    pair = car(alist);
1594    pair_tag = fulltag_of(pair);
1595    if ((is_node_fulltag(pair_tag)) &&
1596        ((dword = gc_area_dword(pair_tag)) < GCndwords_in_area) &&
1597        (! ref_bit(markbits,dword))) {
1598      if (pair_tag == fulltag_cons) {
1599        key = car(pair);
1600        if ((! is_node_fulltag(fulltag_of(key))) ||
1601            ((dword = gc_area_dword(key)) >= GCndwords_in_area) ||
1602            ref_bit(markbits,dword)) {
1603          /* key is marked, mark value if necessary */
1604          value = cdr(pair);
1605          if (is_node_fulltag(fulltag_of(value)) &&
1606              ((dword = gc_area_dword(value)) < GCndwords_in_area) &&
1607              (! ref_bit(markbits,dword))) {
1608            mark_root(value);
1609            marked_new = true;
1610          }
1611        }
1612      } else {
1613          mark_root(pair);
1614          marked_new = true;
1615      }
1616    }
1617  }
1618  return marked_new;
1619}
1620 
1621void
1622markhtabvs()
1623{
1624  LispObj this, header, pending;
1625  int subtag;
1626  bitvector markbits = GCmarkbits;
1627  hash_table_vector_header *hashp;
1628  Boolean marked_new;
1629
1630  do {
1631    pending = (LispObj) NULL;
1632    marked_new = false;
1633   
1634    while (GCweakvll) {
1635      this = GCweakvll;
1636      GCweakvll = deref(this,1);
1637     
1638      header = header_of(this);
1639      subtag = header_subtag(header);
1640     
1641      if (subtag == subtag_weak) {
1642        int weak_type = deref(this,2);
1643        deref(this,1) = pending;
1644        pending = this;
1645        if ((weak_type & population_type_mask) == population_weak_alist) {
1646          if (mark_weak_alist(this, weak_type)) {
1647            marked_new = true;
1648          }
1649        }
1650      } else if (subtag == subtag_hash_vector) {
1651        int elements = header_element_count(header), i;
1652
1653        hashp = (hash_table_vector_header *) untag(this);
1654        if (hashp->flags & nhash_weak_mask) {
1655          deref(this,1) = pending;
1656          pending = this;
1657          if (mark_weak_hash_vector(hashp, elements)) {
1658            marked_new = true;
1659          }
1660        } else {
1661          deref(this,1) = (LispObj)NULL;
1662          for (i = 2; i <= elements; i++) {
1663            mark_root(deref(this,i));
1664          }
1665        } 
1666      } else {
1667        Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this);
1668      }
1669    }
1670
1671    if (marked_new) {
1672      GCweakvll = pending;
1673    }
1674  } while (marked_new);
1675
1676  /* Now, everything's marked that's going to be,  and "pending" is a list
1677     of populations and weak hash tables.  CDR down that list and free
1678     anything that isn't marked.
1679     */
1680
1681  while (pending) {
1682    this = pending;
1683    pending = deref(this,1);
1684    deref(this,1) = (LispObj)NULL;
1685
1686    subtag = header_subtag(header_of(this));
1687    if (subtag == subtag_weak) {
1688      reapweakv(this);
1689    } else {
1690      reaphashv(this);
1691    }
1692  }
1693
1694  /* Finally, mark the termination lists in all terminatable weak vectors
1695     They are now linked together on GCweakvll.
1696     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
1697     but it will force terminatable popualations to hold on to each other
1698     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
1699     */
1700  pending = GCweakvll;
1701  GCweakvll = (LispObj)NULL;
1702  while (pending) {
1703    this = pending;
1704    pending = deref(this,1);
1705    deref(this,1) = (LispObj)NULL;
1706    mark_root(deref(this,1+3));
1707  }
1708}
1709
1710/* Mark the lisp objects in an exception frame */
1711void
1712mark_xp(ExceptionInformation *xp)
1713{
1714  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
1715  int r;
1716
1717
1718  /* registers >= fn should be tagged and marked as roots.
1719     the PC, LR, loc_pc, and CTR should be treated as "pc_locatives".
1720
1721     In general, marking a locative is more expensive than marking
1722     a node is, since it may be neccessary to back up and find the
1723     containing object's header.  Since exception frames contain
1724     many locatives, it'd be wise to mark them *after* marking the
1725     stacks, nilreg-relative globals, etc.
1726     */
1727
1728  for (r = fn; r < 32; r++) {
1729    mark_root((regs[r]));
1730  }
1731
1732
1733
1734  mark_pc_root((regs[loc_pc]));
1735  mark_pc_root((LispObj)xpPC(xp));
1736  mark_pc_root((LispObj)xpLR(xp));
1737  mark_pc_root((LispObj)xpCTR(xp));
1738
1739}
1740void
1741mark_tcr_tlb(TCR *tcr)
1742{
1743  unsigned n = tcr->tlb_limit;
1744  LispObj
1745    *start = tcr->tlb_pointer,
1746    *end = (LispObj *) ((BytePtr)start+n),
1747    node;
1748
1749  while (start < end) {
1750    node = *start;
1751    if (node != no_thread_local_binding_marker) {
1752      mark_root(node);
1753    }
1754    start++;
1755  }
1756}
1757
1758/*
1759  Mark things that're only reachable through some (suspended) TCR.
1760  (This basically means the tcr's gc_context and the exception
1761  frames on its xframe_list.)
1762*/
1763
1764void
1765mark_tcr_xframes(TCR *tcr)
1766{
1767  xframe_list *xframes;
1768  ExceptionInformation *xp;
1769
1770  xp = tcr->gc_context;
1771  if (xp) {
1772    mark_xp(xp);
1773  }
1774 
1775  for (xframes = (xframe_list *) tcr->xframe; 
1776       xframes; 
1777       xframes = xframes->prev) {
1778      mark_xp(xframes->curr);
1779  }
1780}
1781     
1782     
1783void
1784reap_gcable_ptrs()
1785{
1786  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
1787  xmacptr_flag flag;
1788  unsigned dword;
1789  xmacptr *x;
1790
1791  while((next = *prev) != (LispObj)NULL) {
1792    dword = gc_area_dword(next);
1793    x = (xmacptr *) untag(next);
1794
1795    if ((dword >= GCndwords_in_area) ||
1796        (ref_bit(GCmarkbits,dword))) {
1797      prev = &(x->link);
1798    } else {
1799      *prev = x->link;
1800      flag = (xmacptr_flag)(x->flags);
1801      ptr = x->address;
1802
1803      if (ptr) {
1804        switch (flag) {
1805        case xmacptr_flag_recursive_lock:
1806          destroy_recursive_lock(ptr);
1807          break;
1808
1809        case xmacptr_flag_ptr:
1810          deallocate((char *)ptr);
1811          break;
1812
1813        case xmacptr_flag_rwlock:
1814          break;
1815
1816        case xmacptr_flag_semaphore:
1817          destroy_semaphore((void**)&(x->address));
1818          break;
1819
1820        default:
1821          /* (warn "unknown xmacptr_flag: ~s" flag) */
1822          /* Unknowd, and perhaps unknowdable. */
1823          /* Fall in: */
1824        case xmacptr_flag_none:
1825          break;
1826        }
1827      }
1828    }
1829  }
1830}
1831
1832
1833
1834#if 1
1835const unsigned char _one_bits[256] = {
1836    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,
1837    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,
1838    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,
1839    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,
1840    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,
1841    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,
1842    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,
1843    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,
1844    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,
1845    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,
1846    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,
1847    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,
1848    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,
1849    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,
1850    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,
1851    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
1852};
1853
1854#define one_bits(x) _one_bits[x]
1855
1856#else
1857#define one_bits(x) logcount16(x)
1858
1859#endif
1860
1861/* A "pagelet" contains 32 doublewords.  The relocation table contains
1862   a word for each pagelet which defines the lowest address to which
1863   dwords on that pagelet will be relocated.
1864
1865   The relocation address of a given pagelet is the sum of the relocation
1866   address for the preceding pagelet and the number of bytes occupied by
1867   marked objects on the preceding pagelet.
1868*/
1869
1870LispObj
1871calculate_relocation()
1872{
1873  LispObj *relocptr = GCrelocptr;
1874  LispObj current = GCarealow;
1875  bitvector markbits = GCmarkbits;
1876  unsigned char *bytep = (unsigned char *) markbits;
1877  unsigned npagelets = ((GCndwords_in_area+31)>>5);
1878  unsigned thesebits;
1879  LispObj first = 0;
1880
1881  do {
1882    *relocptr++ = current;
1883    thesebits = *markbits++;
1884    if (thesebits == 0xffffffff) {
1885      current += 32*8;
1886      bytep += 4;
1887    } else {
1888      if (!first) {
1889        first = current;
1890        while (thesebits & 0x80000000) {
1891          first += 8;
1892          thesebits += thesebits;
1893        }
1894      }
1895      current += one_bits(*bytep++);
1896      current += one_bits(*bytep++);
1897      current += one_bits(*bytep++);
1898      current += one_bits(*bytep++);
1899    }
1900  } while(--npagelets);
1901  *relocptr++ = current;
1902  return first ? first : current;
1903}
1904
1905LispObj
1906dword_forwarding_address(unsigned dword, int tag_n)
1907{
1908  unsigned pagelet, nbits;
1909  unsigned short near_bits;
1910  LispObj new;
1911
1912  if (GCDebug) {
1913    if (! ref_bit(GCmarkbits, dword)) {
1914      Bug(NULL, "unmarked object being forwarded!\n");
1915    }
1916  }
1917
1918  pagelet = dword >> 5;
1919  nbits = dword & 0x1f;
1920  near_bits = ((unsigned short *)GCmarkbits)[dword>>4];
1921
1922  if (nbits < 16) {
1923    new = GCrelocptr[pagelet] + tag_n;;
1924    /* Increment "new" by the count of 1 bits which precede the dword */
1925    if (near_bits == 0xffff) {
1926      return (new + (nbits << 3));
1927    } else {
1928      near_bits &= (0xffff0000 >> nbits);
1929      if (nbits > 7) {
1930        new += one_bits(near_bits & 0xff);
1931      }
1932      return (new + (one_bits(near_bits >> 8))); 
1933    }
1934  } else {
1935    new = GCrelocptr[pagelet+1] + tag_n;
1936    nbits = 32-nbits;
1937
1938    if (near_bits == 0xffff) {
1939      return (new - (nbits << 3));
1940    } else {
1941      near_bits &= (1<<nbits)-1;
1942      if (nbits > 7) {
1943        new -= one_bits(near_bits >> 8);
1944      }
1945      return (new -  one_bits(near_bits & 0xff));
1946    }
1947  }
1948}
1949
1950
1951LispObj
1952locative_forwarding_address(LispObj obj)
1953{
1954  int tag_n = fulltag_of(obj);
1955  unsigned dword;
1956
1957  /* Locatives can be tagged as conses, "fulltag_misc"
1958     objects, or as fixnums.  Immediates, headers, and nil
1959     shouldn't be "forwarded".  Nil never will be, but it
1960     doesn't hurt to check ... */
1961
1962  if ((1<<tag_n) & ((1<<fulltag_immheader) |
1963                    (1<<fulltag_nodeheader) |
1964                    (1<<fulltag_imm) |
1965                    (1<<fulltag_nil))) {
1966    return obj;
1967  }
1968
1969  dword = gc_area_dword(obj);
1970
1971  if ((dword >= GCndwords_in_area) ||
1972      (obj < GCfirstunmarked)) {
1973    return obj;
1974  }
1975
1976  return dword_forwarding_address(dword, tag_n);
1977}
1978
1979LispObj
1980node_forwarding_address(LispObj node)
1981{
1982  int tag_n;
1983  unsigned dword = gc_area_dword(node);
1984
1985  if ((dword >= GCndwords_in_area) ||
1986      (node < GCfirstunmarked)) {
1987    return node;
1988  }
1989
1990  tag_n = fulltag_of(node);
1991  if (!is_node_fulltag(tag_n)) {
1992    return node;
1993  }
1994
1995  return dword_forwarding_address(dword, tag_n);
1996}
1997
1998Boolean
1999update_noderef(LispObj *noderef)
2000{
2001  LispObj
2002    node = *noderef,
2003    new = node_forwarding_address(node);
2004
2005  if (new != node) {
2006    *noderef = new;
2007    return true;
2008  }
2009  return false;
2010}
2011
2012void
2013update_locref(LispObj *locref)
2014{
2015  LispObj
2016    obj = *locref,
2017    new = locative_forwarding_address(obj);
2018
2019  if (new != obj) {
2020    *locref = new;
2021  }
2022}
2023
2024void
2025forward_gcable_ptrs()
2026{
2027  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2028
2029  while ((next = *prev) != (LispObj)NULL) {
2030    *prev = node_forwarding_address(next);
2031    prev = &(((xmacptr *)(untag(next)))->link);
2032  }
2033}
2034
2035void
2036forward_range(LispObj *range_start, LispObj *range_end)
2037{
2038  LispObj *p = range_start, node, new;
2039  int tag_n, nwords;
2040  hash_table_vector_header *hashp;
2041
2042  while (p < range_end) {
2043    node = *p;
2044    tag_n = fulltag_of(node);
2045    if (tag_n == fulltag_immheader) {
2046      p = (LispObj *) skip_over_ivector((unsigned) p, node);
2047    } else if (tag_n == fulltag_nodeheader) {
2048      nwords = header_element_count(node);
2049      nwords += (1- (nwords&1));
2050      if ((header_subtag(node) == subtag_hash_vector) &&
2051          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
2052        int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2053        hashp = (hash_table_vector_header *) p;
2054        p++;
2055        nwords -= skip;
2056        while(skip--) {
2057          update_noderef(p);
2058          p++;
2059        }
2060        /* "nwords" is odd at this point: there are (floor nwords 2)
2061           key/value pairs to look at, and then an extra word for
2062           alignment.  Process them two at a time, then bump "p"
2063           past the alignment word. */
2064        nwords >>= 1;
2065        while(nwords--) {
2066          if (update_noderef(p) && hashp) {
2067            hashp->flags |= nhash_key_moved_mask;
2068            hashp = NULL;
2069          }
2070          p++;
2071          update_noderef(p);
2072          p++;
2073        }
2074        *p++ = 0;
2075      } else {
2076        p++;
2077        while(nwords--) {
2078          update_noderef(p);
2079          p++;
2080        }
2081      }
2082    } else {
2083      new = node_forwarding_address(node);
2084      if (new != node) {
2085        *p = new;
2086      }
2087      p++;
2088      update_noderef(p);
2089      p++;
2090    }
2091  }
2092}
2093
2094
2095void
2096forward_memoized_area(area *a, unsigned num_memo_dwords)
2097{
2098  bitvector refbits = a->refbits;
2099  LispObj *p = (LispObj *) a->low, x1, x2, new;
2100  unsigned bits, bitidx, *bitsp, nextbit, diff, memo_dword = 0, hash_dword_limit = 0;
2101  int tag_x1;
2102  hash_table_vector_header *hashp = NULL;
2103  Boolean header_p;
2104
2105  if (GCDebug) {
2106    check_refmap_consistency(p, p+(num_memo_dwords << 1), refbits);
2107  }
2108
2109  /* This is pretty straightforward, but we have to note
2110     when we move a key in a hash table vector that wants
2111     us to tell it about that. */
2112
2113  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
2114  while (memo_dword < num_memo_dwords) {
2115    if (bits == 0) {
2116      int remain = 0x20 - bitidx;
2117      memo_dword += remain;
2118      p += (remain+remain);
2119      bits = *++bitsp;
2120      bitidx = 0;
2121    } else {
2122      nextbit = count_leading_zeros(bits);
2123      if ((diff = (nextbit - bitidx)) != 0) {
2124        memo_dword += diff;
2125        bitidx = nextbit;
2126        p += (diff+diff);
2127      }
2128      x1 = p[0];
2129      x2 = p[1];
2130      tag_x1 = fulltag_of(x1);
2131      bits &= ~(BIT0_MASK >> bitidx);
2132      header_p = (tag_x1 == fulltag_nodeheader);
2133
2134      if (header_p &&
2135          (header_subtag(x1) == subtag_hash_vector)) {
2136        hashp = (hash_table_vector_header *) p;
2137        if (hashp->flags & nhash_track_keys_mask) {
2138          hash_dword_limit = memo_dword + ((header_element_count(x1)+2)>>1);
2139        } else {
2140          hashp = NULL;
2141        }
2142      }
2143
2144
2145      if (! header_p) {
2146        new = node_forwarding_address(x1);
2147        if (new != x1) {
2148          *p = new;
2149        }
2150      }
2151      p++;
2152
2153      new = node_forwarding_address(x2);
2154      if (new != x2) {
2155        *p = new;
2156        if (memo_dword < hash_dword_limit) {
2157          hashp->flags |= nhash_key_moved_mask;
2158          hash_dword_limit = 0;
2159          hashp = NULL;
2160        }
2161      }
2162      p++;
2163      memo_dword++;
2164      bitidx++;
2165
2166    }
2167  }
2168}
2169
2170void
2171forward_dohs( void )
2172{
2173  doh_block_ptr doh_block = (doh_block_ptr) lisp_global(DOH_HEAD);
2174  while( doh_block ) {
2175    forward_range( &doh_block->data[0], &doh_block->data[doh_block_slots] );
2176    doh_block = doh_block->link;
2177  }
2178}
2179
2180
2181/* Forward a tstack area */
2182void
2183forward_tstack_area(area *a)
2184{
2185  LispObj
2186    *current,
2187    *next,
2188    *start = (LispObj *) a->active,
2189    *end = start,
2190    *limit = (LispObj *) (a->high);
2191
2192  for (current = start;
2193       end != limit;
2194       current = next) {
2195    next = (LispObj *) *current;
2196    end = ((next >= start) && (next < limit)) ? next : limit;
2197    if (current[1] == 0) {
2198      forward_range(current+2, end);
2199    }
2200  }
2201}
2202
2203/* Forward a vstack area */
2204void
2205forward_vstack_area(area *a)
2206{
2207  LispObj
2208    *p = (LispObj *) a->active,
2209    *q = (LispObj *) a->high;
2210
2211  if (((unsigned)p) & 4) {
2212    update_noderef(p);
2213    p++;
2214  }
2215  forward_range(p, q);
2216}
2217
2218void
2219forward_cstack_area(area *a)
2220{
2221  BytePtr
2222    current,
2223    next,
2224    limit = a->high,
2225    low = a->low;
2226
2227  for (current = a->active; (current >= low) && (current < limit); current = next) {
2228    next = *((BytePtr *)current);
2229    if (next == NULL) break;
2230    if (((next - current) == sizeof(lisp_frame)) &&
2231        (((((lisp_frame *)current)->savefn) == 0) ||
2232         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
2233      update_noderef(&((lisp_frame *) current)->savefn);
2234      update_locref(&((lisp_frame *) current)->savelr);
2235    } else {
2236      /* Clear low 2 bits of "next", just in case */
2237      next = (BytePtr) (((unsigned)next) & ~3);
2238    }
2239  }
2240}
2241
2242void
2243forward_xp(ExceptionInformation *xp)
2244{
2245  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
2246  int r;
2247
2248  /* registers >= fn should be tagged and forwarded as roots.
2249     the PC, LR, loc_pc, and CTR should be treated as "locatives".
2250     */
2251
2252  for (r = fn; r < 32; r++) {
2253    update_noderef((LispObj*) (&(regs[r])));
2254  }
2255
2256  update_locref((LispObj*) (&(regs[loc_pc])));
2257
2258  update_locref((LispObj*) (&(xpPC(xp))));
2259  update_locref((LispObj*) (&(xpLR(xp))));
2260  update_locref((LispObj*) (&(xpCTR(xp))));
2261}
2262
2263void
2264forward_tcr_tlb(TCR *tcr)
2265{
2266  unsigned n = tcr->tlb_limit;
2267  LispObj
2268    *start = tcr->tlb_pointer, 
2269    *end = (LispObj *) ((BytePtr)start+n),
2270    node;
2271
2272  while (start < end) {
2273    node = *start;
2274    if (node != no_thread_local_binding_marker) {
2275      update_noderef(start);
2276    }
2277    start++;
2278  }
2279}
2280
2281void
2282forward_tcr_xframes(TCR *tcr)
2283{
2284  xframe_list *xframes;
2285  ExceptionInformation *xp;
2286
2287  xp = tcr->gc_context;
2288  if (xp) {
2289    forward_xp(xp);
2290  }
2291  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2292    forward_xp(xframes->curr);
2293  }
2294}
2295
2296
2297/*
2298  Compact the dynamic heap (from GCfirstunmarked through its end.)
2299  Return the doubleword address of the new freeptr.
2300  */
2301
2302LispObj
2303compact_dynamic_heap()
2304{
2305  LispObj *src = (LispObj*) GCfirstunmarked, *dest = src, node, new;
2306  unsigned elements, dword = gc_area_dword(GCfirstunmarked), node_dwords = 0, imm_dwords = 0;
2307  unsigned bitidx, *bitsp, bits, nextbit, diff;
2308  int tag;
2309  bitvector markbits = GCmarkbits;
2310    /* keep track of whether or not we saw any
2311       code_vector headers, and only flush cache if so. */
2312  Boolean GCrelocated_code_vector = false;
2313
2314  if (dword < GCndwords_in_area) {
2315    lisp_global(FWDNUM) += (1<<fixnum_shift);
2316 
2317    set_bitidx_vars(markbits,dword,bitsp,bits,bitidx);
2318    while (dword < GCndwords_in_area) {
2319      if (bits == 0) {
2320        int remain = 0x20 - bitidx;
2321        dword += remain;
2322        src += (remain+remain);
2323        bits = *++bitsp;
2324        bitidx = 0;
2325      } else {
2326        /* Have a non-zero markbits word; all bits more significant than
2327           "bitidx" are 0.  Count leading zeros in "bits" (there'll be
2328           at least "bitidx" of them.)  If there are more than "bitidx"
2329           leading zeros, bump "dword", "bitidx", and "src" by the difference. */
2330        nextbit = count_leading_zeros(bits);
2331        if ((diff = (nextbit - bitidx)) != 0) {
2332          dword += diff;
2333          bitidx = nextbit;
2334          src += (diff+diff);
2335        }
2336
2337        if (GCDebug) {
2338          if (dest != (LispObj*)locative_forwarding_address((LispObj)src)) {
2339            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%08x to 0x%08x,\n expected to go to 0x%08x\n", 
2340                src, dest, locative_forwarding_address((LispObj)src));
2341          }
2342        }
2343
2344        node = *src++;
2345        tag = fulltag_of(node);
2346        if (tag == fulltag_nodeheader) {
2347          elements = header_element_count(node);
2348          node_dwords = (elements+2)>>1;
2349          dword += node_dwords;
2350          if ((header_subtag(node) == subtag_hash_vector) &&
2351              (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
2352            hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
2353            int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2354         
2355            *dest++ = node;
2356            elements -= skip;
2357            while(skip--) {
2358              *dest++ = node_forwarding_address(*src++);
2359            }
2360            /* There should be an even number of (key/value) pairs in elements;
2361               an extra alignment word follows. */
2362            elements >>= 1;
2363            while (elements--) {
2364              if (hashp) {
2365                node = *src++;
2366                new = node_forwarding_address(node);
2367                if (new != node) {
2368                  hashp->flags |= nhash_key_moved_mask;
2369                  hashp = NULL;
2370                  *dest++ = new;
2371                } else {
2372                  *dest++ = node;
2373                }
2374              } else {
2375                *dest++ = node_forwarding_address(*src++);
2376              }
2377              *dest++ = node_forwarding_address(*src++);
2378            }
2379            *dest++ = 0;
2380            src++;
2381          } else {
2382            *dest++ = node;
2383            *dest++ = node_forwarding_address(*src++);
2384            while(--node_dwords) {
2385              *dest++ = node_forwarding_address(*src++);
2386              *dest++ = node_forwarding_address(*src++);
2387            }
2388          }
2389          set_bitidx_vars(markbits,dword,bitsp,bits,bitidx);
2390        } else if (tag == fulltag_immheader) {
2391          *dest++ = node;
2392          *dest++ = *src++;
2393          elements = header_element_count(node);
2394          tag = header_subtag(node);
2395          if (tag <= max_32_bit_ivector_subtag) {
2396            if (tag == subtag_code_vector) {
2397              GCrelocated_code_vector = true;
2398            }
2399            imm_dwords = (((elements+1)+1)>>1);
2400          } else if (tag <= max_8_bit_ivector_subtag) {
2401            imm_dwords = (((elements+4)+7)>>3);
2402          } else if (tag <= max_16_bit_ivector_subtag) {
2403            imm_dwords = (((elements+2)+3)>>2);
2404          } else if (tag == subtag_bit_vector) {
2405            imm_dwords = (((elements+32)+63)>>6);
2406          } else {
2407            imm_dwords = elements+1;
2408          }
2409          dword += imm_dwords;
2410          while (--imm_dwords) {
2411            *dest++ = *src++;
2412            *dest++ = *src++;
2413          }
2414          set_bitidx_vars(markbits,dword,bitsp,bits,bitidx);
2415        } else {
2416          *dest++ = node_forwarding_address(node);
2417          *dest++ = node_forwarding_address(*src++);
2418          bits &= ~(BIT0_MASK >> bitidx);
2419          dword++;
2420          bitidx++;
2421        }
2422      }
2423 
2424    }
2425
2426    {
2427      unsigned nbytes = (unsigned)dest - (unsigned)GCfirstunmarked;
2428      if ((nbytes != 0) && GCrelocated_code_vector) {
2429        xMakeDataExecutable((LogicalAddress)GCfirstunmarked, nbytes);
2430      }
2431    }
2432  }
2433  return (LispObj)dest;
2434}
2435
2436
2437Boolean
2438youngest_non_null_area_p (area *a)
2439{
2440  if (a->active == a->high) {
2441    return false;
2442  } else {
2443    for (a = a->younger; a; a = a->younger) {
2444      if (a->active != a->high) {
2445        return false;
2446      }
2447    }
2448  };
2449  return true;
2450}
2451
2452Boolean just_purified_p = false;
2453
2454
2455/*
2456  All thread's stack areas have been "normalized", as
2457  has the dynamic heap.  (The "active" pointer in these areas
2458  matches the stack pointer/freeptr value at the time that
2459  the exception occurred.)
2460*/
2461
2462
2463#define get_time(when) gettimeofday(&when, NULL)
2464
2465void 
2466gc(TCR *tcr)
2467{
2468  xframe_list *xframes = (tcr->xframe);
2469  struct timeval start, stop;
2470  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
2471  unsigned timeidx = 1;
2472  xframe_list *x;
2473  special_binding *sb = (tcr->db_link);
2474  LispObj
2475    pkg,
2476    itabvec = 0;
2477  BytePtr oldfree = a->active;
2478  TCR *other_tcr;
2479
2480  /* make_page_node_map((LispObj) a->low, (LispObj)a->active); */
2481  get_time(start);
2482  lisp_global(IN_GC) = (1<<fixnumshift);
2483
2484  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
2485  if (GCephemeral_low) {
2486    GCn_ephemeral_dwords=area_dword(oldfree, GCephemeral_low);
2487    update_area_refmaps(oldfree);
2488  } else {
2489    if (a->younger) {
2490      unprotect_area(oldspace_protected_area);
2491    }
2492    GCn_ephemeral_dwords = 0;
2493  }
2494 
2495  GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
2496
2497  if (just_purified_p) {
2498    just_purified_p = false;
2499  } else {
2500    if (GCDebug) {
2501      check_all_areas();
2502    }
2503  }
2504
2505  if (GCephemeral_low) {
2506    if ((oldfree-g1_area->low) < g1_area->threshold) {
2507      to = g1_area;
2508      note = a;
2509      timeidx = 4;
2510    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
2511      to = g2_area;
2512      from = g1_area;
2513      note = g1_area;
2514      timeidx = 3;
2515    } else {
2516      to = tenured_area;
2517      from = g2_area;
2518      note = g2_area;
2519      timeidx = 2;
2520    } 
2521  } else {
2522    note = tenured_area;
2523  }
2524
2525
2526  if (from) {
2527    untenure_from_area(from);
2528  }
2529     
2530  GCmarkbits = a->markbits;
2531  GCarealow = (LispObj) a->low,
2532  GCndwords_in_area = gc_area_dword(oldfree);
2533
2534  zero_bits(GCmarkbits, GCndwords_in_area);
2535  GCweakvll = (LispObj)NULL;
2536
2537
2538  if (GCn_ephemeral_dwords == 0) {
2539    /* For GCTWA, mark the internal package hash table vector of
2540     *PACKAGE*, but don't mark its contents. */
2541    {
2542      LispObj
2543        itab;
2544      unsigned
2545        dword, ndwords;
2546     
2547      pkg = nrs_PACKAGE.vcell;
2548      if ((fulltag_of(pkg) == fulltag_misc) &&
2549          (header_subtag(header_of(pkg)) == subtag_package)) {
2550        itab = ((package *)(untag(pkg)))->itab;
2551        itabvec = car(itab);
2552        dword = gc_area_dword(itabvec);
2553        if (dword < GCndwords_in_area) {
2554          ndwords = (header_element_count(header_of(itabvec))+1) >> 1;
2555          set_n_bits(GCmarkbits, dword, ndwords);
2556        }
2557      }
2558    }
2559  }
2560
2561  {
2562    area *next_area;
2563    area_code code;
2564
2565    /* Could make a jump table instead of the typecase */
2566
2567    for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2568      switch (code) {
2569      case AREA_TSTACK:
2570        mark_tstack_area(next_area);
2571        break;
2572
2573      case AREA_VSTACK:
2574        mark_vstack_area(next_area);
2575        break;
2576
2577      case AREA_CSTACK:
2578        mark_cstack_area(next_area);
2579        break;
2580
2581      case AREA_STATIC:
2582      case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
2583        /* In both of these cases, we -could- use the area's "markbits"
2584           bitvector as a reference map.  It's safe (but slower) to
2585           ignore that map and process the entire area.
2586           */
2587        if (next_area->younger == NULL) {
2588          mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
2589        }
2590        break;
2591
2592      default:
2593        break;
2594      }
2595    }
2596  }
2597 
2598  if (lisp_global(OLDEST_EPHEMERAL)) {
2599    mark_memoized_area(tenured_area, area_dword(a->low,tenured_area->low));
2600  }
2601
2602  other_tcr = tcr;
2603  do {
2604    mark_tcr_xframes(other_tcr);
2605    mark_tcr_tlb(other_tcr);
2606    other_tcr = other_tcr->next;
2607  } while (other_tcr != tcr);
2608
2609  mark_dohs();          /* Creole */
2610
2611
2612
2613    /* Go back through *package*'s internal symbols, marking
2614       any that aren't worthless.
2615       */
2616   
2617  if (itabvec) {
2618    int
2619      i,
2620      n = header_element_count(header_of(itabvec));
2621    LispObj
2622      sym,
2623      *raw = 1+((LispObj *)(untag(itabvec)));
2624
2625    for (i = 0; i < n; i++) {
2626      sym = *raw++;
2627      if (fulltag_of(sym) == fulltag_misc) {
2628        lispsymbol *rawsym = (lispsymbol *)(untag(sym));
2629        unsigned dword = gc_area_dword(sym);
2630         
2631        if ((dword < GCndwords_in_area) &&
2632            (!ref_bit(GCmarkbits,dword))) {
2633          /* Symbol is in GC area, not marked.
2634             Mark it if fboundp, boundp, or if
2635             it has a plist or another home package.
2636             */
2637           
2638          if (FBOUNDP(rawsym) ||
2639              BOUNDP(rawsym) ||
2640              (rawsym->flags != 0) || /* SPECIAL, etc. */
2641              ((rawsym->package_plist != pkg) &&
2642               (rawsym->package_plist != lisp_nil))) {
2643            mark_root(sym);
2644          }
2645        }
2646      }
2647    }
2648  }
2649
2650  (void)markhtabvs();
2651
2652  if (itabvec) {
2653    int
2654      i,
2655      n = header_element_count(header_of(itabvec));
2656    LispObj
2657      sym,
2658      *raw = 1+((LispObj *)(untag(itabvec)));
2659
2660    for (i = 0; i < n; i++, raw++) {
2661      sym = *raw;
2662      if (fulltag_of(sym) == fulltag_misc) {
2663        lispsymbol *rawsym = (lispsymbol *)(untag(sym));
2664        unsigned dword = gc_area_dword(sym);
2665
2666        if ((dword < GCndwords_in_area) &&
2667            (!ref_bit(GCmarkbits,dword))) {
2668          *raw = unbound;
2669        }
2670      }
2671    }
2672  }
2673 
2674  reap_gcable_ptrs();
2675
2676  GCrelocptr = global_reloctab;
2677  GCfirstunmarked = calculate_relocation();
2678
2679  forward_range((LispObj *) GCarealow, (LispObj *) GCfirstunmarked);
2680
2681  other_tcr = tcr;
2682  do {
2683    forward_tcr_xframes(other_tcr);
2684    forward_tcr_tlb(other_tcr);
2685    other_tcr = other_tcr->next;
2686  } while (other_tcr != tcr);
2687
2688  forward_dohs();               /* Creole */
2689 
2690  forward_gcable_ptrs();
2691
2692
2693
2694  {
2695    area *next_area;
2696    area_code code;
2697
2698    /* Could make a jump table instead of the typecase */
2699
2700    for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2701      switch (code) {
2702      case AREA_TSTACK:
2703        forward_tstack_area(next_area);
2704        break;
2705
2706      case AREA_VSTACK:
2707        forward_vstack_area(next_area);
2708        break;
2709
2710      case AREA_CSTACK:
2711        forward_cstack_area(next_area);
2712        break;
2713
2714      case AREA_STATIC:
2715      case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
2716        if (next_area->younger == NULL) {
2717          forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
2718        }
2719        break;
2720
2721      default:
2722        break;
2723      }
2724    }
2725  }
2726 
2727  if (GCephemeral_low) {
2728    forward_memoized_area(tenured_area, area_dword(a->low, tenured_area->low));
2729  }
2730
2731 
2732  a->active = (BytePtr) compact_dynamic_heap();
2733 
2734  /* Need to do this before protection kicks back in */
2735  zero_last_page(a->active);
2736
2737  if (to) {
2738    tenure_to_area(to);
2739  }
2740
2741  /*
2742    If the EGC is enabled:
2743     If there's no room for the youngest generation, untenure everything.
2744     If this was a full GC and there's now room for the youngest generation,
2745     tenure everything.
2746     */
2747  resize_dynamic_heap(a->active,
2748                      (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
2749
2750  if (a->older != NULL) {
2751    unsigned nfree = (a->high - a->active);
2752
2753
2754    if (nfree < a->threshold) {
2755      untenure_from_area(tenured_area);
2756    } else {
2757      if (GCephemeral_low == 0) {
2758        tenure_to_area(tenured_area);
2759      }
2760    }
2761  }
2762
2763  lisp_global(GC_NUM) += (1<<fixnumshift);
2764  if (note) {
2765    note->gccount += (1<<fixnumshift);
2766  }
2767
2768  if (GCDebug) {
2769    check_all_areas();
2770  }
2771
2772  other_tcr = tcr;
2773  do {
2774    other_tcr->gc_context = NULL;
2775    other_tcr = other_tcr->next;
2776  } while (other_tcr != tcr);
2777 
2778  lisp_global(IN_GC) = 0;
2779
2780  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
2781  get_time(stop);
2782
2783  {
2784    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
2785    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
2786    LispObj val;
2787    struct timeval *timeinfo;
2788
2789    val = total_gc_microseconds->vcell;
2790    if ((fulltag_of(val) == fulltag_misc) &&
2791        (header_subtag(header_of(val)) == subtag_macptr)) {
2792      timersub(&stop, &start, &stop);
2793      timeinfo = (struct timeval *) ((macptr *) (untag(val)))->address;
2794      timeradd(timeinfo,  &stop, timeinfo);
2795      timeradd(timeinfo+timeidx,  &stop, timeinfo+timeidx);
2796    }
2797
2798    val = total_bytes_freed->vcell;
2799    if ((fulltag_of(val) == fulltag_misc) &&
2800        (header_subtag(header_of(val)) == subtag_macptr)) {
2801      long long justfreed = oldfree - a->active;
2802      *( (long long *) ((macptr *) (untag(val)))->address) += justfreed;
2803    }
2804  }
2805}
2806
2807     
2808   
2809/*
2810  Total the (physical) byte sizes of all ivectors in the indicated memory range
2811*/
2812
2813unsigned
2814unboxed_bytes_in_range(LispObj *start, LispObj *end)
2815{
2816  unsigned total=0, elements, tag, subtag, bytes;
2817  LispObj header;
2818
2819  while (start < end) {
2820    header = *start;
2821    tag = fulltag_of(header);
2822   
2823    if ((tag == fulltag_nodeheader) ||
2824        (tag == fulltag_immheader)) {
2825      elements = header_element_count(header);
2826      if (tag == fulltag_nodeheader) {
2827        start += ((elements+2) & ~1);
2828      } else {
2829        subtag = header_subtag(header);
2830
2831        if (subtag <= max_32_bit_ivector_subtag) {
2832          bytes = 4 + (elements<<2);
2833        } else if (subtag <= max_8_bit_ivector_subtag) {
2834          bytes = 4 + elements;
2835        } else if (subtag <= max_16_bit_ivector_subtag) {
2836          bytes = 4 + (elements<<1);
2837        } else if (subtag == subtag_double_float_vector) {
2838          bytes = 8 + (elements<<3);
2839        } else {
2840          bytes = 4 + ((elements+7)>>3);
2841        }
2842        bytes = (bytes+7) & ~7;
2843        total += bytes;
2844        start += (bytes >> 2);
2845      }
2846    } else {
2847      start += 2;
2848    }
2849  }
2850  return total;
2851}
2852
2853
2854/*
2855  This assumes that it's getting called with a simple-{base,general}-string
2856  or code vector as an argument and that there's room for the object in the
2857  destination area.
2858*/
2859
2860
2861LispObj
2862purify_displaced_object(LispObj obj, area *dest, unsigned disp)
2863{
2864  BytePtr
2865    free = dest->active,
2866    *old = (BytePtr *) untag(obj);
2867  LispObj
2868    header = header_of(obj), 
2869    new;
2870  unsigned 
2871    subtag = header_subtag(header), 
2872    element_count = header_element_count(header),
2873    physbytes;
2874
2875  switch(subtag) {
2876  case subtag_simple_base_string:
2877    physbytes = 4 + element_count;
2878    break;
2879
2880  case subtag_simple_general_string:
2881    physbytes = 4 + (element_count << 1);
2882    break;
2883
2884  case subtag_code_vector:
2885    physbytes = 4 + (element_count << 2);
2886    break;
2887
2888  default:
2889    Bug(NULL, "Can't purify object at 0x%08x", obj);
2890    return obj;
2891  }
2892  physbytes = (physbytes+7)&~7;
2893  dest->active += physbytes;
2894
2895  new = (LispObj)free+disp;
2896
2897  memcpy(free, (BytePtr)old, physbytes);
2898  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
2899  /* Actually, it's best to always leave a trail, for two reasons.
2900     a) We may be walking the same heap that we're leaving forwaring
2901     pointers in, so we don't want garbage that we leave behind to
2902     look like a header.
2903     b) We'd like to be able to forward code-vector locatives, and
2904     it's easiest to do so if we leave a {forward_marker, dword_locative}
2905     pair at every doubleword in the old vector.
2906     */
2907  while(physbytes) {
2908    *old++ = (BytePtr) forward_marker;
2909    *old++ = (BytePtr) free;
2910    free += 8;
2911    physbytes -= 8;
2912  }
2913  return new;
2914}
2915
2916LispObj
2917purify_object(LispObj obj, area *dest)
2918{
2919  return purify_displaced_object(obj, dest, fulltag_of(obj));
2920}
2921
2922
2923#define FORWARD_ONLY 0
2924#define COPY_CODE (1<<0)
2925#define COPY_STRINGS (1<<1)
2926
2927void
2928copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy)
2929{
2930  LispObj obj = *ref, header;
2931  unsigned tag = fulltag_of(obj), header_tag, header_subtag;
2932
2933  if ((tag == fulltag_misc) &&
2934      (((BytePtr)obj) > low) &&
2935      (((BytePtr)obj) < high)) {
2936    header = deref(obj, 0);
2937    if (header == forward_marker) { /* already copied */
2938      *ref = (untag(deref(obj,1)) + tag);
2939    } else {
2940      header_tag = fulltag_of(header);
2941      if (header_tag == fulltag_immheader) {
2942        header_subtag = header_subtag(header);
2943        if (((header_subtag == subtag_code_vector) && (what_to_copy & COPY_CODE)) ||
2944            ((what_to_copy & COPY_STRINGS) && 
2945             ((header_subtag == subtag_simple_base_string) ||
2946              (header_subtag == subtag_simple_general_string)))) {
2947          *ref = purify_object(obj, dest);
2948        }
2949      }
2950    }
2951  }
2952}
2953
2954void
2955purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to, int what)
2956{
2957  LispObj
2958    loc = *locaddr,
2959    header;
2960  unsigned
2961    tag = fulltag_of(loc);
2962
2963  if (((BytePtr)loc > low) &&
2964      ((BytePtr)loc < high)) {
2965    LispObj *p = (LispObj *)(untag(loc));
2966    switch (tag) {
2967    case fulltag_even_fixnum:
2968    case fulltag_odd_fixnum:
2969      if (*p == forward_marker) {
2970        *locaddr = (p[1]+tag);
2971      } else {
2972        /* Grovel backwards until the header's found; copy
2973           the code vector to to space, then treat it as if it
2974           hasn't already been copied. */
2975        do {
2976          p -= 2;
2977          tag += 8;
2978          header = *p;
2979        } while ((header & code_header_mask) != subtag_code_vector);
2980        *locaddr = purify_displaced_object((LispObj)p, to, tag);
2981      }
2982      break;
2983
2984    case fulltag_misc:
2985      copy_ivector_reference(locaddr, low, high, to, what);
2986      break;
2987    }
2988  }
2989}
2990
2991void
2992purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
2993{
2994  LispObj header;
2995  unsigned tag;
2996
2997  while (start < end) {
2998    header = *start;
2999    if (header == forward_marker) {
3000      start += 2;
3001    } else {
3002      tag = fulltag_of(header);
3003      if (tag == fulltag_immheader) {
3004        start = (LispObj *)skip_over_ivector((unsigned)start, header);
3005      } else {
3006        if (tag != fulltag_nodeheader) {
3007          copy_ivector_reference(start, low, high, to, what);
3008        }
3009        start++;
3010        copy_ivector_reference(start, low, high, to, what);
3011        start++;
3012      }
3013    }
3014  }
3015}
3016       
3017/* Purify references from tstack areas */
3018void
3019purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3020{
3021  LispObj
3022    *current,
3023    *next,
3024    *start = (LispObj *) (a->active),
3025    *end = start,
3026    *limit = (LispObj *) (a->high);
3027
3028  for (current = start;
3029       end != limit;
3030       current = next) {
3031    next = (LispObj *) *current;
3032    end = ((next >= start) && (next < limit)) ? next : limit;
3033    if (current[1] == 0) {
3034      purify_range(current+2, end, low, high, to, what);
3035    }
3036  }
3037}
3038
3039/* Purify a vstack area */
3040void
3041purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3042{
3043  LispObj
3044    *p = (LispObj *) a->active,
3045    *q = (LispObj *) a->high;
3046
3047  if (((unsigned)p) & 4) {
3048    copy_ivector_reference(p, low, high, to, what);
3049    p++;
3050  }
3051  purify_range(p, q, low, high, to, what);
3052}
3053
3054void
3055purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3056{
3057  BytePtr
3058    current,
3059    next,
3060    limit = a->high;
3061
3062  for (current = a->active; current != limit; current = next) {
3063    next = *((BytePtr *)current);
3064    if (next == NULL) break;
3065    if (((next - current) == sizeof(lisp_frame)) && 
3066        (((((lisp_frame *)current)->savefn) == 0) ||
3067         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
3068      purify_locref(&((lisp_frame *) current)->savelr, low, high, to, what);
3069    } else {
3070      /* Clear low 2 bits of "next", just in case */
3071      next = (BytePtr) (((unsigned)next) & ~3);
3072    }
3073  }
3074}
3075
3076void
3077purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what)
3078{
3079  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
3080  int r;
3081
3082  /* registers >= fn should be treated as roots.
3083     The PC, LR, loc_pc, and CTR should be treated as "locatives".
3084   */
3085
3086  for (r = fn; r < 32; r++) {
3087    copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to, what);
3088  };
3089
3090  purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to, what);
3091
3092  purify_locref((LispObj*) (&(xpPC(xp))), low, high, to, what);
3093  purify_locref((LispObj*) (&(xpLR(xp))), low, high, to, what);
3094  purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to, what);
3095
3096  /* Don't purify loc_g. It doesn't point at a code_vector, and purify_locref
3097     handles only code vectors.
3098   */
3099}
3100
3101void
3102purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3103{
3104  unsigned n = tcr->tlb_limit;
3105  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3106
3107  purify_range(start, end, low, high, to, what);
3108}
3109
3110void
3111purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3112{
3113  xframe_list *xframes;
3114  ExceptionInformation *xp;
3115 
3116  xp = tcr->gc_context;
3117  if (xp) {
3118    purify_xp(xp, low, high, to, what);
3119  }
3120
3121  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3122    purify_xp(xframes->curr, low, high, to, what);
3123  }
3124}
3125
3126void
3127purify_dohs(BytePtr low, BytePtr high, area *to, int what)
3128{
3129  doh_block_ptr doh_block = (doh_block_ptr) lisp_global(DOH_HEAD);
3130  while( doh_block ) {
3131    purify_range( &doh_block->data[0], &doh_block->data[doh_block_slots],
3132                 low, high, to, what );
3133    doh_block = doh_block->link;
3134  }
3135}
3136
3137void
3138purify_areas(BytePtr low, BytePtr high, area *target, int what)
3139{
3140  area *next_area;
3141  area_code code;
3142     
3143  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3144    switch (code) {
3145    case AREA_TSTACK:
3146      purify_tstack_area(next_area, low, high, target, what);
3147      break;
3148     
3149    case AREA_VSTACK:
3150      purify_vstack_area(next_area, low, high, target, what);
3151      break;
3152     
3153    case AREA_CSTACK:
3154      purify_cstack_area(next_area, low, high, target, what);
3155      break;
3156     
3157    case AREA_STATIC:
3158    case AREA_DYNAMIC:
3159      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what);
3160      break;
3161     
3162    default:
3163      break;
3164    }
3165  }
3166}
3167
3168/*
3169  So far, this is mostly for save_application's benefit.
3170  We -should- be able to return to lisp code after doing this,
3171  however.
3172
3173*/
3174
3175
3176int
3177purify(TCR *tcr)
3178{
3179  extern area *extend_readonly_area(unsigned);
3180  area
3181    *a = active_dynamic_area,
3182    *new_pure_area;
3183
3184  TCR  *other_tcr;
3185  unsigned max_pure_size;
3186  OSErr err;
3187  BytePtr new_pure_start;
3188
3189
3190  max_pure_size = unboxed_bytes_in_range((LispObj *)a->low, (LispObj *) a->active);
3191  new_pure_area = extend_readonly_area(max_pure_size);
3192  if (new_pure_area) {
3193    new_pure_start = new_pure_area->active;
3194    lisp_global(IN_GC) = (1<<fixnumshift);
3195
3196    /*
3197      First, loop thru *all-packages* and purify the pnames of all
3198      interned symbols.  Then walk every place that could reference
3199      a heap-allocated object (all_areas, the xframe_list) and
3200      purify code_vectors (and update the odd case of a shared
3201      reference to a pname.)
3202       
3203      Make the new_pure_area executable, just in case.
3204
3205      Caller will typically GC again (and that should recover quite a bit of
3206      the dynamic heap.)
3207      */
3208
3209    {
3210      lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
3211      LispObj pkg_list = rawsym->vcell, htab, obj;
3212      package *p;
3213      cons *c;
3214      unsigned elements, i;
3215
3216      while (fulltag_of(pkg_list) == fulltag_cons) {
3217        c = (cons *) untag(pkg_list);
3218        p = (package *) untag(c->car);
3219        pkg_list = c->cdr;
3220        c = (cons *) untag(p->itab);
3221        htab = c->car;
3222        elements = header_element_count(header_of(htab));
3223        for (i = 1; i<= elements; i++) {
3224          obj = deref(htab,i);
3225          if (fulltag_of(obj) == fulltag_misc) {
3226            rawsym = (lispsymbol *) untag(obj);
3227            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3228          }
3229        }
3230        c = (cons *) untag(p->etab);
3231        htab = c->car;
3232        elements = header_element_count(header_of(htab));
3233        for (i = 1; i<= elements; i++) {
3234          obj = deref(htab,i);
3235          if (fulltag_of(obj) == fulltag_misc) {
3236            rawsym = (lispsymbol *) untag(obj);
3237            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3238          }
3239        }
3240      }
3241    }
3242   
3243    purify_areas(a->low, a->active, new_pure_area, COPY_CODE);
3244   
3245    other_tcr = tcr;
3246    do {
3247      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, COPY_CODE);
3248      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, COPY_CODE);
3249      other_tcr = other_tcr->next;
3250    } while (other_tcr != tcr);
3251
3252    purify_dohs(a->low, a->active, new_pure_area, COPY_CODE);
3253
3254    {
3255      unsigned 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                                      12));
3264    lisp_global(IN_GC) = 0;
3265    just_purified_p = true;
3266    return 0;
3267  }
3268  return -1;
3269}
3270
3271void
3272impurify_locref(LispObj *p, LispObj low, LispObj high, int delta)
3273{
3274  LispObj q = *p;
3275 
3276  switch (fulltag_of(q)) {
3277  case fulltag_misc:
3278  case fulltag_even_fixnum:
3279  case fulltag_odd_fixnum:
3280    if ((q >= low) && (q < high)) {
3281      *p = (q+delta);
3282    }
3283  }
3284}
3285
3286 
3287void
3288impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
3289{
3290  LispObj q = *p;
3291 
3292  if ((fulltag_of(q) == fulltag_misc) &&
3293      (q >= low) && 
3294      (q < high)) {
3295    *p = (q+delta);
3296  }
3297}
3298 
3299
3300void
3301impurify_cstack_area(area *a, LispObj low, LispObj high, int delta)
3302{
3303  BytePtr
3304    current,
3305    next,
3306    limit = a->high;
3307
3308  for (current = a->active; current != limit; current = next) {
3309    next = *((BytePtr *)current);
3310    if (next == NULL) break;
3311    if (((next - current) == sizeof(lisp_frame)) && 
3312        (((((lisp_frame *)current)->savefn) == 0) ||
3313         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
3314      impurify_locref(&((lisp_frame *) current)->savelr, low, high, delta);
3315    } else {
3316      /* Clear low 2 bits of "next", just in case */
3317      next = (BytePtr) (((unsigned)next) & ~3);
3318    }
3319  }
3320}
3321
3322void
3323impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
3324{
3325  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
3326  int r;
3327
3328  /* registers >= fn should be treated as roots.
3329     The PC, LR, loc_pc, and CTR should be treated as "locatives".
3330   */
3331
3332  for (r = fn; r < 32; r++) {
3333    impurify_noderef((LispObj*) (&(regs[r])), low, high, delta);
3334  };
3335
3336  impurify_locref((LispObj*) (&(regs[loc_pc])), low, high, delta);
3337
3338  impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta);
3339  impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta);
3340  impurify_locref((LispObj*) (&(xpCTR(xp))), low, high, delta);
3341
3342}
3343
3344
3345void
3346impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3347{
3348  LispObj header;
3349  unsigned tag;
3350
3351  while (start < end) {
3352    header = *start;
3353    tag = fulltag_of(header);
3354    if (tag == fulltag_immheader) {
3355      start = (LispObj *)skip_over_ivector((unsigned)start, header);
3356    } else {
3357      if (tag != fulltag_nodeheader) {
3358        impurify_noderef(start, low, high, delta);
3359        }
3360      start++;
3361      impurify_noderef(start, low, high, delta);
3362      start++;
3363    }
3364  }
3365}
3366
3367
3368
3369
3370void
3371impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
3372{
3373  unsigned n = tcr->tlb_limit;
3374  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3375 
3376  impurify_range(start, end, low, high, delta);
3377}
3378
3379void
3380impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
3381{
3382  xframe_list *xframes;
3383  ExceptionInformation *xp;
3384 
3385  xp = tcr->gc_context;
3386  if (xp) {
3387    impurify_xp(xp, low, high, delta);
3388  }
3389
3390  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3391    impurify_xp(xframes->curr, low, high, delta);
3392  }
3393}
3394
3395void
3396impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
3397{
3398  LispObj
3399    *current,
3400    *next,
3401    *start = (LispObj *) (a->active),
3402    *end = start,
3403    *limit = (LispObj *) (a->high);
3404
3405  for (current = start;
3406       end != limit;
3407       current = next) {
3408    next = (LispObj *) *current;
3409    end = ((next >= start) && (next < limit)) ? next : limit;
3410    if (current[1] == 0) {
3411      impurify_range(current+2, end, low, high, delta);
3412    }
3413  }
3414}
3415void
3416impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
3417{
3418  LispObj
3419    *p = (LispObj *) a->active,
3420    *q = (LispObj *) a->high;
3421
3422  if (((unsigned)p) & 4) {
3423    impurify_noderef(p, low, high, delta);
3424    p++;
3425  }
3426  impurify_range(p, q, low, high, delta);
3427}
3428
3429
3430void
3431impurify_areas(LispObj low, LispObj high, int delta)
3432{
3433  area *next_area;
3434  area_code code;
3435     
3436  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3437    switch (code) {
3438    case AREA_TSTACK:
3439      impurify_tstack_area(next_area, low, high, delta);
3440      break;
3441     
3442    case AREA_VSTACK:
3443      impurify_vstack_area(next_area, low, high, delta);
3444      break;
3445     
3446    case AREA_CSTACK:
3447      impurify_cstack_area(next_area, low, high, delta);
3448      break;
3449     
3450    case AREA_STATIC:
3451    case AREA_DYNAMIC:
3452      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
3453      break;
3454     
3455    default:
3456      break;
3457    }
3458  }
3459}
3460
3461int
3462impurify(TCR *tcr)
3463{
3464  area *r = find_readonly_area();
3465
3466  if (r) {
3467    area *a = active_dynamic_area;
3468    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active;
3469    unsigned n = ro_limit - ro_base;
3470    int delta = oldfree-ro_base;
3471    TCR *other_tcr;
3472
3473    if (n) {
3474      lisp_global(IN_GC) = 1;
3475      resize_dynamic_heap(oldfree, n);
3476      a->active += n;
3477      bcopy(ro_base, oldfree, n);
3478      munmap(ro_base, n);
3479      a->ndwords = area_dword(a, a->active);
3480      pure_space_active = r->active = r->low;
3481      r->ndwords = 0;
3482
3483      impurify_areas((LispObj)ro_base, (LispObj)ro_limit, delta);
3484
3485      other_tcr = tcr;
3486      do {
3487        impurify_tcr_xframes(other_tcr, (LispObj)ro_base, (LispObj)ro_limit, delta);
3488        impurify_tcr_tlb(other_tcr, (LispObj)ro_base, (LispObj)ro_limit, delta);
3489        other_tcr = other_tcr->next;
3490      } while (other_tcr != tcr);
3491      lisp_global(IN_GC) = 0;
3492    }
3493    return 0;
3494  }
3495  return -1;
3496}
Note: See TracBrowser for help on using the repository browser.