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

Last change on this file since 557 was 557, checked in by gb, 15 years ago

PPC64 changes (some of them rather suspect ...). 32-bit kernel may be a
little funky ...

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