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

Last change on this file since 9980 was 9980, checked in by gb, 11 years ago

Purify all ivectors (except MACPTRs.)

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