source: release/1.7/source/lisp-kernel/ppc-gc.c @ 15267

Last change on this file since 15267 was 14723, checked in by gb, 8 years ago

In mark_memoized_area() on all platforms, don't do any special
processing of weak-on-value hash vectors. (This means that otherwise
unreferenced values in weak-on-value hash tables will only be free
on a full GC.) This seems to fix (at least the symptom of) ticket:817,
or at least allows my test case to run to completion.

The real problem is that sometimes those weak-on-value hash vectors
aren't on GCweakvll; if we don't mark the values in the weak vector
in mark_memoized_area(), nothing deletes unmarked values from the
hash table (or otherwise completes weak processing.) I was unable
to determine why the vectors were sometimes missing from the list;
not dropping them in init_weakvll() didn't seem to fix anything.

One approach to fixing the real problem is to say:

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