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

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

r13066, r13067 from trunk: copyrights etc

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