source: branches/arm/lisp-kernel/ppc-gc.c @ 13923

Last change on this file since 13923 was 13512, checked in by gb, 10 years ago

Fix typos.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 62.2 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        if (hp->flags & nhash_weak_mask) {
1006          /* If header_count is odd, this cuts off the last header field */
1007          /* That case is handled specially above */
1008          hash_dnode_limit = memo_dnode + ((hash_table_vector_header_count) >>1);
1009          hashp = hp;
1010          mark_method = 3;
1011        }
1012      }
1013
1014      keep_x1 = mark_ephemeral_root(x1);
1015      keep_x2 = mark_ephemeral_root(x2);
1016      if ((keep_x1 == false) && 
1017          (keep_x2 == false) &&
1018          (hashp == NULL)) {
1019        outbits &= ~(BIT0_MASK >> bitidx);
1020      }
1021      memo_dnode++;
1022      bitidx++;
1023    }
1024  }
1025  if (GCDebug) {
1026    p = (LispObj *) a->low;
1027    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1028  }
1029}
1030
1031
1032
1033void
1034mark_simple_area_range(LispObj *start, LispObj *end)
1035{
1036  LispObj x1, *base;
1037  int tag;
1038
1039  while (start < end) {
1040    x1 = *start;
1041    tag = fulltag_of(x1);
1042    if (immheader_tag_p(tag)) {
1043      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
1044    } else if (!nodeheader_tag_p(tag)) {
1045      ++start;
1046      mark_root(x1);
1047      mark_root(*start++);
1048    } else {
1049      int subtag = header_subtag(x1);
1050      natural element_count = header_element_count(x1);
1051      natural size = (element_count+1 + 1) & ~1;
1052
1053      if (subtag == subtag_hash_vector) {
1054        LispObj flags = ((hash_table_vector_header *) start)->flags;
1055
1056        if (flags & nhash_weak_mask) {
1057          ((hash_table_vector_header *) start)->cache_key = undefined;
1058          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1059          mark_weak_htabv((LispObj)start);
1060          element_count = 0;
1061        }
1062      }
1063      if (subtag == subtag_pool) {
1064        start[1] = lisp_nil;
1065      }
1066
1067      if (subtag == subtag_weak) {
1068        natural weak_type = (natural) start[2];
1069        if (weak_type >> population_termination_bit)
1070          element_count -= 2;
1071        else
1072          element_count -= 1; 
1073        start[1] = GCweakvll;
1074        GCweakvll = ptr_to_lispobj(start);
1075      }
1076
1077      base = start + element_count + 1;
1078      while(element_count--) {
1079        mark_root(*--base);
1080      }   
1081      start += size;
1082    }
1083  }
1084}
1085
1086
1087/* Mark a tstack area */
1088void
1089mark_tstack_area(area *a)
1090{
1091  LispObj
1092    *current,
1093    *next,
1094    *start = (LispObj *) (a->active),
1095    *end = start,
1096    *limit = (LispObj *) (a->high);
1097
1098  for (current = start;
1099       end != limit;
1100       current = next) {
1101    next = (LispObj *) ptr_from_lispobj(*current);
1102    end = ((next >= start) && (next < limit)) ? next : limit;
1103    if (current[1] == 0) {
1104      mark_simple_area_range(current+2, end);
1105    }
1106  }
1107}
1108
1109/*
1110  It's really important that headers never wind up in tagged registers.
1111  Those registers would (possibly) get pushed on the vstack and confuse
1112  the hell out of this routine.
1113
1114  vstacks are just treated as a "simple area range", possibly with
1115  an extra word at the top (where the area's active pointer points.)
1116  */
1117
1118void
1119mark_vstack_area(area *a)
1120{
1121  LispObj
1122    *start = (LispObj *) a->active,
1123    *end = (LispObj *) a->high;
1124
1125#if 0
1126  fprintf(dbgout, "mark VSP range: 0x%lx:0x%lx\n", start, end);
1127#endif
1128  if (((natural)start) & (sizeof(natural))) {
1129    /* Odd number of words.  Mark the first (can't be a header) */
1130    mark_root(*start);
1131    ++start;
1132  }
1133  mark_simple_area_range(start, end);
1134}
1135
1136
1137/*
1138  Mark lisp frames on the control stack.
1139  Ignore emulator frames (odd backpointer) and C frames (size != 4).
1140*/
1141
1142void
1143mark_cstack_area(area *a)
1144{
1145  BytePtr
1146    current,
1147    next,
1148    limit = a->high,
1149    low = a->low;
1150
1151  for (current = a->active; (current >= low) && (current < limit); current = next) {
1152    next = *((BytePtr *)current);
1153#if 0
1154    if (next < current) {
1155      Bug(NULL, "Child stack frame older than parent");
1156    }
1157#endif
1158    if (next == NULL) break;
1159    if (((next - current) == sizeof(lisp_frame)) &&
1160        (((((lisp_frame *)current)->savefn) == 0) ||
1161         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
1162      /* mark fn, then saved lr */
1163      mark_root(((lisp_frame *)current)->savefn);
1164      mark_pc_root(((lisp_frame *)current)->savelr);
1165    } else {
1166      /* Clear low 2 bits of "next", just in case */
1167      next = (BytePtr) (((natural)next) & ~3);
1168    }
1169  }
1170}
1171
1172
1173
1174/* Mark the lisp objects in an exception frame */
1175void
1176mark_xp(ExceptionInformation *xp)
1177{
1178  natural *regs = (natural *) xpGPRvector(xp);
1179
1180#ifdef PPC
1181  int r;
1182  /* registers >= fn should be tagged and marked as roots.
1183     the PC, LR, loc_pc, and CTR should be treated as "pc_locatives".
1184
1185     In general, marking a locative is more expensive than marking
1186     a node is, since it may be neccessary to back up and find the
1187     containing object's header.  Since exception frames contain
1188     many locatives, it'd be wise to mark them *after* marking the
1189     stacks, nilreg-relative globals, etc.
1190     */
1191
1192  for (r = fn; r < 32; r++) {
1193    mark_root((regs[r]));
1194  }
1195
1196
1197
1198  mark_pc_root((regs[loc_pc]));
1199  mark_pc_root(ptr_to_lispobj(xpPC(xp)));
1200  mark_pc_root(ptr_to_lispobj(xpLR(xp)));
1201  mark_pc_root(ptr_to_lispobj(xpCTR(xp)));
1202#endif /* PPC */
1203
1204}
1205
1206/* A "pagelet" contains 32 doublewords.  The relocation table contains
1207   a word for each pagelet which defines the lowest address to which
1208   dnodes on that pagelet will be relocated.
1209
1210   The relocation address of a given pagelet is the sum of the relocation
1211   address for the preceding pagelet and the number of bytes occupied by
1212   marked objects on the preceding pagelet.
1213*/
1214
1215LispObj
1216calculate_relocation()
1217{
1218  LispObj *relocptr = GCrelocptr;
1219  LispObj current = GCareadynamiclow;
1220  bitvector
1221    markbits = GCdynamic_markbits;
1222  qnode *q = (qnode *) markbits;
1223  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1224  natural thesebits;
1225  LispObj first = 0;
1226
1227  do {
1228    *relocptr++ = current;
1229    thesebits = *markbits++;
1230    if (thesebits == ALL_ONES) {
1231      current += nbits_in_word*dnode_size;
1232      q += 4; /* sic */
1233    } else {
1234      if (!first) {
1235        first = current;
1236        while (thesebits & BIT0_MASK) {
1237          first += dnode_size;
1238          thesebits += thesebits;
1239        }
1240      }
1241      current += one_bits(*q++);
1242      current += one_bits(*q++);
1243      current += one_bits(*q++);
1244      current += one_bits(*q++);
1245    }
1246  } while(--npagelets);
1247  *relocptr++ = current;
1248  return first ? first : current;
1249}
1250
1251#ifdef PPC64
1252LispObj
1253dnode_forwarding_address(natural dnode, int tag_n)
1254{
1255  natural pagelet, nbits;
1256  unsigned int near_bits;
1257  LispObj new;
1258
1259  if (GCDebug) {
1260    if (! ref_bit(GCdynamic_markbits, dnode)) {
1261      Bug(NULL, "unmarked object being forwarded!\n");
1262    }
1263  }
1264
1265  pagelet = dnode >> bitmap_shift;
1266  nbits = dnode & bitmap_shift_count_mask;
1267  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
1268
1269  if (nbits < 32) {
1270    new = GCrelocptr[pagelet] + tag_n;;
1271    /* Increment "new" by the count of 1 bits which precede the dnode */
1272    if (near_bits == 0xffffffff) {
1273      return (new + (nbits << 4));
1274    } else {
1275      near_bits &= (0xffffffff00000000 >> nbits);
1276      if (nbits > 15) {
1277        new += one_bits(near_bits & 0xffff);
1278      }
1279      return (new + (one_bits(near_bits >> 16))); 
1280    }
1281  } else {
1282    new = GCrelocptr[pagelet+1] + tag_n;
1283    nbits = 64-nbits;
1284
1285    if (near_bits == 0xffffffff) {
1286      return (new - (nbits << 4));
1287    } else {
1288      near_bits &= (1<<nbits)-1;
1289      if (nbits > 15) {
1290        new -= one_bits(near_bits >> 16);
1291      }
1292      return (new -  one_bits(near_bits & 0xffff));
1293    }
1294  }
1295}
1296#else
1297LispObj
1298dnode_forwarding_address(natural dnode, int tag_n)
1299{
1300  natural pagelet, nbits;
1301  unsigned short near_bits;
1302  LispObj new;
1303
1304  if (GCDebug) {
1305    if (! ref_bit(GCdynamic_markbits, dnode)) {
1306      Bug(NULL, "unmarked object being forwarded!\n");
1307    }
1308  }
1309
1310  pagelet = dnode >> 5;
1311  nbits = dnode & 0x1f;
1312  near_bits = ((unsigned short *)GCdynamic_markbits)[dnode>>4];
1313
1314  if (nbits < 16) {
1315    new = GCrelocptr[pagelet] + tag_n;;
1316    /* Increment "new" by the count of 1 bits which precede the dnode */
1317    if (near_bits == 0xffff) {
1318      return (new + (nbits << 3));
1319    } else {
1320      near_bits &= (0xffff0000 >> nbits);
1321      if (nbits > 7) {
1322        new += one_bits(near_bits & 0xff);
1323      }
1324      return (new + (one_bits(near_bits >> 8))); 
1325    }
1326  } else {
1327    new = GCrelocptr[pagelet+1] + tag_n;
1328    nbits = 32-nbits;
1329
1330    if (near_bits == 0xffff) {
1331      return (new - (nbits << 3));
1332    } else {
1333      near_bits &= (1<<nbits)-1;
1334      if (nbits > 7) {
1335        new -= one_bits(near_bits >> 8);
1336      }
1337      return (new -  one_bits(near_bits & 0xff));
1338    }
1339  }
1340}
1341#endif
1342
1343
1344LispObj
1345locative_forwarding_address(LispObj obj)
1346{
1347  int tag_n = fulltag_of(obj);
1348  natural dnode;
1349
1350
1351#ifdef PPC
1352  /* Locatives can be tagged as conses, "fulltag_misc"
1353     objects, or as fixnums.  Immediates, headers, and nil
1354     shouldn't be "forwarded".  Nil never will be, but it
1355     doesn't hurt to check ... */
1356#ifdef PPC64
1357  if ((tag_n & lowtag_mask) != lowtag_primary) {
1358    return obj;
1359  }
1360#else
1361  if ((1<<tag_n) & ((1<<fulltag_immheader) |
1362                    (1<<fulltag_nodeheader) |
1363                    (1<<fulltag_imm) |
1364                    (1<<fulltag_nil))) {
1365    return obj;
1366  }
1367#endif
1368#endif
1369
1370  dnode = gc_dynamic_area_dnode(obj);
1371
1372  if ((dnode >= GCndynamic_dnodes_in_area) ||
1373      (obj < GCfirstunmarked)) {
1374    return obj;
1375  }
1376
1377  return dnode_forwarding_address(dnode, tag_n);
1378}
1379
1380
1381
1382
1383void
1384forward_range(LispObj *range_start, LispObj *range_end)
1385{
1386  LispObj *p = range_start, node, new;
1387  int tag_n;
1388  natural nwords;
1389  hash_table_vector_header *hashp;
1390
1391  while (p < range_end) {
1392    node = *p;
1393    tag_n = fulltag_of(node);
1394    if (immheader_tag_p(tag_n)) {
1395      p = (LispObj *) skip_over_ivector((natural) p, node);
1396    } else if (nodeheader_tag_p(tag_n)) {
1397      nwords = header_element_count(node);
1398      nwords += (1 - (nwords&1));
1399      if ((header_subtag(node) == subtag_hash_vector) &&
1400          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1401        natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1402        hashp = (hash_table_vector_header *) p;
1403        p++;
1404        nwords -= skip;
1405        while(skip--) {
1406          update_noderef(p);
1407          p++;
1408        }
1409        /* "nwords" is odd at this point: there are (floor nwords 2)
1410           key/value pairs to look at, and then an extra word for
1411           alignment.  Process them two at a time, then bump "p"
1412           past the alignment word. */
1413        nwords >>= 1;
1414        while(nwords--) {
1415          if (update_noderef(p) && hashp) {
1416            hashp->flags |= nhash_key_moved_mask;
1417            hashp = NULL;
1418          }
1419          p++;
1420          update_noderef(p);
1421          p++;
1422        }
1423        *p++ = 0;
1424      } else {
1425        p++;
1426        while(nwords--) {
1427          update_noderef(p);
1428          p++;
1429        }
1430      }
1431    } else {
1432      new = node_forwarding_address(node);
1433      if (new != node) {
1434        *p = new;
1435      }
1436      p++;
1437      update_noderef(p);
1438      p++;
1439    }
1440  }
1441}
1442
1443
1444
1445
1446/* Forward a tstack area */
1447void
1448forward_tstack_area(area *a)
1449{
1450  LispObj
1451    *current,
1452    *next,
1453    *start = (LispObj *) a->active,
1454    *end = start,
1455    *limit = (LispObj *) (a->high);
1456
1457  for (current = start;
1458       end != limit;
1459       current = next) {
1460    next = ptr_from_lispobj(*current);
1461    end = ((next >= start) && (next < limit)) ? next : limit;
1462    if (current[1] == 0) {
1463      forward_range(current+2, end);
1464    }
1465  }
1466}
1467
1468/* Forward a vstack area */
1469void
1470forward_vstack_area(area *a)
1471{
1472  LispObj
1473    *p = (LispObj *) a->active,
1474    *q = (LispObj *) a->high;
1475
1476#ifdef DEBUG
1477  fprintf(dbgout,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner);
1478#endif
1479  if (((natural)p) & sizeof(natural)) {
1480    update_noderef(p);
1481    p++;
1482  }
1483  forward_range(p, q);
1484}
1485
1486void
1487forward_cstack_area(area *a)
1488{
1489  BytePtr
1490    current,
1491    next,
1492    limit = a->high,
1493    low = a->low;
1494
1495  for (current = a->active; (current >= low) && (current < limit); current = next) {
1496    next = *((BytePtr *)current);
1497    if (next == NULL) break;
1498    if (((next - current) == sizeof(lisp_frame)) &&
1499        (((((lisp_frame *)current)->savefn) == 0) ||
1500         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
1501      update_noderef(&((lisp_frame *) current)->savefn);
1502      update_locref(&((lisp_frame *) current)->savelr);
1503    }
1504  }
1505}
1506
1507
1508
1509void
1510forward_xp(ExceptionInformation *xp)
1511{
1512  natural *regs = (natural *) xpGPRvector(xp);
1513
1514  int r;
1515
1516  /* registers >= fn should be tagged and forwarded as roots.
1517     the PC, LR, loc_pc, and CTR should be treated as "locatives".
1518     */
1519
1520  for (r = fn; r < 32; r++) {
1521    update_noderef((LispObj*) (&(regs[r])));
1522  }
1523
1524  update_locref((LispObj*) (&(regs[loc_pc])));
1525
1526  update_locref((LispObj*) (&(xpPC(xp))));
1527  update_locref((LispObj*) (&(xpLR(xp))));
1528  update_locref((LispObj*) (&(xpCTR(xp))));
1529
1530}
1531
1532
1533void
1534forward_tcr_xframes(TCR *tcr)
1535{
1536  xframe_list *xframes;
1537  ExceptionInformation *xp;
1538
1539  xp = tcr->gc_context;
1540  if (xp) {
1541    forward_xp(xp);
1542  }
1543  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1544    if (xframes->curr == xp) {
1545      Bug(NULL, "forward xframe twice ???");
1546    }
1547    forward_xp(xframes->curr);
1548  }
1549}
1550
1551
1552
1553/*
1554  Compact the dynamic heap (from GCfirstunmarked through its end.)
1555  Return the doublenode address of the new freeptr.
1556  */
1557
1558LispObj
1559compact_dynamic_heap()
1560{
1561  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new;
1562  natural
1563    elements, 
1564    dnode = gc_area_dnode(GCfirstunmarked), 
1565    node_dnodes = 0, 
1566    imm_dnodes = 0, 
1567    bitidx, 
1568    *bitsp, 
1569    bits, 
1570    nextbit, 
1571    diff;
1572  int tag;
1573  bitvector markbits = GCmarkbits;
1574    /* keep track of whether or not we saw any
1575       code_vector headers, and only flush cache if so. */
1576  Boolean GCrelocated_code_vector = false;
1577
1578  if (dnode < GCndnodes_in_area) {
1579    lisp_global(FWDNUM) += (1<<fixnum_shift);
1580 
1581    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1582    while (dnode < GCndnodes_in_area) {
1583      if (bits == 0) {
1584        int remain = nbits_in_word - bitidx;
1585        dnode += remain;
1586        src += (remain+remain);
1587        bits = *++bitsp;
1588        bitidx = 0;
1589      } else {
1590        /* Have a non-zero markbits word; all bits more significant
1591           than "bitidx" are 0.  Count leading zeros in "bits"
1592           (there'll be at least "bitidx" of them.)  If there are more
1593           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1594           "src" by the difference. */
1595        nextbit = count_leading_zeros(bits);
1596        if ((diff = (nextbit - bitidx)) != 0) {
1597          dnode += diff;
1598          bitidx = nextbit;
1599          src += (diff+diff);
1600        }
1601
1602        if (GCDebug) {
1603          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1604            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1605                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1606          }
1607        }
1608
1609        node = *src++;
1610        tag = fulltag_of(node);
1611        if (nodeheader_tag_p(tag)) {
1612          elements = header_element_count(node);
1613          node_dnodes = (elements+2)>>1;
1614          dnode += node_dnodes;
1615          if ((header_subtag(node) == subtag_hash_vector) &&
1616              (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1617            hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1618            int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1619         
1620            *dest++ = node;
1621            elements -= skip;
1622            while(skip--) {
1623              *dest++ = node_forwarding_address(*src++);
1624            }
1625            /* There should be an even number of (key/value) pairs in elements;
1626               an extra alignment word follows. */
1627            elements >>= 1;
1628            while (elements--) {
1629              if (hashp) {
1630                node = *src++;
1631                new = node_forwarding_address(node);
1632                if (new != node) {
1633                  hashp->flags |= nhash_key_moved_mask;
1634                  hashp = NULL;
1635                  *dest++ = new;
1636                } else {
1637                  *dest++ = node;
1638                }
1639              } else {
1640                *dest++ = node_forwarding_address(*src++);
1641              }
1642              *dest++ = node_forwarding_address(*src++);
1643            }
1644            *dest++ = 0;
1645            src++;
1646          } else {
1647            *dest++ = node;
1648            *dest++ = node_forwarding_address(*src++);
1649            while(--node_dnodes) {
1650              *dest++ = node_forwarding_address(*src++);
1651              *dest++ = node_forwarding_address(*src++);
1652            }
1653          }
1654          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1655        } else if (immheader_tag_p(tag)) {
1656          *dest++ = node;
1657          *dest++ = *src++;
1658          elements = header_element_count(node);
1659          tag = header_subtag(node);
1660
1661#ifdef PPC
1662#ifdef PPC64
1663          switch(fulltag_of(tag)) {
1664          case ivector_class_64_bit:
1665            imm_dnodes = ((elements+1)+1)>>1;
1666            break;
1667          case ivector_class_32_bit:
1668            if (tag == subtag_code_vector) {
1669              GCrelocated_code_vector = true;
1670            }
1671            imm_dnodes = (((elements+2)+3)>>2);
1672            break;
1673          case ivector_class_8_bit:
1674            imm_dnodes = (((elements+8)+15)>>4);
1675            break;
1676          case ivector_class_other_bit:
1677            if (tag == subtag_bit_vector) {
1678              imm_dnodes = (((elements+64)+127)>>7);
1679            } else {
1680              imm_dnodes = (((elements+4)+7)>>3);
1681            }
1682          }
1683#else
1684          if (tag <= max_32_bit_ivector_subtag) {
1685            if (tag == subtag_code_vector) {
1686              GCrelocated_code_vector = true;
1687            }
1688            imm_dnodes = (((elements+1)+1)>>1);
1689          } else if (tag <= max_8_bit_ivector_subtag) {
1690            imm_dnodes = (((elements+4)+7)>>3);
1691          } else if (tag <= max_16_bit_ivector_subtag) {
1692            imm_dnodes = (((elements+2)+3)>>2);
1693          } else if (tag == subtag_bit_vector) {
1694            imm_dnodes = (((elements+32)+63)>>6);
1695          } else {
1696            imm_dnodes = elements+1;
1697          }
1698#endif
1699#endif
1700
1701          dnode += imm_dnodes;
1702          while (--imm_dnodes) {
1703            *dest++ = *src++;
1704            *dest++ = *src++;
1705          }
1706          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1707        } else {
1708          *dest++ = node_forwarding_address(node);
1709          *dest++ = node_forwarding_address(*src++);
1710          bits &= ~(BIT0_MASK >> bitidx);
1711          dnode++;
1712          bitidx++;
1713        }
1714      }
1715 
1716    }
1717
1718    {
1719      natural nbytes = (natural)ptr_to_lispobj(dest) - (natural)GCfirstunmarked;
1720      if ((nbytes != 0) && GCrelocated_code_vector) {
1721        xMakeDataExecutable((LogicalAddress)ptr_from_lispobj(GCfirstunmarked), nbytes);
1722      }
1723    }
1724  }
1725  return ptr_to_lispobj(dest);
1726}
1727
1728
1729
1730
1731     
1732   
1733/*
1734  Total the (physical) byte sizes of all ivectors in the indicated memory range
1735*/
1736
1737natural
1738unboxed_bytes_in_range(LispObj *start, LispObj *end)
1739{
1740    natural total=0, elements, tag, subtag, bytes;
1741    LispObj header;
1742
1743    while (start < end) {
1744      header = *start;
1745      tag = fulltag_of(header);
1746   
1747      if ((nodeheader_tag_p(tag)) ||
1748          (immheader_tag_p(tag))) {
1749        elements = header_element_count(header);
1750        if (nodeheader_tag_p(tag)) {
1751          start += ((elements+2) & ~1);
1752        } else {
1753          subtag = header_subtag(header);
1754
1755#ifdef PPC64
1756          switch(fulltag_of(header)) {
1757          case ivector_class_64_bit:
1758            bytes = 8 + (elements<<3);
1759            break;
1760          case ivector_class_32_bit:
1761            bytes = 8 + (elements<<2);
1762            break;
1763          case ivector_class_8_bit:
1764            bytes = 8 + elements;
1765            break;
1766          case ivector_class_other_bit:
1767          default:
1768            if (subtag == subtag_bit_vector) {
1769              bytes = 8 + ((elements+7)>>3);
1770            } else {
1771              bytes = 8 + (elements<<1);
1772            }
1773          }
1774#else
1775          if (subtag <= max_32_bit_ivector_subtag) {
1776            bytes = 4 + (elements<<2);
1777          } else if (subtag <= max_8_bit_ivector_subtag) {
1778            bytes = 4 + elements;
1779          } else if (subtag <= max_16_bit_ivector_subtag) {
1780            bytes = 4 + (elements<<1);
1781          } else if (subtag == subtag_double_float_vector) {
1782            bytes = 8 + (elements<<3);
1783          } else {
1784            bytes = 4 + ((elements+7)>>3);
1785          }
1786#endif
1787
1788
1789          bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1790          total += bytes;
1791          start += (bytes >> node_shift);
1792        }
1793      } else {
1794        start += 2;
1795      }
1796    }
1797    return total;
1798  }
1799
1800
1801  /*
1802     This assumes that it's getting called with an ivector
1803     argument and that there's room for the object in the
1804     destination area.
1805  */
1806
1807
1808LispObj
1809purify_displaced_object(LispObj obj, area *dest, natural disp)
1810{
1811  BytePtr
1812    free = dest->active,
1813    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1814  LispObj
1815    header = header_of(obj), 
1816    new;
1817  natural
1818    start = (natural)old,
1819    physbytes;
1820
1821  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1822  dest->active += physbytes;
1823
1824  new = ptr_to_lispobj(free)+disp;
1825
1826  memcpy(free, (BytePtr)old, physbytes);
1827  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1828  /* Actually, it's best to always leave a trail, for two reasons.
1829     a) We may be walking the same heap that we're leaving forwaring
1830     pointers in, so we don't want garbage that we leave behind to
1831     look like a header.
1832     b) We'd like to be able to forward code-vector locatives, and
1833     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1834     pair at every doubleword in the old vector.
1835  */
1836  while(physbytes) {
1837    *old++ = (BytePtr) forward_marker;
1838    *old++ = (BytePtr) free;
1839    free += dnode_size;
1840    physbytes -= dnode_size;
1841  }
1842  return new;
1843}
1844
1845LispObj
1846purify_object(LispObj obj, area *dest)
1847{
1848  return purify_displaced_object(obj, dest, fulltag_of(obj));
1849}
1850
1851
1852
1853void
1854copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1855{
1856  LispObj obj = *ref, header;
1857  natural tag = fulltag_of(obj), header_tag;
1858
1859  if ((tag == fulltag_misc) &&
1860      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1861      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1862    header = deref(obj, 0);
1863    if (header == forward_marker) { /* already copied */
1864      *ref = (untag(deref(obj,1)) + tag);
1865    } else {
1866      header_tag = fulltag_of(header);
1867      if (immheader_tag_p(header_tag)) {
1868        if (header_subtag(header) != subtag_macptr) {
1869          *ref = purify_object(obj, dest);
1870        }
1871      }
1872    }
1873  }
1874}
1875
1876void
1877purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to)
1878{
1879#ifdef PPC
1880  LispObj
1881    loc = *locaddr,
1882    *headerP;
1883  opcode
1884    *p,
1885    insn;
1886  natural
1887    tag = fulltag_of(loc);
1888
1889  if (((BytePtr)ptr_from_lispobj(loc) > low) &&
1890      ((BytePtr)ptr_from_lispobj(loc) < high)) {
1891
1892    headerP = (LispObj *)ptr_from_lispobj(untag(loc));
1893    switch (tag) {
1894    case fulltag_even_fixnum:
1895    case fulltag_odd_fixnum:
1896#ifdef PPC64
1897    case fulltag_cons:
1898    case fulltag_misc:
1899#endif
1900      if (*headerP == forward_marker) {
1901        *locaddr = (headerP[1]+tag);
1902      } else {
1903        /* Grovel backwards until the header's found; copy
1904           the code vector to to space, then treat it as if it
1905           hasn't already been copied. */
1906        p = (opcode *)headerP;
1907        do {
1908          p -= 2;
1909          tag += 8;
1910          insn = *p;
1911#ifdef PPC64
1912        } while (insn != PPC64_CODE_VECTOR_PREFIX);
1913        headerP = ((LispObj*)p)-1;
1914        *locaddr = purify_displaced_object(((LispObj)headerP), to, tag);
1915#else
1916      } while ((insn & code_header_mask) != subtag_code_vector);
1917      *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag);
1918#endif
1919    }
1920    break;
1921
1922#ifndef PPC64
1923  case fulltag_misc:
1924    copy_ivector_reference(locaddr, low, high, to);
1925    break;
1926#endif
1927  }
1928}
1929#endif
1930}
1931
1932void
1933purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1934{
1935  LispObj header;
1936  unsigned tag;
1937
1938  while (start < end) {
1939    header = *start;
1940    if (header == forward_marker) {
1941      start += 2;
1942    } else {
1943      tag = fulltag_of(header);
1944      if (immheader_tag_p(tag)) {
1945        start = (LispObj *)skip_over_ivector((natural)start, header);
1946      } else {
1947        if (!nodeheader_tag_p(tag)) {
1948          copy_ivector_reference(start, low, high, to);
1949        }
1950        start++;
1951        copy_ivector_reference(start, low, high, to);
1952        start++;
1953      }
1954    }
1955  }
1956}
1957       
1958/* Purify references from tstack areas */
1959void
1960purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
1961{
1962  LispObj
1963    *current,
1964    *next,
1965    *start = (LispObj *) (a->active),
1966    *end = start,
1967    *limit = (LispObj *) (a->high);
1968
1969  for (current = start;
1970       end != limit;
1971       current = next) {
1972    next = (LispObj *) ptr_from_lispobj(*current);
1973    end = ((next >= start) && (next < limit)) ? next : limit;
1974    if (current[1] == 0) {
1975      purify_range(current+2, end, low, high, to);
1976    }
1977  }
1978}
1979
1980/* Purify a vstack area */
1981void
1982purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
1983{
1984  LispObj
1985    *p = (LispObj *) a->active,
1986    *q = (LispObj *) a->high;
1987
1988  if (((natural)p) & sizeof(natural)) {
1989    copy_ivector_reference(p, low, high, to);
1990    p++;
1991  }
1992  purify_range(p, q, low, high, to);
1993}
1994
1995
1996void
1997purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to)
1998{
1999  BytePtr
2000    current,
2001    next,
2002    limit = a->high;
2003
2004  for (current = a->active; current != limit; current = next) {
2005    next = *((BytePtr *)current);
2006    if (next == NULL) break;
2007    if (((next - current) == sizeof(lisp_frame)) && 
2008        (((((lisp_frame *)current)->savefn) == 0) ||
2009         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
2010      purify_locref(&((lisp_frame *) current)->savelr, low, high, to);
2011    } else {
2012      /* Clear low bits of "next", just in case */
2013      next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1));
2014    }
2015  }
2016}
2017
2018void
2019purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
2020{
2021  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
2022
2023  int r;
2024
2025  /* registers >= fn should be treated as roots.
2026     The PC, LR, loc_pc, and CTR should be treated as "locatives".
2027   */
2028
2029  for (r = fn; r < 32; r++) {
2030    copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to);
2031  };
2032
2033  purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to);
2034
2035  purify_locref((LispObj*) (&(xpPC(xp))), low, high, to);
2036  purify_locref((LispObj*) (&(xpLR(xp))), low, high, to);
2037  purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to);
2038}
2039
2040void
2041purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
2042{
2043  natural n = tcr->tlb_limit;
2044  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2045
2046  purify_range(start, end, low, high, to);
2047}
2048
2049void
2050purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
2051{
2052  xframe_list *xframes;
2053  ExceptionInformation *xp;
2054 
2055  xp = tcr->gc_context;
2056  if (xp) {
2057    purify_xp(xp, low, high, to);
2058  }
2059
2060  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2061    purify_xp(xframes->curr, low, high, to);
2062  }
2063}
2064
2065void
2066purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
2067{
2068  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2069
2070  while ((*prev) != (LispObj)NULL) {
2071    copy_ivector_reference(prev, low, high, to);
2072    next = *prev;
2073    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2074  }
2075}
2076
2077
2078void
2079purify_areas(BytePtr low, BytePtr high, area *target)
2080{
2081  area *next_area;
2082  area_code code;
2083     
2084  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2085    switch (code) {
2086    case AREA_TSTACK:
2087      purify_tstack_area(next_area, low, high, target);
2088      break;
2089     
2090    case AREA_VSTACK:
2091      purify_vstack_area(next_area, low, high, target);
2092      break;
2093     
2094    case AREA_CSTACK:
2095      purify_cstack_area(next_area, low, high, target);
2096      break;
2097     
2098    case AREA_STATIC:
2099    case AREA_DYNAMIC:
2100      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
2101      break;
2102     
2103    default:
2104      break;
2105    }
2106  }
2107}
2108
2109/*
2110  So far, this is mostly for save_application's benefit.
2111  We -should- be able to return to lisp code after doing this,
2112  however.
2113
2114*/
2115
2116
2117signed_natural
2118purify(TCR *tcr, signed_natural param)
2119{
2120  extern area *extend_readonly_area(unsigned);
2121  area
2122    *a = active_dynamic_area,
2123    *new_pure_area;
2124
2125  TCR  *other_tcr;
2126  natural max_pure_size;
2127  BytePtr new_pure_start;
2128
2129
2130  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
2131                                         (LispObj *) a->active);
2132  new_pure_area = extend_readonly_area(max_pure_size);
2133  if (new_pure_area) {
2134    new_pure_start = new_pure_area->active;
2135    lisp_global(IN_GC) = (1<<fixnumshift);
2136
2137   
2138    purify_areas(a->low, a->active, new_pure_area);
2139   
2140    other_tcr = tcr;
2141    do {
2142      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
2143      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
2144      other_tcr = other_tcr->next;
2145    } while (other_tcr != tcr);
2146
2147    purify_gcable_ptrs(a->low, a->active, new_pure_area);
2148
2149    {
2150      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2151      if (puresize != 0) {
2152        xMakeDataExecutable(new_pure_start, puresize);
2153 
2154      }
2155    }
2156    ProtectMemory(new_pure_area->low,
2157                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2158                                      log2_page_size));
2159    lisp_global(IN_GC) = 0;
2160    just_purified_p = true;
2161    return 0;
2162  }
2163  return -1;
2164}
2165
2166void
2167impurify_locref(LispObj *p, LispObj low, LispObj high, int delta)
2168{
2169  LispObj q = *p;
2170 
2171  switch (fulltag_of(q)) {
2172#ifdef PPC64
2173  case fulltag_cons:
2174#endif
2175  case fulltag_misc:
2176  case fulltag_even_fixnum:
2177  case fulltag_odd_fixnum:
2178    if ((q >= low) && (q < high)) {
2179      *p = (q+delta);
2180    }
2181  }
2182}
2183
2184 
2185void
2186impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2187{
2188  LispObj q = *p;
2189 
2190  if ((fulltag_of(q) == fulltag_misc) &&
2191      (q >= low) && 
2192      (q < high)) {
2193    *p = (q+delta);
2194  }
2195}
2196 
2197
2198#ifdef PPC
2199void
2200impurify_cstack_area(area *a, LispObj low, LispObj high, int delta)
2201{
2202  BytePtr
2203    current,
2204    next,
2205    limit = a->high;
2206
2207  for (current = a->active; current != limit; current = next) {
2208    next = *((BytePtr *)current);
2209    if (next == NULL) break;
2210    if (((next - current) == sizeof(lisp_frame)) && 
2211        (((((lisp_frame *)current)->savefn) == 0) ||
2212         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
2213      impurify_locref(&((lisp_frame *) current)->savelr, low, high, delta);
2214    } else {
2215      /* Clear low bits of "next", just in case */
2216      next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1));
2217    }
2218  }
2219}
2220#endif
2221
2222void
2223impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
2224{
2225  natural *regs = (natural *) xpGPRvector(xp);
2226
2227#ifdef PPC
2228  int r;
2229  /* registers >= fn should be treated as roots.
2230     The PC, LR, loc_pc, and CTR should be treated as "locatives".
2231   */
2232
2233  for (r = fn; r < 32; r++) {
2234    impurify_noderef((LispObj*) (&(regs[r])), low, high, delta);
2235  };
2236
2237  impurify_locref((LispObj*) (&(regs[loc_pc])), low, high, delta);
2238
2239  impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta);
2240  impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta);
2241  impurify_locref((LispObj*) (&(xpCTR(xp))), low, high, delta);
2242#endif
2243
2244}
2245
2246
2247void
2248impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
2249{
2250  LispObj header;
2251  unsigned tag;
2252
2253  while (start < end) {
2254    header = *start;
2255    tag = fulltag_of(header);
2256    if (immheader_tag_p(tag)) {
2257      start = (LispObj *)skip_over_ivector((natural)start, header);
2258    } else {
2259      if (!nodeheader_tag_p(tag)) {
2260        impurify_noderef(start, low, high, delta);
2261        }
2262      start++;
2263      impurify_noderef(start, low, high, delta);
2264      start++;
2265    }
2266  }
2267}
2268
2269
2270
2271
2272void
2273impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
2274{
2275  unsigned n = tcr->tlb_limit;
2276  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2277 
2278  impurify_range(start, end, low, high, delta);
2279}
2280
2281void
2282impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
2283{
2284  xframe_list *xframes;
2285  ExceptionInformation *xp;
2286 
2287  xp = tcr->gc_context;
2288  if (xp) {
2289    impurify_xp(xp, low, high, delta);
2290  }
2291
2292  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2293    impurify_xp(xframes->curr, low, high, delta);
2294  }
2295}
2296
2297void
2298impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
2299{
2300  LispObj
2301    *current,
2302    *next,
2303    *start = (LispObj *) (a->active),
2304    *end = start,
2305    *limit = (LispObj *) (a->high);
2306
2307  for (current = start;
2308       end != limit;
2309       current = next) {
2310    next = (LispObj *) ptr_from_lispobj(*current);
2311    end = ((next >= start) && (next < limit)) ? next : limit;
2312    if (current[1] == 0) {
2313      impurify_range(current+2, end, low, high, delta);
2314    }
2315  }
2316}
2317void
2318impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
2319{
2320  LispObj
2321    *p = (LispObj *) a->active,
2322    *q = (LispObj *) a->high;
2323
2324  if (((natural)p) & sizeof(natural)) {
2325    impurify_noderef(p, low, high, delta);
2326    p++;
2327  }
2328  impurify_range(p, q, low, high, delta);
2329}
2330
2331
2332void
2333impurify_areas(LispObj low, LispObj high, int delta)
2334{
2335  area *next_area;
2336  area_code code;
2337     
2338  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2339    switch (code) {
2340    case AREA_TSTACK:
2341      impurify_tstack_area(next_area, low, high, delta);
2342      break;
2343     
2344    case AREA_VSTACK:
2345      impurify_vstack_area(next_area, low, high, delta);
2346      break;
2347     
2348    case AREA_CSTACK:
2349#ifdef PPC
2350      impurify_cstack_area(next_area, low, high, delta);
2351#endif
2352      break;
2353     
2354    case AREA_STATIC:
2355    case AREA_DYNAMIC:
2356      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2357      break;
2358     
2359    default:
2360      break;
2361    }
2362  }
2363}
2364
2365void
2366impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2367{
2368  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2369
2370  while ((*prev) != (LispObj)NULL) {
2371    impurify_noderef(prev, low, high, delta);
2372    next = *prev;
2373    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2374  }
2375}
2376
2377signed_natural
2378impurify(TCR *tcr, signed_natural param)
2379{
2380  area *r = readonly_area;
2381
2382  if (r) {
2383    area *a = active_dynamic_area;
2384    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2385      oldhigh = a->high, newhigh; 
2386    unsigned n = ro_limit - ro_base;
2387    int delta = oldfree-ro_base;
2388    TCR *other_tcr;
2389
2390    if (n) {
2391      lisp_global(IN_GC) = 1;
2392      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2393                                               log2_heap_segment_size));
2394      if (newhigh > oldhigh) {
2395        grow_dynamic_area(newhigh-oldhigh);
2396      }
2397      a->active += n;
2398      memmove(oldfree, ro_base, n);
2399      munmap(ro_base, n);
2400      a->ndnodes = area_dnode(a, a->active);
2401      pure_space_active = r->active = r->low;
2402      r->ndnodes = 0;
2403
2404      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2405
2406      other_tcr = tcr;
2407      do {
2408        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2409        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2410        other_tcr = other_tcr->next;
2411      } while (other_tcr != tcr);
2412
2413      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2414      lisp_global(IN_GC) = 0;
2415    }
2416    return 0;
2417  }
2418  return -1;
2419}
2420
Note: See TracBrowser for help on using the repository browser.