source: trunk/source/lisp-kernel/ppc-gc.c @ 11167

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

check_all_areas() takes the current tcr as argument (doesn't use it yet
on PPC.)

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