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

Last change on this file since 7668 was 7668, checked in by gb, 12 years ago

openSUSE 10.3 (at least) shipped with a buggy version of bcopy();
see <http://lists.opensuse.oorg/opensuse-bugs/2007-09/msg14146.html>
Use memmove() instead. (I don't think any of the uses of any of this
stuff care about overlap, but we might as well use something that
checks for it.)

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