source: branches/working-0711/ccl/lisp-kernel/x86-gc.c @ 7673

Last change on this file since 7673 was 7673, checked in by gb, 14 years ago

Try not to lose it when marking partly-initialized function-vectors.

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