source: branches/working-0711/ccl/lisp-kernel/ppc-gc.c @ 13263

Last change on this file since 13263 was 13263, checked in by gz, 11 years ago

Changes in handling of weak vectors (i.e. populations and weak hash vectors) in ephemeral gc. Depending on how these changes affect performance in different use cases, it might be necessary to make them user-configurable, but for now I just made them unconditional.

  • all populations (including in particular all terminable populations) are processed at every gc. In normal use, population data has newest conses at the front, and processing will terminate as soon as it reaches a cons not in the area being gc'd, so in practice this will only process cells actually added in the current generation, which should limit the performance impact on ephemeral gc.
  • all weak hash vectors that have keys in ephemeral areas are processed at every gc. (Unfortunately, that means weak-on-value hash tables are NOT processed during egc).
  • egc always uses the :non-circular weak processing method for hash vectors. This means that certain kinds of cross-references between weak keys and values in weak hash tables will keep objects from being collected during ephemeral gc.

Details:

  • when marking memoized area, collect weak any hash tables on GCweakvll
  • add new global WEAKVLL to store weak populations between gc's
  • keep the gc-link field in weak vectors untagged (i.e. tagged as a fixnum), and forward them manually after compacting the heap, so that can forward them correctly regardless of area they're in
  • save WEAKVLL when image is saved
  • always use weak method 1 in egc
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 60.5 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lisp.h"
19#include "lisp_globals.h"
20#include "bits.h"
21#include "gc.h"
22#include "area.h"
23#include "Threads.h"
24#include <stddef.h>
25#include <stdlib.h>
26#include <string.h>
27#include <sys/time.h>
28
29/* Heap sanity checking. */
30
31void
32check_node(LispObj n)
33{
34  int tag = fulltag_of(n), header_tag;
35  area *a;
36  LispObj header;
37
38  switch (tag) {
39  case fulltag_even_fixnum:
40  case fulltag_odd_fixnum:
41
42
43#ifdef PPC64
44  case fulltag_imm_0:
45  case fulltag_imm_1:
46  case fulltag_imm_2:
47  case fulltag_imm_3:
48#else
49  case fulltag_imm:
50#endif
51
52
53    return;
54
55#ifndef PPC64
56  case fulltag_nil:
57    if (n != lisp_nil) {
58      Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n);
59    }
60    return;
61#endif
62
63
64#ifdef PPC64
65  case fulltag_nodeheader_0: 
66  case fulltag_nodeheader_1: 
67  case fulltag_nodeheader_2: 
68  case fulltag_nodeheader_3: 
69  case fulltag_immheader_0: 
70  case fulltag_immheader_1: 
71  case fulltag_immheader_2: 
72  case fulltag_immheader_3: 
73#else
74  case fulltag_nodeheader:
75  case fulltag_immheader:
76#endif
77
78
79    Bug(NULL, "Header not expected : 0x%lx", n);
80    return;
81
82  case fulltag_misc:
83  case fulltag_cons:
84    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
85   
86    if (a == NULL) {
87      /* Can't do as much sanity checking as we'd like to
88         if object is a defunct stack-consed object.
89         If a dangling reference to the heap, that's
90         bad .. */
91      a = active_dynamic_area;
92      if ((n > (ptr_to_lispobj(a->active))) &&
93          (n < (ptr_to_lispobj(a->high)))) {
94        Bug(NULL, "Node points to heap free space: 0x%lx", n);
95      }
96      return;
97    }
98    break;
99  }
100  /* Node points to heap area, so check header/lack thereof. */
101  header = header_of(n);
102  header_tag = fulltag_of(header);
103  if (tag == fulltag_cons) {
104    if ((nodeheader_tag_p(header_tag)) ||
105        (immheader_tag_p(header_tag))) {
106      Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header);
107    }
108    return;
109  }
110
111  if ((!nodeheader_tag_p(header_tag)) &&
112      (!immheader_tag_p(header_tag))) {
113    Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header);
114  }
115  return;
116}
117
118
119
120
121void
122check_range(LispObj *start, LispObj *end, Boolean header_allowed)
123{
124  LispObj node, *current = start, *prev = NULL;
125  int tag;
126  natural elements;
127
128  while (current < end) {
129    prev = current;
130    node = *current++;
131    tag = fulltag_of(node);
132    if (immheader_tag_p(tag)) {
133      if (! header_allowed) {
134        Bug(NULL, "Header not expected at 0x%lx\n", prev);
135      }
136      current = (LispObj *)skip_over_ivector((natural)prev, node);
137    } else if (nodeheader_tag_p(tag)) {
138      if (! header_allowed) {
139        Bug(NULL, "Header not expected at 0x%lx\n", prev);
140      }
141      elements = header_element_count(node) | 1;
142      while (elements--) {
143        check_node(*current++);
144      }
145    } else {
146      check_node(node);
147      check_node(*current++);
148    }
149  }
150
151  if (current != end) {
152    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
153        start, end, prev, current);
154  }
155}
156
157void
158check_all_areas(TCR *tcr)
159{
160  area *a = active_dynamic_area;
161  area_code code = a->code;
162
163  while (code != AREA_VOID) {
164    switch (code) {
165    case AREA_DYNAMIC:
166    case AREA_STATIC:
167    case AREA_MANAGED_STATIC:
168      check_range((LispObj *)a->low, (LispObj *)a->active, true);
169      break;
170
171    case AREA_VSTACK:
172      {
173        LispObj* low = (LispObj *)a->active;
174        LispObj* high = (LispObj *)a->high;
175       
176        if (((natural)low) & node_size) {
177          check_node(*low++);
178        }
179        check_range(low, high, false);
180      }
181      break;
182
183    case AREA_TSTACK:
184      {
185        LispObj *current, *next,
186                *start = (LispObj *) a->active,
187                *end = start,
188                *limit = (LispObj *) a->high;
189                 
190        for (current = start;
191             end != limit;
192             current = next) {
193          next = ptr_from_lispobj(*current);
194          end = ((next >= start) && (next < limit)) ? next : limit;
195          if (current[1] == 0) {
196            check_range(current+2, end, true);
197          }
198        }
199      }
200      break;
201    }
202    a = a->succ;
203    code = (a->code);
204  }
205}
206
207
208
209
210
211
212
213
214
215
216/* Sooner or later, this probably wants to be in assembler */
217/* Return false if n is definitely not an ephemeral node, true if
218   it might be */
219void
220mark_root(LispObj n)
221{
222  int tag_n = fulltag_of(n);
223  natural dnode, bits, *bitsp, mask;
224
225  if (!is_node_fulltag(tag_n)) {
226    return;
227  }
228
229  dnode = gc_area_dnode(n);
230  if (dnode >= GCndnodes_in_area) {
231    return;
232  }
233  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
234  if (bits & mask) {
235    return;
236  }
237  *bitsp = (bits | mask);
238
239  if (tag_n == fulltag_cons) {
240    cons *c = (cons *) ptr_from_lispobj(untag(n));
241    rmark(c->car);
242    rmark(c->cdr);
243    return;
244  }
245  {
246    LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
247    natural
248      header = *((natural *) base),
249      subtag = header_subtag(header),
250      element_count = header_element_count(header),
251      total_size_in_bytes,      /* including 4/8-byte header */
252      suffix_dnodes;
253    tag_n = fulltag_of(header);
254
255
256#ifdef PPC64
257    if ((nodeheader_tag_p(tag_n)) ||
258        (tag_n == ivector_class_64_bit)) {
259      total_size_in_bytes = 8 + (element_count<<3);
260    } else if (tag_n == ivector_class_8_bit) {
261      total_size_in_bytes = 8 + element_count;
262    } else if (tag_n == ivector_class_32_bit) {
263      total_size_in_bytes = 8 + (element_count<<2);
264    } else {
265      /* ivector_class_other_bit contains 16-bit arrays & bitvector */
266      if (subtag == subtag_bit_vector) {
267        total_size_in_bytes = 8 + ((element_count+7)>>3);
268      } else {
269        total_size_in_bytes = 8 + (element_count<<1);
270      }
271    }
272#else
273    if ((tag_n == fulltag_nodeheader) ||
274        (subtag <= max_32_bit_ivector_subtag)) {
275      total_size_in_bytes = 4 + (element_count<<2);
276    } else if (subtag <= max_8_bit_ivector_subtag) {
277      total_size_in_bytes = 4 + element_count;
278    } else if (subtag <= max_16_bit_ivector_subtag) {
279      total_size_in_bytes = 4 + (element_count<<1);
280    } else if (subtag == subtag_double_float_vector) {
281      total_size_in_bytes = 8 + (element_count<<3);
282    } else {
283      total_size_in_bytes = 4 + ((element_count+7)>>3);
284    }
285#endif
286
287
288
289    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1;
290
291    if (suffix_dnodes) {
292      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
293    }
294
295    if (nodeheader_tag_p(tag_n)) {
296      if (subtag == subtag_hash_vector) {
297        /* Don't invalidate the cache here.  It should get
298           invalidated on the lisp side, if/when we know
299           that rehashing is necessary. */
300        LispObj flags = ((hash_table_vector_header *) base)->flags;
301
302        if (flags & nhash_weak_mask) {
303          ((hash_table_vector_header *) base)->cache_key = undefined;
304          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
305          mark_weak_htabv(n);
306          return;
307        }
308      }
309
310      if (subtag == subtag_pool) {
311        deref(ptr_to_lispobj(base), 1) = lisp_nil;
312      }
313     
314      if (subtag == subtag_weak) {
315        natural weak_type = (natural) base[2];
316        if (weak_type >> population_termination_bit) {
317          element_count -= 2;
318        } else {
319          element_count -= 1;
320        }
321      }
322
323      base += (1+element_count);
324
325
326      while(element_count--) {
327        rmark(*--base);
328      }
329      if (subtag == subtag_weak) {
330        deref(n, 1) = GCweakvll;
331        GCweakvll = untag(n);
332      }
333    }
334  }
335}
336
337
338/*
339  This marks the node if it needs to; it returns true if the node
340  is either a hash table vector header or a cons/misc-tagged pointer
341  to ephemeral space.
342  Note that it  might be a pointer to ephemeral space even if it's
343  not pointing to the current generation.
344*/
345
346Boolean
347mark_ephemeral_root(LispObj n)
348{
349  int tag_n = fulltag_of(n);
350  natural eph_dnode;
351
352  if (nodeheader_tag_p(tag_n)) {
353    return (header_subtag(n) == subtag_hash_vector);
354  }
355 
356  if ((tag_n == fulltag_cons) ||
357      (tag_n == fulltag_misc)) {
358    eph_dnode = area_dnode(n, GCephemeral_low);
359    if (eph_dnode < GCn_ephemeral_dnodes) {
360      mark_root(n);             /* May or may not mark it */
361      return true;              /* but return true 'cause it's an ephemeral node */
362    }
363  }
364  return false;                 /* Not a heap pointer or not ephemeral */
365}
366 
367
368#ifdef PPC64
369/* Any register (srr0, the lr or ctr) or stack location that
370   we're calling this on should have its low 2 bits clear; it'll
371   be tagged as a "primary" object, but the pc/lr/ctr should
372   never point to a tagged object or contain a fixnum.
373   
374   If the "pc" appears to be pointing into a heap-allocated
375   code vector that's not yet marked, back up until we find
376   the code-vector's prefix (the 32-bit word containing the
377   value 'CODE' whic precedes the code-vector's first instruction)
378   and mark the entire code-vector.
379*/
380void
381mark_pc_root(LispObj xpc)
382{
383  if ((xpc & 3) != 0) {
384    Bug(NULL, "Bad PC locative!");
385  } else {
386    natural dnode = gc_area_dnode(xpc);
387    if ((dnode < GCndnodes_in_area) &&
388        !ref_bit(GCmarkbits,dnode)) {
389      LispObj
390        *headerP,
391        header;
392      opcode *program_counter;
393
394      for(program_counter=(opcode *)ptr_from_lispobj(xpc & ~7);
395          (LispObj)program_counter >= GCarealow;
396          program_counter-=2) {
397        if (*program_counter == PPC64_CODE_VECTOR_PREFIX) {
398          headerP = ((LispObj *)program_counter)-1;
399          header = *headerP;
400          dnode = gc_area_dnode(headerP);
401          set_n_bits(GCmarkbits, dnode, (8+(header_element_count(header)<<2)+(dnode_size-1))>>dnode_shift);
402          return;
403        }
404      }
405      /*
406        Expected to have found a header by now, but didn't.
407        That's a bug.
408        */
409      Bug(NULL, "code_vector header not found!");
410    }
411  }
412}
413#else /* PPC64 */
414/*
415  Some objects (saved LRs on the control stack, the LR, PC, and CTR
416  in exception frames) may be tagged as fixnums but are really
417  locatives into code_vectors.
418
419  If "pc" is not tagged as a fixnum, mark it as a "normal" root.
420  If "pc" doesn't point at an unmarked doubleword in the area
421  being GCed, return.
422  Else back up until the code_vector's header is found and mark
423  all doublewords in the code_vector.
424*/
425void
426mark_pc_root(LispObj pc)
427{
428  if (tag_of(pc) != tag_fixnum) {
429    mark_root(pc);
430  } else {
431    natural dnode = gc_area_dnode(pc);
432    if ((dnode < GCndnodes_in_area) &&
433        !ref_bit(GCmarkbits,dnode)) {
434      LispObj
435        *headerP,
436        header;
437
438      for(headerP = (LispObj*)ptr_from_lispobj(untag(pc));
439          dnode < GCndnodes_in_area;
440          headerP-=2, --dnode) {
441        header = *headerP;
442
443        if ((header & code_header_mask) == subtag_code_vector) {
444          set_n_bits(GCmarkbits, dnode, (2+header_element_count(header))>>1);
445          return;
446        }
447      }
448      /*
449        Expected to have found a header by now, but didn't.
450        That's a bug.
451        */
452      Bug(NULL, "code_vector header not found!");
453    }
454  }
455}
456#endif /* PPC64 */
457
458
459
460#ifdef PPC64
461#define RMARK_PREV_ROOT fulltag_imm_3
462#define RMARK_PREV_CAR fulltag_misc
463#else
464#define RMARK_PREV_ROOT fulltag_imm
465#define RMARK_PREV_CAR fulltag_nil
466#endif
467
468
469
470
471
472/*
473  This wants to be in assembler even more than "mark_root" does.
474  For now, it does link-inversion: hard as that is to express in C,
475  reliable stack-overflow detection may be even harder ...
476*/
477void
478rmark(LispObj n)
479{
480  int tag_n = fulltag_of(n);
481  bitvector markbits = GCmarkbits;
482  natural dnode, bits, *bitsp, mask;
483
484  if (!is_node_fulltag(tag_n)) {
485    return;
486  }
487
488  dnode = gc_area_dnode(n);
489  if (dnode >= GCndnodes_in_area) {
490    return;
491  }
492  set_bits_vars(markbits,dnode,bitsp,bits,mask);
493  if (bits & mask) {
494    return;
495  }
496  *bitsp = (bits | mask);
497
498  if (current_stack_pointer() > GCstack_limit) {
499    if (tag_n == fulltag_cons) {
500      rmark(deref(n,1));
501      rmark(deref(n,0));
502    } else {
503      LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
504      natural
505        header = *((natural *) base),
506        subtag = header_subtag(header),
507        element_count = header_element_count(header),
508        total_size_in_bytes,
509        suffix_dnodes;
510      tag_n = fulltag_of(header);
511#ifdef PPC64
512      if ((nodeheader_tag_p(tag_n)) ||
513          (tag_n == ivector_class_64_bit)) {
514        total_size_in_bytes = 8 + (element_count<<3);
515      } else if (tag_n == ivector_class_8_bit) {
516        total_size_in_bytes = 8 + element_count;
517      } else if (tag_n == ivector_class_32_bit) {
518        total_size_in_bytes = 8 + (element_count<<2);
519      } else {
520        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
521        if (subtag == subtag_bit_vector) {
522          total_size_in_bytes = 8 + ((element_count+7)>>3);
523        } else {
524          total_size_in_bytes = 8 + (element_count<<1);
525        }
526      }
527#else
528      if ((tag_n == fulltag_nodeheader) ||
529          (subtag <= max_32_bit_ivector_subtag)) {
530        total_size_in_bytes = 4 + (element_count<<2);
531      } else if (subtag <= max_8_bit_ivector_subtag) {
532        total_size_in_bytes = 4 + element_count;
533      } else if (subtag <= max_16_bit_ivector_subtag) {
534        total_size_in_bytes = 4 + (element_count<<1);
535      } else if (subtag == subtag_double_float_vector) {
536        total_size_in_bytes = 8 + (element_count<<3);
537      } else {
538        total_size_in_bytes = 4 + ((element_count+7)>>3);
539      }
540#endif
541
542
543      suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
544
545      if (suffix_dnodes) {
546        set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
547      }
548
549      if (!nodeheader_tag_p(tag_n)) return;
550
551      if (subtag == subtag_hash_vector) {
552        /* Splice onto weakvll, then return */
553        /* In general, there's no reason to invalidate the cached
554           key/value pair here.  However, if the hash table's weak,
555           we don't want to retain an otherwise unreferenced key
556           or value simply because they're referenced from the
557           cache.  Clear the cached entries iff the hash table's
558           weak in some sense.
559        */
560        LispObj flags = ((hash_table_vector_header *) base)->flags;
561
562        if ((flags & nhash_keys_frozen_mask) &&
563            (((hash_table_vector_header *) base)->deleted_count > 0)) {
564          /* We're responsible for clearing out any deleted keys, since
565             lisp side can't do it without breaking the state machine
566          */
567          LispObj *pairp = base + hash_table_vector_header_count;
568          natural
569            npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1;
570
571          while (npairs--) {
572            if ((pairp[1] == unbound) && (pairp[0] != unbound)) {
573              pairp[0] = slot_unbound;
574            }
575            pairp +=2;
576          }
577          ((hash_table_vector_header *) base)->deleted_count = 0;
578        }
579
580
581        if (flags & nhash_weak_mask) {
582          ((hash_table_vector_header *) base)->cache_key = undefined;
583          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
584          mark_weak_htabv(n);
585          return;
586        }
587      }
588
589      if (subtag == subtag_pool) {
590        deref(n, 1) = lisp_nil;
591      }
592
593      if (subtag == subtag_weak) {
594        natural weak_type = (natural) base[2];
595        if (weak_type >> population_termination_bit)
596          element_count -= 2;
597        else
598          element_count -= 1;
599      }
600      while (element_count) {
601        rmark(deref(n,element_count));
602        element_count--;
603      }
604
605      if (subtag == subtag_weak) {
606        deref(n, 1) = GCweakvll;
607        GCweakvll = untag(n);
608      }
609
610    }
611  } else {
612    LispObj prev = undefined;
613    LispObj this = n, next;
614    /*
615      This is an FSM.  The basic states are:
616      (0) Just marked the cdr of a cons; mark the car next;
617      (1) Just marked the car of a cons; back up.
618      (2) Hit a gvector header.  Back up.
619      (3) Marked a gvector element; mark the preceding one.
620      (4) Backed all the way up to the object that got us here.
621     
622      This is all encoded in the fulltag of the "prev" pointer.
623    */
624
625    if (tag_n == fulltag_cons) goto MarkCons;
626    goto MarkVector;
627
628  ClimbCdr:
629    prev = deref(this,0);
630    deref(this,0) = next;
631
632  Climb:
633    next = this;
634    this = prev;
635    tag_n = fulltag_of(prev);
636    switch(tag_n) {
637    case fulltag_odd_fixnum:
638    case fulltag_even_fixnum:
639      goto ClimbVector;
640
641    case RMARK_PREV_ROOT:
642      return;
643
644    case fulltag_cons:
645      goto ClimbCdr;
646
647    case RMARK_PREV_CAR:
648      goto ClimbCar;
649
650      /* default: abort() */
651    }
652
653  DescendCons:
654    prev = this;
655    this = next;
656
657  MarkCons:
658    next = deref(this,1);
659    this += node_size;
660    tag_n = fulltag_of(next);
661    if (!is_node_fulltag(tag_n)) goto MarkCdr;
662    dnode = gc_area_dnode(next);
663    if (dnode >= GCndnodes_in_area) goto MarkCdr;
664    set_bits_vars(markbits,dnode,bitsp,bits,mask);
665    if (bits & mask) goto MarkCdr;
666    *bitsp = (bits | mask);
667    deref(this,1) = prev;
668    if (tag_n == fulltag_cons) goto DescendCons;
669    goto DescendVector;
670
671  ClimbCar:
672    prev = deref(this,1);
673    deref(this,1) = next;
674
675  MarkCdr:
676    next = deref(this, 0);
677    this -= node_size;
678    tag_n = fulltag_of(next);
679    if (!is_node_fulltag(tag_n)) goto Climb;
680    dnode = gc_area_dnode(next);
681    if (dnode >= GCndnodes_in_area) goto Climb;
682    set_bits_vars(markbits,dnode,bitsp,bits,mask);
683    if (bits & mask) goto Climb;
684    *bitsp = (bits | mask);
685    deref(this, 0) = prev;
686    if (tag_n == fulltag_cons) goto DescendCons;
687    /* goto DescendVector; */
688
689  DescendVector:
690    prev = this;
691    this = next;
692
693  MarkVector:
694    {
695      LispObj *base = (LispObj *) ptr_from_lispobj(untag(this));
696      natural
697        header = *((natural *) base),
698        subtag = header_subtag(header),
699        element_count = header_element_count(header),
700        total_size_in_bytes,
701        suffix_dnodes;
702
703      tag_n = fulltag_of(header);
704
705#ifdef PPC64
706      if ((nodeheader_tag_p(tag_n)) ||
707          (tag_n == ivector_class_64_bit)) {
708        total_size_in_bytes = 8 + (element_count<<3);
709      } else if (tag_n == ivector_class_8_bit) {
710        total_size_in_bytes = 8 + element_count;
711      } else if (tag_n == ivector_class_32_bit) {
712        total_size_in_bytes = 8 + (element_count<<2);
713      } else {
714        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
715        if (subtag == subtag_bit_vector) {
716          total_size_in_bytes = 8 + ((element_count+7)>>3);
717        } else {
718          total_size_in_bytes = 8 + (element_count<<1);
719        }
720      }
721#else
722      if ((tag_n == fulltag_nodeheader) ||
723          (subtag <= max_32_bit_ivector_subtag)) {
724        total_size_in_bytes = 4 + (element_count<<2);
725      } else if (subtag <= max_8_bit_ivector_subtag) {
726        total_size_in_bytes = 4 + element_count;
727      } else if (subtag <= max_16_bit_ivector_subtag) {
728        total_size_in_bytes = 4 + (element_count<<1);
729      } else if (subtag == subtag_double_float_vector) {
730        total_size_in_bytes = 8 + (element_count<<3);
731      } else {
732        total_size_in_bytes = 4 + ((element_count+7)>>3);
733      }
734#endif
735
736
737      suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
738
739      if (suffix_dnodes) {
740        set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
741      }
742
743      if (!nodeheader_tag_p(tag_n)) goto Climb;
744
745      if (subtag == subtag_hash_vector) {
746        /* Splice onto weakvll, then climb */
747        LispObj flags = ((hash_table_vector_header *) base)->flags;
748
749        if (flags & nhash_weak_mask) {
750          ((hash_table_vector_header *) base)->cache_key = undefined;
751          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
752          dws_mark_weak_htabv(this);
753          element_count = hash_table_vector_header_count;
754        }
755      }
756
757      if (subtag == subtag_pool) {
758        deref(this, 1) = lisp_nil;
759      }
760
761      if (subtag == subtag_weak) {
762        natural weak_type = (natural) base[2];
763        if (weak_type >> population_termination_bit)
764          element_count -= 2;
765        else
766          element_count -= 1;
767      }
768
769      this = untag(this) + ((element_count+1) << node_shift);
770      goto MarkVectorLoop;
771    }
772
773  ClimbVector:
774    prev = *((LispObj *) ptr_from_lispobj(this));
775    *((LispObj *) ptr_from_lispobj(this)) = next;
776
777  MarkVectorLoop:
778    this -= node_size;
779    next = *((LispObj *) ptr_from_lispobj(this));
780    tag_n = fulltag_of(next);
781    if (nodeheader_tag_p(tag_n)) goto MarkVectorDone;
782    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
783    dnode = gc_area_dnode(next);
784    if (dnode >= GCndnodes_in_area) goto MarkVectorLoop;
785    set_bits_vars(markbits,dnode,bitsp,bits,mask);
786    if (bits & mask) goto MarkVectorLoop;
787    *bitsp = (bits | mask);
788    *(ptr_from_lispobj(this)) = prev;
789    if (tag_n == fulltag_cons) goto DescendCons;
790    goto DescendVector;
791
792  MarkVectorDone:
793    /* "next" is vector header; "this" is fixnum-aligned.
794       If  header subtag = subtag_weak_header, put it on weakvll */
795    this += fulltag_misc;
796
797    if (header_subtag(next) == subtag_weak) {
798      deref(this, 1) = GCweakvll;
799      GCweakvll = untag(this);
800    }
801    goto Climb;
802  }
803}
804
805LispObj *
806skip_over_ivector(natural start, LispObj header)
807{
808  natural
809    element_count = header_element_count(header),
810    subtag = header_subtag(header),
811    nbytes;
812
813#ifdef PPC64
814  switch (fulltag_of(header)) {
815  case ivector_class_64_bit:
816    nbytes = element_count << 3;
817    break;
818  case ivector_class_32_bit:
819    nbytes = element_count << 2;
820    break;
821  case ivector_class_8_bit:
822    nbytes = element_count;
823    break;
824  case ivector_class_other_bit:
825  default:
826    if (subtag == subtag_bit_vector) {
827      nbytes = (element_count+7)>>3;
828    } else {
829      nbytes = element_count << 1;
830    }
831  }
832  return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15)));
833#else
834  if (subtag <= max_32_bit_ivector_subtag) {
835    nbytes = element_count << 2;
836  } else if (subtag <= max_8_bit_ivector_subtag) {
837    nbytes = element_count;
838  } else if (subtag <= max_16_bit_ivector_subtag) {
839    nbytes = element_count << 1;
840  } else if (subtag == subtag_double_float_vector) {
841    nbytes = 4 + (element_count << 3);
842  } else {
843    nbytes = (element_count+7) >> 3;
844  }
845  return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7)));
846#endif
847
848
849
850}
851
852
853void
854check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
855{
856  LispObj x1, *base = start;
857  int tag;
858  natural ref_dnode, node_dnode;
859  Boolean intergen_ref;
860
861  while (start < end) {
862    x1 = *start;
863    tag = fulltag_of(x1);
864    if (immheader_tag_p(tag)) {
865      start = skip_over_ivector(ptr_to_lispobj(start), x1);
866    } else {
867      intergen_ref = false;
868      if ((tag == fulltag_misc) || (tag == fulltag_cons)) {       
869        node_dnode = gc_area_dnode(x1);
870        if (node_dnode < GCndnodes_in_area) {
871          intergen_ref = true;
872        }
873      }
874      if (intergen_ref == false) {       
875        x1 = start[1];
876        tag = fulltag_of(x1);
877        if ((tag == fulltag_misc) || (tag == fulltag_cons)) {
878          node_dnode = gc_area_dnode(x1);
879          if (node_dnode < GCndnodes_in_area) {
880            intergen_ref = true;
881          }
882        }
883      }
884      if (intergen_ref) {
885        ref_dnode = area_dnode(start, base);
886        if (!ref_bit(refbits, ref_dnode)) {
887          Bug(NULL, "Missing memoization in doublenode at 0x%08X", start);
888          set_bit(refbits, ref_dnode);
889        }
890      }
891      start += 2;
892    }
893  }
894}
895
896
897
898void
899mark_memoized_area(area *a, natural num_memo_dnodes)
900{
901  bitvector refbits = a->refbits;
902  LispObj *p = (LispObj *) a->low, x1, x2;
903  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
904  Boolean keep_x1, keep_x2;
905
906  if (GCDebug) {
907    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
908  }
909
910  /* The distinction between "inbits" and "outbits" is supposed to help us
911     detect cases where "uninteresting" setfs have been memoized.  Storing
912     NIL, fixnums, immediates (characters, etc.) or node pointers to static
913     or readonly areas is definitely uninteresting, but other cases are
914     more complicated (and some of these cases are hard to detect.)
915
916     Some headers are "interesting", to the forwarder if not to us.
917
918     We -don't- give anything any weak treatment here.  Weak things have
919     to be seen by a full gc, for some value of 'full'.
920     */
921
922  /*
923    We need to ensure that there are no bits set at or beyond
924    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
925    tenures/untenures things.)  We find bits by grabbing a fullword at
926    a time and doing a cntlzw instruction; and don't want to have to
927    check for (< memo_dnode num_memo_dnodes) in the loop.
928    */
929
930  {
931    natural
932      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
933      index_of_last_word = (num_memo_dnodes >> bitmap_shift);
934
935    if (bits_in_last_word != 0) {
936      natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L);
937      refbits[index_of_last_word] &= mask;
938    }
939  }
940       
941  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
942  inbits = outbits = bits;
943  while (memo_dnode < num_memo_dnodes) {
944    if (bits == 0) {
945      int remain = nbits_in_word - bitidx;
946      memo_dnode += remain;
947      p += (remain+remain);
948      if (outbits != inbits) {
949        *bitsp = outbits;
950      }
951      bits = *++bitsp;
952      inbits = outbits = bits;
953      bitidx = 0;
954    } else {
955      nextbit = count_leading_zeros(bits);
956      if ((diff = (nextbit - bitidx)) != 0) {
957        memo_dnode += diff;
958        bitidx = nextbit;
959        p += (diff+diff);
960      }
961      x1 = *p++;
962      x2 = *p++;
963      bits &= ~(BIT0_MASK >> bitidx);
964
965      if (header_subtag(x1) == subtag_hash_vector) {
966        LispObj flags = ((hash_table_vector_header *) p-2)->flags;
967        if (flags & nhash_weak_mask) {
968          *(p-1) = GCweakvll;
969          GCweakvll = ptr_to_lispobj(p - 1);
970          x2 = 0;
971        }
972      }
973
974      keep_x1 = mark_ephemeral_root(x1);
975      keep_x2 = mark_ephemeral_root(x2);
976      if ((keep_x1 == false) && 
977          (keep_x2 == false)) {
978        outbits &= ~(BIT0_MASK >> bitidx);
979      }
980      memo_dnode++;
981      bitidx++;
982    }
983  }
984  if (GCDebug) {
985    p = (LispObj *) a->low;
986    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
987  }
988}
989
990
991
992void
993mark_simple_area_range(LispObj *start, LispObj *end)
994{
995  LispObj x1, *base;
996  int tag;
997
998  while (start < end) {
999    x1 = *start;
1000    tag = fulltag_of(x1);
1001    if (immheader_tag_p(tag)) {
1002      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
1003    } else if (!nodeheader_tag_p(tag)) {
1004      ++start;
1005      mark_root(x1);
1006      mark_root(*start++);
1007    } else {
1008      int subtag = header_subtag(x1);
1009      natural element_count = header_element_count(x1);
1010      natural size = (element_count+1 + 1) & ~1;
1011
1012      if (subtag == subtag_hash_vector) {
1013        LispObj flags = ((hash_table_vector_header *) start)->flags;
1014
1015        if (flags & nhash_weak_mask) {
1016          ((hash_table_vector_header *) start)->cache_key = undefined;
1017          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1018          mark_weak_htabv((LispObj)start);
1019          element_count = 0;
1020        }
1021      }
1022      if (subtag == subtag_pool) {
1023        start[1] = lisp_nil;
1024      }
1025
1026      if (subtag == subtag_weak) {
1027        natural weak_type = (natural) start[2];
1028        if (weak_type >> population_termination_bit)
1029          element_count -= 2;
1030        else
1031          element_count -= 1; 
1032        start[1] = GCweakvll;
1033        GCweakvll = ptr_to_lispobj(start);
1034      }
1035
1036      base = start + element_count + 1;
1037      while(element_count--) {
1038        mark_root(*--base);
1039      }   
1040      start += size;
1041    }
1042  }
1043}
1044
1045
1046/* Mark a tstack area */
1047void
1048mark_tstack_area(area *a)
1049{
1050  LispObj
1051    *current,
1052    *next,
1053    *start = (LispObj *) (a->active),
1054    *end = start,
1055    *limit = (LispObj *) (a->high);
1056
1057  for (current = start;
1058       end != limit;
1059       current = next) {
1060    next = (LispObj *) ptr_from_lispobj(*current);
1061    end = ((next >= start) && (next < limit)) ? next : limit;
1062    if (current[1] == 0) {
1063      mark_simple_area_range(current+2, end);
1064    }
1065  }
1066}
1067
1068/*
1069  It's really important that headers never wind up in tagged registers.
1070  Those registers would (possibly) get pushed on the vstack and confuse
1071  the hell out of this routine.
1072
1073  vstacks are just treated as a "simple area range", possibly with
1074  an extra word at the top (where the area's active pointer points.)
1075  */
1076
1077void
1078mark_vstack_area(area *a)
1079{
1080  LispObj
1081    *start = (LispObj *) a->active,
1082    *end = (LispObj *) a->high;
1083
1084#if 0
1085  fprintf(dbgout, "mark VSP range: 0x%lx:0x%lx\n", start, end);
1086#endif
1087  if (((natural)start) & (sizeof(natural))) {
1088    /* Odd number of words.  Mark the first (can't be a header) */
1089    mark_root(*start);
1090    ++start;
1091  }
1092  mark_simple_area_range(start, end);
1093}
1094
1095
1096/*
1097  Mark lisp frames on the control stack.
1098  Ignore emulator frames (odd backpointer) and C frames (size != 4).
1099*/
1100
1101void
1102mark_cstack_area(area *a)
1103{
1104  BytePtr
1105    current,
1106    next,
1107    limit = a->high,
1108    low = a->low;
1109
1110  for (current = a->active; (current >= low) && (current < limit); current = next) {
1111    next = *((BytePtr *)current);
1112#if 0
1113    if (next < current) {
1114      Bug(NULL, "Child stack frame older than parent");
1115    }
1116#endif
1117    if (next == NULL) break;
1118    if (((next - current) == sizeof(lisp_frame)) &&
1119        (((((lisp_frame *)current)->savefn) == 0) ||
1120         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
1121      /* mark fn, then saved lr */
1122      mark_root(((lisp_frame *)current)->savefn);
1123      mark_pc_root(((lisp_frame *)current)->savelr);
1124    } else {
1125      /* Clear low 2 bits of "next", just in case */
1126      next = (BytePtr) (((natural)next) & ~3);
1127    }
1128  }
1129}
1130
1131
1132
1133/* Mark the lisp objects in an exception frame */
1134void
1135mark_xp(ExceptionInformation *xp)
1136{
1137  natural *regs = (natural *) xpGPRvector(xp);
1138
1139#ifdef PPC
1140  int r;
1141  /* registers >= fn should be tagged and marked as roots.
1142     the PC, LR, loc_pc, and CTR should be treated as "pc_locatives".
1143
1144     In general, marking a locative is more expensive than marking
1145     a node is, since it may be neccessary to back up and find the
1146     containing object's header.  Since exception frames contain
1147     many locatives, it'd be wise to mark them *after* marking the
1148     stacks, nilreg-relative globals, etc.
1149     */
1150
1151  for (r = fn; r < 32; r++) {
1152    mark_root((regs[r]));
1153  }
1154
1155
1156
1157  mark_pc_root((regs[loc_pc]));
1158  mark_pc_root(ptr_to_lispobj(xpPC(xp)));
1159  mark_pc_root(ptr_to_lispobj(xpLR(xp)));
1160  mark_pc_root(ptr_to_lispobj(xpCTR(xp)));
1161#endif /* PPC */
1162
1163}
1164
1165/* A "pagelet" contains 32 doublewords.  The relocation table contains
1166   a word for each pagelet which defines the lowest address to which
1167   dnodes on that pagelet will be relocated.
1168
1169   The relocation address of a given pagelet is the sum of the relocation
1170   address for the preceding pagelet and the number of bytes occupied by
1171   marked objects on the preceding pagelet.
1172*/
1173
1174LispObj
1175calculate_relocation()
1176{
1177  LispObj *relocptr = GCrelocptr;
1178  LispObj current = GCareadynamiclow;
1179  bitvector
1180    markbits = GCdynamic_markbits;
1181  qnode *q = (qnode *) markbits;
1182  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1183  natural thesebits;
1184  LispObj first = 0;
1185
1186  do {
1187    *relocptr++ = current;
1188    thesebits = *markbits++;
1189    if (thesebits == ALL_ONES) {
1190      current += nbits_in_word*dnode_size;
1191      q += 4; /* sic */
1192    } else {
1193      if (!first) {
1194        first = current;
1195        while (thesebits & BIT0_MASK) {
1196          first += dnode_size;
1197          thesebits += thesebits;
1198        }
1199      }
1200      current += one_bits(*q++);
1201      current += one_bits(*q++);
1202      current += one_bits(*q++);
1203      current += one_bits(*q++);
1204    }
1205  } while(--npagelets);
1206  *relocptr++ = current;
1207  return first ? first : current;
1208}
1209
1210#ifdef PPC64
1211LispObj
1212dnode_forwarding_address(natural dnode, int tag_n)
1213{
1214  natural pagelet, nbits;
1215  unsigned int near_bits;
1216  LispObj new;
1217
1218  if (GCDebug) {
1219    if (! ref_bit(GCdynamic_markbits, dnode)) {
1220      Bug(NULL, "unmarked object being forwarded!\n");
1221    }
1222  }
1223
1224  pagelet = dnode >> bitmap_shift;
1225  nbits = dnode & bitmap_shift_count_mask;
1226  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
1227
1228  if (nbits < 32) {
1229    new = GCrelocptr[pagelet] + tag_n;;
1230    /* Increment "new" by the count of 1 bits which precede the dnode */
1231    if (near_bits == 0xffffffff) {
1232      return (new + (nbits << 4));
1233    } else {
1234      near_bits &= (0xffffffff00000000 >> nbits);
1235      if (nbits > 15) {
1236        new += one_bits(near_bits & 0xffff);
1237      }
1238      return (new + (one_bits(near_bits >> 16))); 
1239    }
1240  } else {
1241    new = GCrelocptr[pagelet+1] + tag_n;
1242    nbits = 64-nbits;
1243
1244    if (near_bits == 0xffffffff) {
1245      return (new - (nbits << 4));
1246    } else {
1247      near_bits &= (1<<nbits)-1;
1248      if (nbits > 15) {
1249        new -= one_bits(near_bits >> 16);
1250      }
1251      return (new -  one_bits(near_bits & 0xffff));
1252    }
1253  }
1254}
1255#else
1256LispObj
1257dnode_forwarding_address(natural dnode, int tag_n)
1258{
1259  natural pagelet, nbits;
1260  unsigned short near_bits;
1261  LispObj new;
1262
1263  if (GCDebug) {
1264    if (! ref_bit(GCdynamic_markbits, dnode)) {
1265      Bug(NULL, "unmarked object being forwarded!\n");
1266    }
1267  }
1268
1269  pagelet = dnode >> 5;
1270  nbits = dnode & 0x1f;
1271  near_bits = ((unsigned short *)GCdynamic_markbits)[dnode>>4];
1272
1273  if (nbits < 16) {
1274    new = GCrelocptr[pagelet] + tag_n;;
1275    /* Increment "new" by the count of 1 bits which precede the dnode */
1276    if (near_bits == 0xffff) {
1277      return (new + (nbits << 3));
1278    } else {
1279      near_bits &= (0xffff0000 >> nbits);
1280      if (nbits > 7) {
1281        new += one_bits(near_bits & 0xff);
1282      }
1283      return (new + (one_bits(near_bits >> 8))); 
1284    }
1285  } else {
1286    new = GCrelocptr[pagelet+1] + tag_n;
1287    nbits = 32-nbits;
1288
1289    if (near_bits == 0xffff) {
1290      return (new - (nbits << 3));
1291    } else {
1292      near_bits &= (1<<nbits)-1;
1293      if (nbits > 7) {
1294        new -= one_bits(near_bits >> 8);
1295      }
1296      return (new -  one_bits(near_bits & 0xff));
1297    }
1298  }
1299}
1300#endif
1301
1302
1303LispObj
1304locative_forwarding_address(LispObj obj)
1305{
1306  int tag_n = fulltag_of(obj);
1307  natural dnode;
1308
1309
1310#ifdef PPC
1311  /* Locatives can be tagged as conses, "fulltag_misc"
1312     objects, or as fixnums.  Immediates, headers, and nil
1313     shouldn't be "forwarded".  Nil never will be, but it
1314     doesn't hurt to check ... */
1315#ifdef PPC64
1316  if ((tag_n & lowtag_mask) != lowtag_primary) {
1317    return obj;
1318  }
1319#else
1320  if ((1<<tag_n) & ((1<<fulltag_immheader) |
1321                    (1<<fulltag_nodeheader) |
1322                    (1<<fulltag_imm) |
1323                    (1<<fulltag_nil))) {
1324    return obj;
1325  }
1326#endif
1327#endif
1328
1329  dnode = gc_dynamic_area_dnode(obj);
1330
1331  if ((dnode >= GCndynamic_dnodes_in_area) ||
1332      (obj < GCfirstunmarked)) {
1333    return obj;
1334  }
1335
1336  return dnode_forwarding_address(dnode, tag_n);
1337}
1338
1339
1340
1341
1342void
1343forward_range(LispObj *range_start, LispObj *range_end)
1344{
1345  LispObj *p = range_start, node, new;
1346  int tag_n;
1347  natural nwords;
1348  hash_table_vector_header *hashp;
1349
1350  while (p < range_end) {
1351    node = *p;
1352    tag_n = fulltag_of(node);
1353    if (immheader_tag_p(tag_n)) {
1354      p = (LispObj *) skip_over_ivector((natural) p, node);
1355    } else if (nodeheader_tag_p(tag_n)) {
1356      nwords = header_element_count(node);
1357      nwords += (1 - (nwords&1));
1358      if ((header_subtag(node) == subtag_hash_vector) &&
1359          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1360        natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1361        hashp = (hash_table_vector_header *) p;
1362        p++;
1363        nwords -= skip;
1364        while(skip--) {
1365          update_noderef(p);
1366          p++;
1367        }
1368        /* "nwords" is odd at this point: there are (floor nwords 2)
1369           key/value pairs to look at, and then an extra word for
1370           alignment.  Process them two at a time, then bump "p"
1371           past the alignment word. */
1372        nwords >>= 1;
1373        while(nwords--) {
1374          if (update_noderef(p) && hashp) {
1375            hashp->flags |= nhash_key_moved_mask;
1376            hashp = NULL;
1377          }
1378          p++;
1379          update_noderef(p);
1380          p++;
1381        }
1382        *p++ = 0;
1383      } else {
1384        p++;
1385        while(nwords--) {
1386          update_noderef(p);
1387          p++;
1388        }
1389      }
1390    } else {
1391      new = node_forwarding_address(node);
1392      if (new != node) {
1393        *p = new;
1394      }
1395      p++;
1396      update_noderef(p);
1397      p++;
1398    }
1399  }
1400}
1401
1402
1403
1404
1405/* Forward a tstack area */
1406void
1407forward_tstack_area(area *a)
1408{
1409  LispObj
1410    *current,
1411    *next,
1412    *start = (LispObj *) a->active,
1413    *end = start,
1414    *limit = (LispObj *) (a->high);
1415
1416  for (current = start;
1417       end != limit;
1418       current = next) {
1419    next = ptr_from_lispobj(*current);
1420    end = ((next >= start) && (next < limit)) ? next : limit;
1421    if (current[1] == 0) {
1422      forward_range(current+2, end);
1423    }
1424  }
1425}
1426
1427/* Forward a vstack area */
1428void
1429forward_vstack_area(area *a)
1430{
1431  LispObj
1432    *p = (LispObj *) a->active,
1433    *q = (LispObj *) a->high;
1434
1435#ifdef DEBUG
1436  fprintf(dbgout,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner);
1437#endif
1438  if (((natural)p) & sizeof(natural)) {
1439    update_noderef(p);
1440    p++;
1441  }
1442  forward_range(p, q);
1443}
1444
1445void
1446forward_cstack_area(area *a)
1447{
1448  BytePtr
1449    current,
1450    next,
1451    limit = a->high,
1452    low = a->low;
1453
1454  for (current = a->active; (current >= low) && (current < limit); current = next) {
1455    next = *((BytePtr *)current);
1456    if (next == NULL) break;
1457    if (((next - current) == sizeof(lisp_frame)) &&
1458        (((((lisp_frame *)current)->savefn) == 0) ||
1459         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
1460      update_noderef(&((lisp_frame *) current)->savefn);
1461      update_locref(&((lisp_frame *) current)->savelr);
1462    }
1463  }
1464}
1465
1466
1467
1468void
1469forward_xp(ExceptionInformation *xp)
1470{
1471  natural *regs = (natural *) xpGPRvector(xp);
1472
1473  int r;
1474
1475  /* registers >= fn should be tagged and forwarded as roots.
1476     the PC, LR, loc_pc, and CTR should be treated as "locatives".
1477     */
1478
1479  for (r = fn; r < 32; r++) {
1480    update_noderef((LispObj*) (&(regs[r])));
1481  }
1482
1483  update_locref((LispObj*) (&(regs[loc_pc])));
1484
1485  update_locref((LispObj*) (&(xpPC(xp))));
1486  update_locref((LispObj*) (&(xpLR(xp))));
1487  update_locref((LispObj*) (&(xpCTR(xp))));
1488
1489}
1490
1491
1492void
1493forward_tcr_xframes(TCR *tcr)
1494{
1495  xframe_list *xframes;
1496  ExceptionInformation *xp;
1497
1498  xp = tcr->gc_context;
1499  if (xp) {
1500    forward_xp(xp);
1501  }
1502  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1503    if (xframes->curr == xp) {
1504      Bug(NULL, "forward xframe twice ???");
1505    }
1506    forward_xp(xframes->curr);
1507  }
1508}
1509
1510
1511
1512/*
1513  Compact the dynamic heap (from GCfirstunmarked through its end.)
1514  Return the doublenode address of the new freeptr.
1515  */
1516
1517LispObj
1518compact_dynamic_heap()
1519{
1520  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new;
1521  natural
1522    elements, 
1523    dnode = gc_area_dnode(GCfirstunmarked), 
1524    node_dnodes = 0, 
1525    imm_dnodes = 0, 
1526    bitidx, 
1527    *bitsp, 
1528    bits, 
1529    nextbit, 
1530    diff;
1531  int tag;
1532  bitvector markbits = GCmarkbits;
1533    /* keep track of whether or not we saw any
1534       code_vector headers, and only flush cache if so. */
1535  Boolean GCrelocated_code_vector = false;
1536
1537  if (dnode < GCndnodes_in_area) {
1538    lisp_global(FWDNUM) += (1<<fixnum_shift);
1539 
1540    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1541    while (dnode < GCndnodes_in_area) {
1542      if (bits == 0) {
1543        int remain = nbits_in_word - bitidx;
1544        dnode += remain;
1545        src += (remain+remain);
1546        bits = *++bitsp;
1547        bitidx = 0;
1548      } else {
1549        /* Have a non-zero markbits word; all bits more significant
1550           than "bitidx" are 0.  Count leading zeros in "bits"
1551           (there'll be at least "bitidx" of them.)  If there are more
1552           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1553           "src" by the difference. */
1554        nextbit = count_leading_zeros(bits);
1555        if ((diff = (nextbit - bitidx)) != 0) {
1556          dnode += diff;
1557          bitidx = nextbit;
1558          src += (diff+diff);
1559        }
1560
1561        if (GCDebug) {
1562          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1563            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1564                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1565          }
1566        }
1567
1568        node = *src++;
1569        tag = fulltag_of(node);
1570        if (nodeheader_tag_p(tag)) {
1571          elements = header_element_count(node);
1572          node_dnodes = (elements+2)>>1;
1573          dnode += node_dnodes;
1574          if ((header_subtag(node) == subtag_hash_vector) &&
1575              (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1576            hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1577            int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1578         
1579            *dest++ = node;
1580            elements -= skip;
1581            while(skip--) {
1582              *dest++ = node_forwarding_address(*src++);
1583            }
1584            /* There should be an even number of (key/value) pairs in elements;
1585               an extra alignment word follows. */
1586            elements >>= 1;
1587            while (elements--) {
1588              if (hashp) {
1589                node = *src++;
1590                new = node_forwarding_address(node);
1591                if (new != node) {
1592                  hashp->flags |= nhash_key_moved_mask;
1593                  hashp = NULL;
1594                  *dest++ = new;
1595                } else {
1596                  *dest++ = node;
1597                }
1598              } else {
1599                *dest++ = node_forwarding_address(*src++);
1600              }
1601              *dest++ = node_forwarding_address(*src++);
1602            }
1603            *dest++ = 0;
1604            src++;
1605          } else {
1606            *dest++ = node;
1607            *dest++ = node_forwarding_address(*src++);
1608            while(--node_dnodes) {
1609              *dest++ = node_forwarding_address(*src++);
1610              *dest++ = node_forwarding_address(*src++);
1611            }
1612          }
1613          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1614        } else if (immheader_tag_p(tag)) {
1615          *dest++ = node;
1616          *dest++ = *src++;
1617          elements = header_element_count(node);
1618          tag = header_subtag(node);
1619
1620#ifdef PPC
1621#ifdef PPC64
1622          switch(fulltag_of(tag)) {
1623          case ivector_class_64_bit:
1624            imm_dnodes = ((elements+1)+1)>>1;
1625            break;
1626          case ivector_class_32_bit:
1627            if (tag == subtag_code_vector) {
1628              GCrelocated_code_vector = true;
1629            }
1630            imm_dnodes = (((elements+2)+3)>>2);
1631            break;
1632          case ivector_class_8_bit:
1633            imm_dnodes = (((elements+8)+15)>>4);
1634            break;
1635          case ivector_class_other_bit:
1636            if (tag == subtag_bit_vector) {
1637              imm_dnodes = (((elements+64)+127)>>7);
1638            } else {
1639              imm_dnodes = (((elements+4)+7)>>3);
1640            }
1641          }
1642#else
1643          if (tag <= max_32_bit_ivector_subtag) {
1644            if (tag == subtag_code_vector) {
1645              GCrelocated_code_vector = true;
1646            }
1647            imm_dnodes = (((elements+1)+1)>>1);
1648          } else if (tag <= max_8_bit_ivector_subtag) {
1649            imm_dnodes = (((elements+4)+7)>>3);
1650          } else if (tag <= max_16_bit_ivector_subtag) {
1651            imm_dnodes = (((elements+2)+3)>>2);
1652          } else if (tag == subtag_bit_vector) {
1653            imm_dnodes = (((elements+32)+63)>>6);
1654          } else {
1655            imm_dnodes = elements+1;
1656          }
1657#endif
1658#endif
1659
1660          dnode += imm_dnodes;
1661          while (--imm_dnodes) {
1662            *dest++ = *src++;
1663            *dest++ = *src++;
1664          }
1665          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1666        } else {
1667          *dest++ = node_forwarding_address(node);
1668          *dest++ = node_forwarding_address(*src++);
1669          bits &= ~(BIT0_MASK >> bitidx);
1670          dnode++;
1671          bitidx++;
1672        }
1673      }
1674 
1675    }
1676
1677    {
1678      natural nbytes = (natural)ptr_to_lispobj(dest) - (natural)GCfirstunmarked;
1679      if ((nbytes != 0) && GCrelocated_code_vector) {
1680        xMakeDataExecutable((LogicalAddress)ptr_from_lispobj(GCfirstunmarked), nbytes);
1681      }
1682    }
1683  }
1684  return ptr_to_lispobj(dest);
1685}
1686
1687
1688
1689
1690     
1691   
1692/*
1693  Total the (physical) byte sizes of all ivectors in the indicated memory range
1694*/
1695
1696natural
1697unboxed_bytes_in_range(LispObj *start, LispObj *end)
1698{
1699    natural total=0, elements, tag, subtag, bytes;
1700    LispObj header;
1701
1702    while (start < end) {
1703      header = *start;
1704      tag = fulltag_of(header);
1705   
1706      if ((nodeheader_tag_p(tag)) ||
1707          (immheader_tag_p(tag))) {
1708        elements = header_element_count(header);
1709        if (nodeheader_tag_p(tag)) {
1710          start += ((elements+2) & ~1);
1711        } else {
1712          subtag = header_subtag(header);
1713
1714#ifdef PPC64
1715          switch(fulltag_of(header)) {
1716          case ivector_class_64_bit:
1717            bytes = 8 + (elements<<3);
1718            break;
1719          case ivector_class_32_bit:
1720            bytes = 8 + (elements<<2);
1721            break;
1722          case ivector_class_8_bit:
1723            bytes = 8 + elements;
1724            break;
1725          case ivector_class_other_bit:
1726          default:
1727            if (subtag == subtag_bit_vector) {
1728              bytes = 8 + ((elements+7)>>3);
1729            } else {
1730              bytes = 8 + (elements<<1);
1731            }
1732          }
1733#else
1734          if (subtag <= max_32_bit_ivector_subtag) {
1735            bytes = 4 + (elements<<2);
1736          } else if (subtag <= max_8_bit_ivector_subtag) {
1737            bytes = 4 + elements;
1738          } else if (subtag <= max_16_bit_ivector_subtag) {
1739            bytes = 4 + (elements<<1);
1740          } else if (subtag == subtag_double_float_vector) {
1741            bytes = 8 + (elements<<3);
1742          } else {
1743            bytes = 4 + ((elements+7)>>3);
1744          }
1745#endif
1746
1747
1748          bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1749          total += bytes;
1750          start += (bytes >> node_shift);
1751        }
1752      } else {
1753        start += 2;
1754      }
1755    }
1756    return total;
1757  }
1758
1759
1760  /*
1761     This assumes that it's getting called with an ivector
1762     argument and that there's room for the object in the
1763     destination area.
1764  */
1765
1766
1767LispObj
1768purify_displaced_object(LispObj obj, area *dest, natural disp)
1769{
1770  BytePtr
1771    free = dest->active,
1772    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1773  LispObj
1774    header = header_of(obj), 
1775    new;
1776  natural
1777    start = (natural)old,
1778    physbytes;
1779
1780  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1781  dest->active += physbytes;
1782
1783  new = ptr_to_lispobj(free)+disp;
1784
1785  memcpy(free, (BytePtr)old, physbytes);
1786  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1787  /* Actually, it's best to always leave a trail, for two reasons.
1788     a) We may be walking the same heap that we're leaving forwaring
1789     pointers in, so we don't want garbage that we leave behind to
1790     look like a header.
1791     b) We'd like to be able to forward code-vector locatives, and
1792     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1793     pair at every doubleword in the old vector.
1794  */
1795  while(physbytes) {
1796    *old++ = (BytePtr) forward_marker;
1797    *old++ = (BytePtr) free;
1798    free += dnode_size;
1799    physbytes -= dnode_size;
1800  }
1801  return new;
1802}
1803
1804LispObj
1805purify_object(LispObj obj, area *dest)
1806{
1807  return purify_displaced_object(obj, dest, fulltag_of(obj));
1808}
1809
1810
1811
1812void
1813copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1814{
1815  LispObj obj = *ref, header;
1816  natural tag = fulltag_of(obj), header_tag;
1817
1818  if ((tag == fulltag_misc) &&
1819      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1820      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1821    header = deref(obj, 0);
1822    if (header == forward_marker) { /* already copied */
1823      *ref = (untag(deref(obj,1)) + tag);
1824    } else {
1825      header_tag = fulltag_of(header);
1826      if (immheader_tag_p(header_tag)) {
1827        if (header_subtag(header) != subtag_macptr) {
1828          *ref = purify_object(obj, dest);
1829        }
1830      }
1831    }
1832  }
1833}
1834
1835void
1836purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to)
1837{
1838#ifdef PPC
1839  LispObj
1840    loc = *locaddr,
1841    *headerP;
1842  opcode
1843    *p,
1844    insn;
1845  natural
1846    tag = fulltag_of(loc);
1847
1848  if (((BytePtr)ptr_from_lispobj(loc) > low) &&
1849      ((BytePtr)ptr_from_lispobj(loc) < high)) {
1850
1851    headerP = (LispObj *)ptr_from_lispobj(untag(loc));
1852    switch (tag) {
1853    case fulltag_even_fixnum:
1854    case fulltag_odd_fixnum:
1855#ifdef PPC64
1856    case fulltag_cons:
1857    case fulltag_misc:
1858#endif
1859      if (*headerP == forward_marker) {
1860        *locaddr = (headerP[1]+tag);
1861      } else {
1862        /* Grovel backwards until the header's found; copy
1863           the code vector to to space, then treat it as if it
1864           hasn't already been copied. */
1865        p = (opcode *)headerP;
1866        do {
1867          p -= 2;
1868          tag += 8;
1869          insn = *p;
1870#ifdef PPC64
1871        } while (insn != PPC64_CODE_VECTOR_PREFIX);
1872        headerP = ((LispObj*)p)-1;
1873        *locaddr = purify_displaced_object(((LispObj)headerP), to, tag);
1874#else
1875      } while ((insn & code_header_mask) != subtag_code_vector);
1876      *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag);
1877#endif
1878    }
1879    break;
1880
1881#ifndef PPC64
1882  case fulltag_misc:
1883    copy_ivector_reference(locaddr, low, high, to);
1884    break;
1885#endif
1886  }
1887}
1888#endif
1889}
1890
1891void
1892purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1893{
1894  LispObj header;
1895  unsigned tag;
1896
1897  while (start < end) {
1898    header = *start;
1899    if (header == forward_marker) {
1900      start += 2;
1901    } else {
1902      tag = fulltag_of(header);
1903      if (immheader_tag_p(tag)) {
1904        start = (LispObj *)skip_over_ivector((natural)start, header);
1905      } else {
1906        if (!nodeheader_tag_p(tag)) {
1907          copy_ivector_reference(start, low, high, to);
1908        }
1909        start++;
1910        copy_ivector_reference(start, low, high, to);
1911        start++;
1912      }
1913    }
1914  }
1915}
1916       
1917/* Purify references from tstack areas */
1918void
1919purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
1920{
1921  LispObj
1922    *current,
1923    *next,
1924    *start = (LispObj *) (a->active),
1925    *end = start,
1926    *limit = (LispObj *) (a->high);
1927
1928  for (current = start;
1929       end != limit;
1930       current = next) {
1931    next = (LispObj *) ptr_from_lispobj(*current);
1932    end = ((next >= start) && (next < limit)) ? next : limit;
1933    if (current[1] == 0) {
1934      purify_range(current+2, end, low, high, to);
1935    }
1936  }
1937}
1938
1939/* Purify a vstack area */
1940void
1941purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
1942{
1943  LispObj
1944    *p = (LispObj *) a->active,
1945    *q = (LispObj *) a->high;
1946
1947  if (((natural)p) & sizeof(natural)) {
1948    copy_ivector_reference(p, low, high, to);
1949    p++;
1950  }
1951  purify_range(p, q, low, high, to);
1952}
1953
1954
1955void
1956purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to)
1957{
1958  BytePtr
1959    current,
1960    next,
1961    limit = a->high;
1962
1963  for (current = a->active; current != limit; current = next) {
1964    next = *((BytePtr *)current);
1965    if (next == NULL) break;
1966    if (((next - current) == sizeof(lisp_frame)) && 
1967        (((((lisp_frame *)current)->savefn) == 0) ||
1968         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
1969      purify_locref(&((lisp_frame *) current)->savelr, low, high, to);
1970    } else {
1971      /* Clear low bits of "next", just in case */
1972      next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1));
1973    }
1974  }
1975}
1976
1977void
1978purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
1979{
1980  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
1981
1982  int r;
1983
1984  /* registers >= fn should be treated as roots.
1985     The PC, LR, loc_pc, and CTR should be treated as "locatives".
1986   */
1987
1988  for (r = fn; r < 32; r++) {
1989    copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to);
1990  };
1991
1992  purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to);
1993
1994  purify_locref((LispObj*) (&(xpPC(xp))), low, high, to);
1995  purify_locref((LispObj*) (&(xpLR(xp))), low, high, to);
1996  purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to);
1997}
1998
1999void
2000purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
2001{
2002  natural n = tcr->tlb_limit;
2003  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2004
2005  purify_range(start, end, low, high, to);
2006}
2007
2008void
2009purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
2010{
2011  xframe_list *xframes;
2012  ExceptionInformation *xp;
2013 
2014  xp = tcr->gc_context;
2015  if (xp) {
2016    purify_xp(xp, low, high, to);
2017  }
2018
2019  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2020    purify_xp(xframes->curr, low, high, to);
2021  }
2022}
2023
2024void
2025purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
2026{
2027  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2028
2029  while ((*prev) != (LispObj)NULL) {
2030    copy_ivector_reference(prev, low, high, to);
2031    next = *prev;
2032    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2033  }
2034}
2035
2036
2037void
2038purify_areas(BytePtr low, BytePtr high, area *target)
2039{
2040  area *next_area;
2041  area_code code;
2042     
2043  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2044    switch (code) {
2045    case AREA_TSTACK:
2046      purify_tstack_area(next_area, low, high, target);
2047      break;
2048     
2049    case AREA_VSTACK:
2050      purify_vstack_area(next_area, low, high, target);
2051      break;
2052     
2053    case AREA_CSTACK:
2054      purify_cstack_area(next_area, low, high, target);
2055      break;
2056     
2057    case AREA_STATIC:
2058    case AREA_DYNAMIC:
2059      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
2060      break;
2061     
2062    default:
2063      break;
2064    }
2065  }
2066}
2067
2068/*
2069  So far, this is mostly for save_application's benefit.
2070  We -should- be able to return to lisp code after doing this,
2071  however.
2072
2073*/
2074
2075
2076signed_natural
2077purify(TCR *tcr, signed_natural param)
2078{
2079  extern area *extend_readonly_area(unsigned);
2080  area
2081    *a = active_dynamic_area,
2082    *new_pure_area;
2083
2084  TCR  *other_tcr;
2085  natural max_pure_size;
2086  BytePtr new_pure_start;
2087
2088
2089  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
2090                                         (LispObj *) a->active);
2091  new_pure_area = extend_readonly_area(max_pure_size);
2092  if (new_pure_area) {
2093    new_pure_start = new_pure_area->active;
2094    lisp_global(IN_GC) = (1<<fixnumshift);
2095
2096   
2097    purify_areas(a->low, a->active, new_pure_area);
2098   
2099    other_tcr = tcr;
2100    do {
2101      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
2102      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
2103      other_tcr = other_tcr->next;
2104    } while (other_tcr != tcr);
2105
2106    purify_gcable_ptrs(a->low, a->active, new_pure_area);
2107
2108    {
2109      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2110      if (puresize != 0) {
2111        xMakeDataExecutable(new_pure_start, puresize);
2112 
2113      }
2114    }
2115    ProtectMemory(new_pure_area->low,
2116                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2117                                      log2_page_size));
2118    lisp_global(IN_GC) = 0;
2119    just_purified_p = true;
2120    return 0;
2121  }
2122  return -1;
2123}
2124
2125void
2126impurify_locref(LispObj *p, LispObj low, LispObj high, int delta)
2127{
2128  LispObj q = *p;
2129 
2130  switch (fulltag_of(q)) {
2131#ifdef PPC64
2132  case fulltag_cons:
2133#endif
2134  case fulltag_misc:
2135  case fulltag_even_fixnum:
2136  case fulltag_odd_fixnum:
2137    if ((q >= low) && (q < high)) {
2138      *p = (q+delta);
2139    }
2140  }
2141}
2142
2143 
2144void
2145impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2146{
2147  LispObj q = *p;
2148 
2149  if ((fulltag_of(q) == fulltag_misc) &&
2150      (q >= low) && 
2151      (q < high)) {
2152    *p = (q+delta);
2153  }
2154}
2155 
2156
2157#ifdef PPC
2158void
2159impurify_cstack_area(area *a, LispObj low, LispObj high, int delta)
2160{
2161  BytePtr
2162    current,
2163    next,
2164    limit = a->high;
2165
2166  for (current = a->active; current != limit; current = next) {
2167    next = *((BytePtr *)current);
2168    if (next == NULL) break;
2169    if (((next - current) == sizeof(lisp_frame)) && 
2170        (((((lisp_frame *)current)->savefn) == 0) ||
2171         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
2172      impurify_locref(&((lisp_frame *) current)->savelr, low, high, delta);
2173    } else {
2174      /* Clear low bits of "next", just in case */
2175      next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1));
2176    }
2177  }
2178}
2179#endif
2180
2181void
2182impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
2183{
2184  natural *regs = (natural *) xpGPRvector(xp);
2185
2186#ifdef PPC
2187  int r;
2188  /* registers >= fn should be treated as roots.
2189     The PC, LR, loc_pc, and CTR should be treated as "locatives".
2190   */
2191
2192  for (r = fn; r < 32; r++) {
2193    impurify_noderef((LispObj*) (&(regs[r])), low, high, delta);
2194  };
2195
2196  impurify_locref((LispObj*) (&(regs[loc_pc])), low, high, delta);
2197
2198  impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta);
2199  impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta);
2200  impurify_locref((LispObj*) (&(xpCTR(xp))), low, high, delta);
2201#endif
2202
2203}
2204
2205
2206void
2207impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
2208{
2209  LispObj header;
2210  unsigned tag;
2211
2212  while (start < end) {
2213    header = *start;
2214    tag = fulltag_of(header);
2215    if (immheader_tag_p(tag)) {
2216      start = (LispObj *)skip_over_ivector((natural)start, header);
2217    } else {
2218      if (!nodeheader_tag_p(tag)) {
2219        impurify_noderef(start, low, high, delta);
2220        }
2221      start++;
2222      impurify_noderef(start, low, high, delta);
2223      start++;
2224    }
2225  }
2226}
2227
2228
2229
2230
2231void
2232impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
2233{
2234  unsigned n = tcr->tlb_limit;
2235  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2236 
2237  impurify_range(start, end, low, high, delta);
2238}
2239
2240void
2241impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
2242{
2243  xframe_list *xframes;
2244  ExceptionInformation *xp;
2245 
2246  xp = tcr->gc_context;
2247  if (xp) {
2248    impurify_xp(xp, low, high, delta);
2249  }
2250
2251  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2252    impurify_xp(xframes->curr, low, high, delta);
2253  }
2254}
2255
2256void
2257impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
2258{
2259  LispObj
2260    *current,
2261    *next,
2262    *start = (LispObj *) (a->active),
2263    *end = start,
2264    *limit = (LispObj *) (a->high);
2265
2266  for (current = start;
2267       end != limit;
2268       current = next) {
2269    next = (LispObj *) ptr_from_lispobj(*current);
2270    end = ((next >= start) && (next < limit)) ? next : limit;
2271    if (current[1] == 0) {
2272      impurify_range(current+2, end, low, high, delta);
2273    }
2274  }
2275}
2276void
2277impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
2278{
2279  LispObj
2280    *p = (LispObj *) a->active,
2281    *q = (LispObj *) a->high;
2282
2283  if (((natural)p) & sizeof(natural)) {
2284    impurify_noderef(p, low, high, delta);
2285    p++;
2286  }
2287  impurify_range(p, q, low, high, delta);
2288}
2289
2290
2291void
2292impurify_areas(LispObj low, LispObj high, int delta)
2293{
2294  area *next_area;
2295  area_code code;
2296     
2297  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2298    switch (code) {
2299    case AREA_TSTACK:
2300      impurify_tstack_area(next_area, low, high, delta);
2301      break;
2302     
2303    case AREA_VSTACK:
2304      impurify_vstack_area(next_area, low, high, delta);
2305      break;
2306     
2307    case AREA_CSTACK:
2308#ifdef PPC
2309      impurify_cstack_area(next_area, low, high, delta);
2310#endif
2311      break;
2312     
2313    case AREA_STATIC:
2314    case AREA_DYNAMIC:
2315      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2316      break;
2317     
2318    default:
2319      break;
2320    }
2321  }
2322}
2323
2324void
2325impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2326{
2327  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2328
2329  while ((*prev) != (LispObj)NULL) {
2330    impurify_noderef(prev, low, high, delta);
2331    next = *prev;
2332    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2333  }
2334}
2335
2336signed_natural
2337impurify(TCR *tcr, signed_natural param)
2338{
2339  area *r = readonly_area;
2340
2341  if (r) {
2342    area *a = active_dynamic_area;
2343    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2344      oldhigh = a->high, newhigh; 
2345    unsigned n = ro_limit - ro_base;
2346    int delta = oldfree-ro_base;
2347    TCR *other_tcr;
2348
2349    if (n) {
2350      lisp_global(IN_GC) = 1;
2351      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2352                                               log2_heap_segment_size));
2353      if (newhigh > oldhigh) {
2354        grow_dynamic_area(newhigh-oldhigh);
2355      }
2356      a->active += n;
2357      memmove(oldfree, ro_base, n);
2358      munmap(ro_base, n);
2359      a->ndnodes = area_dnode(a, a->active);
2360      pure_space_active = r->active = r->low;
2361      r->ndnodes = 0;
2362
2363      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2364
2365      other_tcr = tcr;
2366      do {
2367        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2368        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2369        other_tcr = other_tcr->next;
2370      } while (other_tcr != tcr);
2371
2372      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2373      lisp_global(IN_GC) = 0;
2374    }
2375    return 0;
2376  }
2377  return -1;
2378}
2379
Note: See TracBrowser for help on using the repository browser.