source: trunk/ccl/lisp-kernel/x86-gc.c @ 7824

Last change on this file since 7824 was 7824, checked in by gb, 13 years ago

Use commas when printing bytes allocated/freed in GC messages; try to
make fields in before/after GC messages line up.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 111.9 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
53void
54comma_output_decimal(char *buf, int len, natural n) 
55{
56  int nout = 0;
57
58  buf[--len] = 0;
59  do {
60    buf[--len] = n%10+'0';
61    n = n/10;
62    if (n == 0) {
63      while (len) {
64        buf[--len] = ' ';
65      }
66      return;
67    }
68    if (len == 0) return;
69    nout ++;
70    if (nout == 3) {
71      buf[--len] = ',';
72      nout = 0;
73    }
74  } while (len >= 0);
75}
76
77/* Heap sanity checking. */
78
79void
80check_node(LispObj n)
81{
82  int tag = fulltag_of(n), header_tag;
83  area *a;
84  LispObj header;
85
86  if (n == (n & 0xff)) {
87    return;
88  }
89
90  switch (tag) {
91  case fulltag_even_fixnum:
92  case fulltag_odd_fixnum:
93  case fulltag_imm_0:
94  case fulltag_imm_1:
95    return;
96
97  case fulltag_nil:
98    if (n != lisp_nil) {
99      Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n);
100    }
101    return;
102
103
104  case fulltag_nodeheader_0: 
105  case fulltag_nodeheader_1: 
106  case fulltag_immheader_0: 
107  case fulltag_immheader_1: 
108  case fulltag_immheader_2: 
109    Bug(NULL, "Header not expected : 0x%lx", n);
110    return;
111
112  case fulltag_tra_0:
113  case fulltag_tra_1:
114    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
115    if (a == NULL) {
116      a = active_dynamic_area;
117      if ((n > (ptr_to_lispobj(a->active))) &&
118          (n < (ptr_to_lispobj(a->high)))) {
119        Bug(NULL, "TRA points to heap free space: 0x%lx", n);
120      }
121      return;
122    }
123    /* tra points into the heap.  Check displacement, then
124       check the function it (should) identify.
125    */
126    {
127      int disp = 0;
128      LispObj m = n;
129
130      if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
131          (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
132        disp = (*(int *) (n+3));
133        n = RECOVER_FN_FROM_RIP_LENGTH+m+disp;
134      }
135      if ((disp == 0) ||
136          (fulltag_of(n) != fulltag_function) ||
137          (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) {
138        Bug(NULL, "TRA at 0x%lx has bad displacement %d\n", n, disp);
139      }
140    }
141    /* Otherwise, fall through and check the header on the function
142       that the tra references */
143
144  case fulltag_misc:
145  case fulltag_cons:
146  case fulltag_symbol:
147  case fulltag_function:
148    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
149   
150    if (a == NULL) {
151      /* Can't do as much sanity checking as we'd like to
152         if object is a defunct stack-consed object.
153         If a dangling reference to the heap, that's
154         bad .. */
155      a = active_dynamic_area;
156      if ((n > (ptr_to_lispobj(a->active))) &&
157          (n < (ptr_to_lispobj(a->high)))) {
158        Bug(NULL, "Node points to heap free space: 0x%lx", n);
159      }
160      return;
161    }
162    break;
163  }
164  /* Node points to heap area, so check header/lack thereof. */
165  header = header_of(n);
166  header_tag = fulltag_of(header);
167  if (tag == fulltag_cons) {
168    if ((nodeheader_tag_p(header_tag)) ||
169        (immheader_tag_p(header_tag))) {
170      Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header);
171    }
172    return;
173  }
174
175  if ((!nodeheader_tag_p(header_tag)) &&
176      (!immheader_tag_p(header_tag))) {
177    Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header);
178  }
179  return;
180}
181
182void
183check_all_mark_bits(LispObj *nodepointer) 
184{
185}
186
187
188Boolean GCDebug = false, GCverbose = false;
189
190
191
192void
193check_range(LispObj *start, LispObj *end, Boolean header_allowed)
194{
195  LispObj node, *current = start, *prev;
196  int tag;
197  natural elements;
198
199  while (current < end) {
200    prev = current;
201    node = *current++;
202    tag = fulltag_of(node);
203    if (immheader_tag_p(tag)) {
204      if (! header_allowed) {
205        Bug(NULL, "Header not expected at 0x%lx\n", prev);
206      }
207      current = (LispObj *)skip_over_ivector((natural)prev, node);
208    } else if (nodeheader_tag_p(tag)) {
209      if (! header_allowed) {
210        Bug(NULL, "Header not expected at 0x%lx\n", prev);
211      }
212      elements = header_element_count(node) | 1;
213      if (header_subtag(node) == subtag_function) {
214        int skip = *(int *)current;
215        current += skip;
216        elements -= skip;
217      }
218      while (elements--) {
219        check_node(*current++);
220      }
221    } else {
222      check_node(node);
223      check_node(*current++);
224    }
225  }
226
227  if (current != end) {
228    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
229        start, end, prev, current);
230  }
231}
232
233void
234check_all_areas()
235{
236  area *a = active_dynamic_area;
237  area_code code = a->code;
238
239  while (code != AREA_VOID) {
240    switch (code) {
241    case AREA_DYNAMIC:
242    case AREA_STATIC:
243    case AREA_MANAGED_STATIC:
244      check_range((LispObj *)a->low, (LispObj *)a->active, true);
245      break;
246
247    case AREA_VSTACK:
248      {
249        LispObj* low = (LispObj *)a->active;
250        LispObj* high = (LispObj *)a->high;
251       
252        if (((natural)low) & node_size) {
253          check_node(*low++);
254        }
255        check_range(low, high, false);
256      }
257      break;
258
259    case AREA_TSTACK:
260      {
261        LispObj *current, *next,
262                *start = (LispObj *) a->active,
263                *end = start,
264                *limit = (LispObj *) a->high;
265                 
266        for (current = start;
267             end != limit;
268             current = next) {
269          next = ptr_from_lispobj(*current);
270          end = ((next >= start) && (next < limit)) ? next : limit;
271          check_range(current+2, end, true);
272        }
273      }
274      break;
275    }
276    a = a->succ;
277    code = (a->code);
278  }
279}
280
281natural
282static_dnodes_for_area(area *a)
283{
284  if (a->low == tenured_area->low) {
285    return tenured_area->static_dnodes;
286  }
287  return 0;
288}
289
290
291
292
293
294
295
296bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
297LispObj GCarealow, GCareadynamiclow;
298natural GCndnodes_in_area, GCndynamic_dnodes_in_area;
299LispObj GCweakvll = (LispObj)NULL;
300LispObj GCephemeral_low;
301natural GCn_ephemeral_dnodes;
302
303
304/* Sooner or later, this probably wants to be in assembler */
305/* Return false if n is definitely not an ephemeral node, true if
306   it might be */
307void
308mark_root(LispObj n)
309{
310  int tag_n = fulltag_of(n);
311  natural dnode, bits, *bitsp, mask;
312
313  if (!is_node_fulltag(tag_n)) {
314    return;
315  }
316
317  if (tag_of(n) == tag_tra) {
318    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
319        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
320      int sdisp = (*(int *) (n+3));
321      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
322      tag_n = fulltag_function;
323    }
324    else {
325      return;
326    }
327  }
328
329
330  dnode = gc_area_dnode(n);
331  if (dnode >= GCndnodes_in_area) {
332    return;
333  }
334  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
335  if (bits & mask) {
336    return;
337  }
338  *bitsp = (bits | mask);
339
340  if (tag_n == fulltag_cons) {
341    cons *c = (cons *) ptr_from_lispobj(untag(n));
342
343    rmark(c->car);
344    rmark(c->cdr);
345    return;
346  }
347  {
348    LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
349    natural
350      header = *((natural *) base),
351      subtag = header_subtag(header),
352      element_count = header_element_count(header),
353      total_size_in_bytes,      /* including 4/8-byte header */
354      suffix_dnodes;
355    natural prefix_nodes = 0;
356
357    tag_n = fulltag_of(header);
358
359
360    if ((nodeheader_tag_p(tag_n)) ||
361        (tag_n == ivector_class_64_bit)) {
362      total_size_in_bytes = 8 + (element_count<<3);
363    } else if (tag_n == ivector_class_32_bit) {
364      total_size_in_bytes = 8 + (element_count<<2);
365    } else {
366      /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */
367      if (subtag == subtag_bit_vector) {
368        total_size_in_bytes = 8 + ((element_count+7)>>3);
369      } else if (subtag >= min_8_bit_ivector_subtag) {
370        total_size_in_bytes = 8 + element_count;
371      } else {
372        total_size_in_bytes = 8 + (element_count<<1);
373      }
374    }
375
376    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1;
377
378    if (suffix_dnodes) {
379      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
380    }
381
382    if (nodeheader_tag_p(tag_n)) {
383      if (subtag == subtag_hash_vector) {
384        /* Don't invalidate the cache here.  It should get
385           invalidated on the lisp side, if/when we know
386           that rehashing is necessary. */
387        LispObj flags = ((hash_table_vector_header *) base)->flags;
388
389        if (flags & nhash_weak_mask) {
390          ((hash_table_vector_header *) base)->cache_key = undefined;
391          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
392        }
393        deref(ptr_to_lispobj(base),1) = GCweakvll;
394        GCweakvll = n;
395        return;
396      }
397
398      if (subtag == subtag_pool) {
399        deref(ptr_to_lispobj(base), 1) = lisp_nil;
400      }
401     
402      if (subtag == subtag_weak) {
403        natural weak_type = (natural) base[2];
404        if (weak_type >> population_termination_bit) {
405          element_count -= 2;
406        } else {
407          element_count -= 1;
408        }
409      }
410
411      if (subtag == subtag_function) {
412        prefix_nodes = (natural) ((int) deref(base,1));
413        if (prefix_nodes > element_count) {
414          Bug(NULL, "Function 0x%lx trashed",n);
415        }
416      }
417      base += (1+element_count);
418
419      element_count -= prefix_nodes;
420
421      while(element_count--) {
422        rmark(*--base);
423      }
424      if (subtag == subtag_weak) {
425        deref(ptr_to_lispobj(base),1) = GCweakvll;
426        GCweakvll = n;
427      }
428    }
429  }
430}
431
432
433/*
434  This marks the node if it needs to; it returns true if the node
435  is either a hash table vector header or a cons/misc-tagged pointer
436  to ephemeral space.
437  Note that it  might be a pointer to ephemeral space even if it's
438  not pointing to the current generation.
439*/
440
441Boolean
442mark_ephemeral_root(LispObj n)
443{
444  int tag_n = fulltag_of(n);
445  natural eph_dnode;
446
447  if (nodeheader_tag_p(tag_n)) {
448    return (header_subtag(n) == subtag_hash_vector);
449  }
450 
451  if (is_node_fulltag (tag_n)) {
452    eph_dnode = area_dnode(n, GCephemeral_low);
453    if (eph_dnode < GCn_ephemeral_dnodes) {
454      mark_root(n);             /* May or may not mark it */
455      return true;              /* but return true 'cause it's an ephemeral node */
456    }
457  }
458  return false;                 /* Not a heap pointer or not ephemeral */
459}
460 
461
462
463#ifdef X8664
464#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */
465#define RMARK_PREV_CAR fulltag_nil /* fulltag_nil + node_size. Coincidence ? I think not. */
466#else
467#endif
468
469natural
470GCstack_limit = 0;
471
472
473/*
474  This wants to be in assembler even more than "mark_root" does.
475  For now, it does link-inversion: hard as that is to express in C,
476  reliable stack-overflow detection may be even harder ...
477*/
478void
479rmark(LispObj n)
480{
481  int tag_n = fulltag_of(n);
482  bitvector markbits = GCmarkbits;
483  natural dnode, bits, *bitsp, mask, original_n = n;
484
485  if (!is_node_fulltag(tag_n)) {
486    return;
487  }
488
489  if (tag_of(n) == tag_tra) {
490    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
491        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
492      int sdisp = (*(int *) (n+3));
493      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
494      tag_n = fulltag_function;
495    } else {
496      return;
497    }
498  }
499
500  dnode = gc_area_dnode(n);
501  if (dnode >= GCndnodes_in_area) {
502    return;
503  }
504  set_bits_vars(markbits,dnode,bitsp,bits,mask);
505  if (bits & mask) {
506    return;
507  }
508  *bitsp = (bits | mask);
509
510  if (current_stack_pointer() > GCstack_limit) {
511    if (tag_n == fulltag_cons) {
512      rmark(deref(n,1));
513      rmark(deref(n,0));
514    } else {
515      LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
516      natural
517        header = *((natural *) base),
518        subtag = header_subtag(header),
519        element_count = header_element_count(header),
520        total_size_in_bytes,
521        suffix_dnodes,
522        nmark;
523
524      tag_n = fulltag_of(header);
525
526      if ((nodeheader_tag_p(tag_n)) ||
527          (tag_n == ivector_class_64_bit)) {
528        total_size_in_bytes = 8 + (element_count<<3);
529      } else if (tag_n == ivector_class_32_bit) {
530        total_size_in_bytes = 8 + (element_count<<2);
531      } else {
532        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
533        if (subtag == subtag_bit_vector) {
534          total_size_in_bytes = 8 + ((element_count+7)>>3);
535        } else if (subtag >= min_8_bit_ivector_subtag) {
536          total_size_in_bytes = 8 + element_count;
537        } else {
538          total_size_in_bytes = 8 + (element_count<<1);
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_weak_mask) {
561          ((hash_table_vector_header *) base)->cache_key = undefined;
562          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
563        }
564        deref(ptr_to_lispobj(base),1) = GCweakvll;
565        GCweakvll = n;
566        return;
567      }
568
569      if (subtag == subtag_pool) {
570        deref(n, 1) = lisp_nil;
571      }
572
573      if (subtag == subtag_weak) {
574        natural weak_type = (natural) base[2];
575        if (weak_type >> population_termination_bit)
576          element_count -= 2;
577        else
578          element_count -= 1;
579      }
580
581      nmark = element_count;
582
583      if (subtag == subtag_function) {
584        if ((int)base[1] >= nmark) {
585          Bug(NULL,"Bad function at 0x%lx",n);
586        }
587        nmark -= (int)base[1];
588      }
589
590      while (nmark--) {
591        rmark(deref(n,element_count));
592        element_count--;
593      }
594
595      if (subtag == subtag_weak) {
596        deref(n, 1) = GCweakvll;
597        GCweakvll = n;
598      }
599
600    }
601  } else {
602
603    /* This is all a bit more complicated than the PPC version:
604
605       - a symbol-vector can be referenced via either a FULLTAG-MISC
606       pointer or a FULLTAG-SYMBOL pointer.  When we've finished
607       marking the symbol-vector's elements, we need to know which tag
608       the object that pointed to the symbol-vector had originally.
609
610       - a function-vector can be referenced via either a FULLTAG-MISC
611       pointer or a FULLTAG-FUNCTION pointer.  That introduces pretty
612       much the same set of issues, but ...
613
614       - a function-vector can also be referenced via a TRA; the
615       offset from the TRA to the function header is arbitrary (though
616       we can probably put an upper bound on it, and it's certainly
617       not going to be more than 32 bits.)
618
619       - function-vectors contain a mixture of code and constants,
620       with a "boundary" word (that doesn't look like a valid
621       constant) in between them.  There are 56 unused bits in the
622       boundary word; the low 8 bits must be = to the constant
623       'function_boundary_marker'.  We can store the byte displacement
624       from the address of the object which references the function
625       (tagged fulltag_misc, fulltag_function, or tra) to the address
626       of the boundary marker when the function vector is first marked
627       and recover that offset when we've finished marking the
628       function vector.  (Note that the offset is signed; it's
629       probably simplest to keep it in the high 32 bits of the
630       boundary word.)
631
632 So:
633
634       - while marking a CONS, the 'this' pointer as a 3-bit tag of
635       tag_list; the 4-bit fulltag indicates which cell is being
636       marked.
637
638       - while marking a gvector (other than a symbol-vector or
639       function-vector), the 'this' pointer is tagged tag_misc.
640       (Obviously, it alternates between fulltag_misc and
641       fulltag_nodeheader_0, arbitrarily.)  When we encounter the
642       gvector header when the 'this' pointer has been tagged as
643       fulltag_misc, we can restore 'this' to the header's address +
644       fulltag_misc and enter the 'climb' state.  (Note that this
645       value happens to be exactly what's in 'this' when the header's
646       encountered.)
647
648       - if we encounter a symbol-vector via the FULLTAG-MISC pointer
649       to the symbol (not very likely, but legal and possible), it's
650       treated exactly like the gvector case above.
651
652       - in the more likely case where a symbol-vector is referenced
653       via a FULLTAG-SYMBOL, we do the same loop as in the general
654       gvector case, backing up through the vector with 'this' tagged
655       as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter
656       the symbol header, 'this' gets fulltag_symbol added to the
657       dnode-aligned address of the header, and we climb.
658
659       - if anything (fulltag_misc, fulltag_function, tra) references
660       an unmarked function function vector, we store the byte offfset
661       from the tagged reference to the address of the boundary word
662       in the high 32 bits of the boundary word, then we back up
663       through the function-vector's constants, with 'this' tagged
664       tag_function/ fulltag_immheader_0, until the (specially-tagged)
665       boundary word is encountered.  The displacement stored in the boundary
666       word is added to the aligned address of the  boundary word (restoring
667       the original 'this' pointer, and we climb.
668
669       Not that bad.
670    */
671       
672    LispObj prev = undefined, this = n, next, *base;
673    natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary;
674
675    if (tag_n == fulltag_cons) goto MarkCons;
676    goto MarkVector;
677
678  ClimbCdr:
679    prev = deref(this,0);
680    deref(this,0) = next;
681
682  Climb:
683    next = this;
684    this = prev;
685    tag_n = fulltag_of(prev);
686    switch(tag_n) {
687    case tag_misc:
688    case fulltag_misc:
689    case tag_symbol:
690    case fulltag_symbol:
691    case tag_function:
692    case fulltag_function:
693      goto ClimbVector;
694
695    case RMARK_PREV_ROOT:
696      return;
697
698    case fulltag_cons:
699      goto ClimbCdr;
700
701    case RMARK_PREV_CAR:
702      goto ClimbCar;
703
704      /* default: abort() */
705    }
706
707  DescendCons:
708    prev = this;
709    this = next;
710
711  MarkCons:
712    next = deref(this,1);
713    this += node_size;
714    tag_n = fulltag_of(next);
715    if (!is_node_fulltag(tag_n)) goto MarkCdr;
716    dnode = gc_area_dnode(next);
717    if (dnode >= GCndnodes_in_area) goto MarkCdr;
718    set_bits_vars(markbits,dnode,bitsp,bits,mask);
719    if (bits & mask) goto MarkCdr;
720    *bitsp = (bits | mask);
721    deref(this,1) = prev;
722    if (tag_n == fulltag_cons) goto DescendCons;
723    goto DescendVector;
724
725  ClimbCar:
726    prev = deref(this,1);
727    deref(this,1) = next;
728
729  MarkCdr:
730    next = deref(this, 0);
731    this -= node_size;
732    tag_n = fulltag_of(next);
733    if (!is_node_fulltag(tag_n)) goto Climb;
734    dnode = gc_area_dnode(next);
735    if (dnode >= GCndnodes_in_area) goto Climb;
736    set_bits_vars(markbits,dnode,bitsp,bits,mask);
737    if (bits & mask) goto Climb;
738    *bitsp = (bits | mask);
739    deref(this, 0) = prev;
740    if (tag_n == fulltag_cons) goto DescendCons;
741    /* goto DescendVector; */
742
743  DescendVector:
744    prev = this;
745    this = next;
746
747  MarkVector:
748    if ((tag_n == fulltag_tra_0) ||
749        (tag_n == fulltag_tra_1)) {
750      int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH;
751
752      base = (LispObj *) (untag(n-disp));
753      header = *((natural *) base);
754      subtag = header_subtag(header);
755      boundary = base + (int)(base[1]);
756      (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
757      this = (LispObj)(base)+fulltag_function;
758      /* Need to set the initial markbit here */
759      dnode = gc_area_dnode(this);
760      set_bit(markbits,dnode);
761    } else {
762      base = (LispObj *) ptr_from_lispobj(untag(this));
763      header = *((natural *) base);
764      subtag = header_subtag(header);
765      if (subtag == subtag_function) {
766        boundary = base + (int)(base[1]);
767        (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
768      }
769    }
770    element_count = header_element_count(header);
771    tag_n = fulltag_of(header);
772
773    if ((nodeheader_tag_p(tag_n)) ||
774        (tag_n == ivector_class_64_bit)) {
775      total_size_in_bytes = 8 + (element_count<<3);
776    } else if (tag_n == ivector_class_32_bit) {
777      total_size_in_bytes = 8 + (element_count<<2);
778    } else {
779      /* ivector_class_other_bit contains 16-bit arrays & bitvector */
780      if (subtag == subtag_bit_vector) {
781        total_size_in_bytes = 8 + ((element_count+7)>>3);
782      } else if (subtag >= min_8_bit_ivector_subtag) {
783        total_size_in_bytes = 8 + element_count;
784      } else {
785        total_size_in_bytes = 8 + (element_count<<1);
786      }
787    }
788    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
789   
790    if (suffix_dnodes) {
791      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
792    }
793   
794    if (!nodeheader_tag_p(tag_n)) goto Climb;
795   
796    if (subtag == subtag_hash_vector) {
797      /* Splice onto weakvll, then climb */
798      LispObj flags = ((hash_table_vector_header *) base)->flags;
799     
800      if (flags & nhash_weak_mask) {
801        ((hash_table_vector_header *) base)->cache_key = undefined;
802        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
803      }
804
805      deref(ptr_to_lispobj(base),1) = GCweakvll;
806      GCweakvll = this;
807      goto Climb;
808    }
809
810    if (subtag == subtag_pool) {
811      deref(this, 1) = lisp_nil;
812    }
813
814    if (subtag == subtag_weak) {
815      natural weak_type = (natural) base[2];
816      if (weak_type >> population_termination_bit)
817        element_count -= 2;
818      else
819        element_count -= 1;
820    }
821
822    this = (LispObj)(base) + (tag_of(this))  + ((element_count+1) << node_shift);
823    goto MarkVectorLoop;
824
825  ClimbVector:
826    prev = indirect_node(this);
827    indirect_node(this) = next;
828
829  MarkVectorLoop:
830    this -= node_size;
831    next = indirect_node(this);
832    if ((tag_of(this) == tag_function) &&
833        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
834    tag_n = fulltag_of(next);
835    if (nodeheader_tag_p(tag_n)) goto MarkVectorDone;
836    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
837    dnode = gc_area_dnode(next);
838    if (dnode >= GCndnodes_in_area) goto MarkVectorLoop;
839    set_bits_vars(markbits,dnode,bitsp,bits,mask);
840    if (bits & mask) goto MarkVectorLoop;
841    *bitsp = (bits | mask);
842    indirect_node(this) = prev;
843    if (tag_n == fulltag_cons) goto DescendCons;
844    goto DescendVector;
845
846  MarkVectorDone:
847    /* "next" is vector header; "this" tagged tag_misc or tag_symbol.
848       If  header subtag = subtag_weak_header, put it on weakvll */
849    this += node_size;          /* make it fulltag_misc/fulltag_symbol */
850
851    if (header_subtag(next) == subtag_weak) {
852      deref(this, 1) = GCweakvll;
853      GCweakvll = this;
854    }
855    goto Climb;
856
857  MarkFunctionDone:
858    boundary = (LispObj *)(node_aligned(this));
859    this = ((LispObj)boundary) + (((int *)boundary)[1]);
860    (((int *)boundary)[1]) = 0;
861    goto Climb;
862  }
863}
864
865LispObj *
866skip_over_ivector(natural start, LispObj header)
867{
868  natural
869    element_count = header_element_count(header),
870    subtag = header_subtag(header),
871    nbytes;
872
873
874
875  switch (fulltag_of(header)) {
876  case ivector_class_64_bit:
877    nbytes = element_count << 3;
878    break;
879  case ivector_class_32_bit:
880    nbytes = element_count << 2;
881    break;
882  case ivector_class_other_bit:
883  default:
884    if (subtag == subtag_bit_vector) {
885      nbytes = (element_count+7)>>3;
886    } else if (subtag >= min_8_bit_ivector_subtag) {
887      nbytes = element_count;
888    } else {
889      nbytes = element_count << 1;
890    }
891  }
892  return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15)));
893
894}
895
896
897void
898check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
899{
900  LispObj x1, *base = start, *prev = start;
901  int tag;
902  natural ref_dnode, node_dnode;
903  Boolean intergen_ref;
904
905  while (start < end) {
906    x1 = *start;
907    prev = start;
908    tag = fulltag_of(x1);
909    if (immheader_tag_p(tag)) {
910      start = skip_over_ivector(ptr_to_lispobj(start), x1);
911    } else {
912      if (header_subtag(x1) == subtag_function) {
913        int skip = (int) deref(start,1);
914        start += ((1+skip)&~1);
915        x1 = *start;
916        tag = fulltag_of(x1);
917      }
918      intergen_ref = false;
919      if (is_node_fulltag(tag)) {       
920        node_dnode = gc_area_dnode(x1);
921        if (node_dnode < GCndnodes_in_area) {
922          intergen_ref = true;
923        }
924      }
925      if (intergen_ref == false) {       
926        x1 = start[1];
927        tag = fulltag_of(x1);
928      if (is_node_fulltag(tag)) {       
929          node_dnode = gc_area_dnode(x1);
930          if (node_dnode < GCndnodes_in_area) {
931            intergen_ref = true;
932          }
933        }
934      }
935      if (intergen_ref) {
936        ref_dnode = area_dnode(start, base);
937        if (!ref_bit(refbits, ref_dnode)) {
938          Bug(NULL, "Missing memoization in doublenode at 0x%08X", start);
939          set_bit(refbits, ref_dnode);
940        }
941      }
942      start += 2;
943    }
944  }
945  if (start > end) {
946    Bug(NULL, "Overran end of range!");
947  }
948}
949
950
951
952void
953mark_memoized_area(area *a, natural num_memo_dnodes)
954{
955  bitvector refbits = a->refbits;
956  LispObj *p = (LispObj *) a->low, x1, x2;
957  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
958  Boolean keep_x1, keep_x2;
959
960  if (GCDebug) {
961    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
962  }
963
964  /* The distinction between "inbits" and "outbits" is supposed to help us
965     detect cases where "uninteresting" setfs have been memoized.  Storing
966     NIL, fixnums, immediates (characters, etc.) or node pointers to static
967     or readonly areas is definitely uninteresting, but other cases are
968     more complicated (and some of these cases are hard to detect.)
969
970     Some headers are "interesting", to the forwarder if not to us.
971
972     We -don't- give anything any weak treatment here.  Weak things have
973     to be seen by a full gc, for some value of 'full'.
974     */
975
976  /*
977    We need to ensure that there are no bits set at or beyond
978    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
979    tenures/untenures things.)  We find bits by grabbing a fullword at
980    a time and doing a cntlzw instruction; and don't want to have to
981    check for (< memo_dnode num_memo_dnodes) in the loop.
982    */
983
984  {
985    natural
986      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
987      index_of_last_word = (num_memo_dnodes >> bitmap_shift);
988
989    if (bits_in_last_word != 0) {
990      natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L);
991      refbits[index_of_last_word] &= mask;
992    }
993  }
994       
995  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
996  inbits = outbits = bits;
997  while (memo_dnode < num_memo_dnodes) {
998    if (bits == 0) {
999      int remain = nbits_in_word - bitidx;
1000      memo_dnode += remain;
1001      p += (remain+remain);
1002      if (outbits != inbits) {
1003        *bitsp = outbits;
1004      }
1005      bits = *++bitsp;
1006      inbits = outbits = bits;
1007      bitidx = 0;
1008    } else {
1009      nextbit = count_leading_zeros(bits);
1010      if ((diff = (nextbit - bitidx)) != 0) {
1011        memo_dnode += diff;
1012        bitidx = nextbit;
1013        p += (diff+diff);
1014      }
1015      x1 = *p++;
1016      x2 = *p++;
1017      bits &= ~(BIT0_MASK >> bitidx);
1018      keep_x1 = mark_ephemeral_root(x1);
1019      keep_x2 = mark_ephemeral_root(x2);
1020      if ((keep_x1 == false) && 
1021          (keep_x2 == false)) {
1022        outbits &= ~(BIT0_MASK >> bitidx);
1023      }
1024      memo_dnode++;
1025      bitidx++;
1026    }
1027  }
1028  if (GCDebug) {
1029    p = (LispObj *) a->low;
1030    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1031  }
1032}
1033
1034void
1035mark_headerless_area_range(LispObj *start, LispObj *end)
1036{
1037  while (start < end) {
1038    mark_root(*start++);
1039  }
1040}
1041
1042void
1043mark_simple_area_range(LispObj *start, LispObj *end)
1044{
1045  LispObj x1, *base;
1046  int tag;
1047
1048  while (start < end) {
1049    x1 = *start;
1050    tag = fulltag_of(x1);
1051    if (immheader_tag_p(tag)) {
1052      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
1053    } else if (!nodeheader_tag_p(tag)) {
1054      ++start;
1055      mark_root(x1);
1056      mark_root(*start++);
1057    } else {
1058      int subtag = header_subtag(x1);
1059      natural element_count = header_element_count(x1);
1060      natural size = (element_count+1 + 1) & ~1;
1061
1062      if (subtag == subtag_hash_vector) {
1063        LispObj flags = ((hash_table_vector_header *) start)->flags;
1064
1065        if (flags & nhash_weak_mask) {
1066          ((hash_table_vector_header *) start)->cache_key = undefined;
1067          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1068        }
1069
1070        start[1] = GCweakvll;
1071        GCweakvll = (LispObj) (((natural) start) + fulltag_misc);
1072      } else {
1073
1074        if (subtag == subtag_pool) {
1075          start[1] = lisp_nil;
1076        }
1077
1078        if (subtag == subtag_weak) {
1079          natural weak_type = (natural) start[2];
1080          if (weak_type >> population_termination_bit)
1081            element_count -= 2;
1082          else
1083            element_count -= 1; 
1084          start[1] = GCweakvll;
1085          GCweakvll = (LispObj) (((natural) start) + fulltag_misc);   
1086        }
1087
1088        base = start + element_count + 1;
1089        if (subtag == subtag_function) {
1090          element_count -= (int)start[1];
1091        }
1092        while(element_count--) {
1093          mark_root(*--base);
1094        }
1095      }
1096      start += size;
1097    }
1098  }
1099}
1100
1101
1102/* Mark a tstack area */
1103void
1104mark_tstack_area(area *a)
1105{
1106  LispObj
1107    *current,
1108    *next,
1109    *start = (LispObj *) (a->active),
1110    *end = start,
1111    *limit = (LispObj *) (a->high);
1112
1113  for (current = start;
1114       end != limit;
1115       current = next) {
1116    next = (LispObj *) ptr_from_lispobj(*current);
1117    end = ((next >= start) && (next < limit)) ? next : limit;
1118    mark_simple_area_range(current+2, end);
1119  }
1120}
1121
1122/*
1123  It's really important that headers never wind up in tagged registers.
1124  Those registers would (possibly) get pushed on the vstack and confuse
1125  the hell out of this routine.
1126
1127  vstacks are just treated as a "simple area range", possibly with
1128  an extra word at the top (where the area's active pointer points.)
1129  */
1130
1131void
1132mark_vstack_area(area *a)
1133{
1134  LispObj
1135    *start = (LispObj *) a->active,
1136    *end = (LispObj *) a->high;
1137
1138#if 0
1139  fprintf(stderr, "mark VSP range: 0x%lx:0x%lx\n", start, end);
1140#endif
1141  mark_headerless_area_range(start, end);
1142}
1143
1144
1145void
1146reapweakv(LispObj weakv)
1147{
1148  /*
1149    element 2 of the weak vector should be tagged as a cons: if it
1150    isn't, just mark it as a root.  if it is, cdr through it until a
1151    "marked" cons is encountered.  If the car of any unmarked cons is
1152    marked, mark the cons which contains it; otherwise, splice the
1153    cons out of the list.  N.B. : elements 0 and 1 are already marked
1154    (or are immediate, etc.)
1155  */
1156  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
1157  LispObj termination_list = lisp_nil;
1158  natural weak_type = (natural) deref(weakv,2);
1159  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
1160    terminatablep = ((weak_type >> population_termination_bit) != 0);
1161  Boolean done = false;
1162  cons *rawcons;
1163  natural dnode, car_dnode;
1164  bitvector markbits = GCmarkbits;
1165
1166  if (terminatablep) {
1167    termination_list = deref(weakv,1+3);
1168  }
1169
1170  if (fulltag_of(cell) != fulltag_cons) {
1171    mark_root(cell);
1172  } else if (alistp) {
1173    /* weak alist */
1174    while (! done) {
1175      dnode = gc_area_dnode(cell);
1176      if ((dnode >= GCndnodes_in_area) ||
1177          (ref_bit(markbits, dnode))) {
1178        done = true;
1179      } else {
1180        /* Cons cell is unmarked. */
1181        LispObj alist_cell, thecar;
1182        unsigned cell_tag;
1183
1184        rawcons = (cons *) ptr_from_lispobj(untag(cell));
1185        alist_cell = rawcons->car;
1186        cell_tag = fulltag_of(alist_cell);
1187
1188        if ((cell_tag == fulltag_cons) &&
1189            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
1190            (! ref_bit(markbits, car_dnode)) &&
1191            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
1192            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
1193            (! ref_bit(markbits, car_dnode))) {
1194          *prev = rawcons->cdr;
1195          if (terminatablep) {
1196            rawcons->cdr = termination_list;
1197            termination_list = cell;
1198          }
1199        } else {
1200          set_bit(markbits, dnode);
1201          prev = (LispObj *)(&(rawcons->cdr));
1202          mark_root(alist_cell);
1203        }
1204        cell = *prev;
1205      }
1206    }
1207  } else {
1208    /* weak list */
1209    while (! done) {
1210      dnode = gc_area_dnode(cell);
1211      if ((dnode >= GCndnodes_in_area) ||
1212          (ref_bit(markbits, dnode))) {
1213        done = true;
1214      } else {
1215        /* Cons cell is unmarked. */
1216        LispObj thecar;
1217        unsigned cartag;
1218
1219        rawcons = (cons *) ptr_from_lispobj(untag(cell));
1220        thecar = rawcons->car;
1221        cartag = fulltag_of(thecar);
1222
1223        if (is_node_fulltag(cartag) &&
1224            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
1225            (! ref_bit(markbits, car_dnode))) {
1226          *prev = rawcons->cdr;
1227          if (terminatablep) {
1228            rawcons->cdr = termination_list;
1229            termination_list = cell;
1230          }
1231        } else {
1232          set_bit(markbits, dnode);
1233          prev = (LispObj *)(&(rawcons->cdr));
1234        }
1235        cell = *prev;
1236      }
1237    }
1238  }
1239
1240  if (terminatablep) {
1241    deref(weakv,1+3) = termination_list;
1242    if (termination_list != lisp_nil) {
1243      deref(weakv,1) = GCweakvll;
1244      GCweakvll = weakv;
1245    }
1246  }
1247}
1248
1249/*
1250  Screw: doesn't deal with finalization.
1251  */
1252
1253void
1254reaphashv(LispObj hashv)
1255{
1256  hash_table_vector_header
1257    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
1258  natural
1259    dnode,
1260    npairs = (header_element_count(hashp->header) - 
1261              ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1;
1262  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
1263  Boolean
1264    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
1265  bitvector markbits = GCmarkbits;
1266  int tag;
1267
1268  while (npairs--) {
1269    if (weak_on_value) {
1270      weakelement = pairp[1];
1271    } else {
1272      weakelement = pairp[0];
1273    }
1274    tag = fulltag_of(weakelement);
1275    if (is_node_fulltag(tag)) {
1276      dnode = gc_area_dnode(weakelement);
1277      if ((dnode < GCndnodes_in_area) && 
1278          ! ref_bit(markbits, dnode)) {
1279        pairp[0] = slot_unbound;
1280        pairp[1] = lisp_nil;
1281        hashp->weak_deletions_count += (1<<fixnumshift);
1282      }
1283    }
1284    pairp += 2;
1285  }
1286}   
1287   
1288
1289
1290Boolean
1291mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
1292{
1293  natural flags = hashp->flags, key_dnode, val_dnode;
1294  Boolean
1295    marked_new = false, 
1296    key_marked,
1297    val_marked,
1298    weak_value = ((flags & nhash_weak_value_mask) != 0);
1299  int 
1300    skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1,
1301    key_tag,
1302    val_tag,
1303    i;
1304  LispObj
1305    *pairp = (LispObj*) (hashp+1),
1306    key,
1307    val;
1308
1309  /* Mark everything in the header */
1310 
1311  for (i = 2; i<= skip; i++) {
1312    mark_root(deref(ptr_to_lispobj(hashp),i));
1313  }
1314
1315  elements -= skip;
1316
1317  for (i = 0; i<elements; i+=2, pairp+=2) {
1318    key = pairp[0];
1319    val = pairp[1];
1320    key_marked = val_marked = true;
1321    key_tag = fulltag_of(key);
1322    val_tag = fulltag_of(val);
1323    if (is_node_fulltag(key_tag)) {
1324      key_dnode = gc_area_dnode(key);
1325      if ((key_dnode < GCndnodes_in_area) &&
1326          ! ref_bit(GCmarkbits,key_dnode)) {
1327        key_marked = false;
1328      }
1329    }
1330    if (is_node_fulltag(val_tag)) {
1331      val_dnode = gc_area_dnode(val);
1332      if ((val_dnode < GCndnodes_in_area) &&
1333          ! ref_bit(GCmarkbits,val_dnode)) {
1334        val_marked = false;
1335      }
1336    }
1337
1338    if (weak_value) {
1339      if (val_marked & !key_marked) {
1340        mark_root(key);
1341        marked_new = true;
1342      }
1343    } else {
1344      if (key_marked & !val_marked) {
1345        mark_root(val);
1346        marked_new = true;
1347      }
1348    }
1349  }
1350  return marked_new;
1351}
1352
1353
1354Boolean
1355mark_weak_alist(LispObj weak_alist, int weak_type)
1356{
1357  natural
1358    elements = header_element_count(header_of(weak_alist)),
1359    dnode;
1360  int pair_tag;
1361  Boolean marked_new = false;
1362  LispObj alist, pair, key, value;
1363  bitvector markbits = GCmarkbits;
1364
1365  if (weak_type >> population_termination_bit) {
1366    elements -= 1;
1367  }
1368  for(alist = deref(weak_alist, elements);
1369      (fulltag_of(alist) == fulltag_cons) &&
1370      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
1371      (! ref_bit(markbits,dnode));
1372      alist = cdr(alist)) {
1373    pair = car(alist);
1374    pair_tag = fulltag_of(pair);
1375    if ((is_node_fulltag(pair_tag)) &&
1376        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
1377        (! ref_bit(markbits,dnode))) {
1378      if (pair_tag == fulltag_cons) {
1379        key = car(pair);
1380        if ((! is_node_fulltag(fulltag_of(key))) ||
1381            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
1382            ref_bit(markbits,dnode)) {
1383          /* key is marked, mark value if necessary */
1384          value = cdr(pair);
1385          if (is_node_fulltag(fulltag_of(value)) &&
1386              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
1387              (! ref_bit(markbits,dnode))) {
1388            mark_root(value);
1389            marked_new = true;
1390          }
1391        }
1392      } else {
1393          mark_root(pair);
1394          marked_new = true;
1395      }
1396    }
1397  }
1398  return marked_new;
1399}
1400 
1401void
1402markhtabvs()
1403{
1404  LispObj this, header, pending;
1405  int subtag;
1406  bitvector markbits = GCmarkbits;
1407  hash_table_vector_header *hashp;
1408  Boolean marked_new;
1409
1410  do {
1411    pending = (LispObj) NULL;
1412    marked_new = false;
1413   
1414    while (GCweakvll) {
1415      this = GCweakvll;
1416      GCweakvll = deref(this,1);
1417     
1418      header = header_of(this);
1419      subtag = header_subtag(header);
1420     
1421      if (subtag == subtag_weak) {
1422        natural weak_type = deref(this,2);
1423        deref(this,1) = pending;
1424        pending = this;
1425        if ((weak_type & population_type_mask) == population_weak_alist) {
1426          if (mark_weak_alist(this, weak_type)) {
1427            marked_new = true;
1428          }
1429        }
1430      } else if (subtag == subtag_hash_vector) {
1431        natural elements = header_element_count(header), i;
1432
1433        hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this));
1434        if (hashp->flags & nhash_weak_mask) {
1435          deref(this,1) = pending;
1436          pending = this;
1437          if (mark_weak_hash_vector(hashp, elements)) {
1438            marked_new = true;
1439          }
1440        } else {
1441          deref(this,1) = (LispObj)NULL;
1442          for (i = 2; i <= elements; i++) {
1443            mark_root(deref(this,i));
1444          }
1445        } 
1446      } else {
1447        Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this);
1448      }
1449    }
1450
1451    if (marked_new) {
1452      GCweakvll = pending;
1453    }
1454  } while (marked_new);
1455
1456  /* Now, everything's marked that's going to be,  and "pending" is a list
1457     of populations and weak hash tables.  CDR down that list and free
1458     anything that isn't marked.
1459     */
1460
1461  while (pending) {
1462    this = pending;
1463    pending = deref(this,1);
1464    deref(this,1) = (LispObj)NULL;
1465
1466    subtag = header_subtag(header_of(this));
1467    if (subtag == subtag_weak) {
1468      reapweakv(this);
1469    } else {
1470      reaphashv(this);
1471    }
1472  }
1473
1474  /* Finally, mark the termination lists in all terminatable weak vectors
1475     They are now linked together on GCweakvll.
1476     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
1477     but it will force terminatable popualations to hold on to each other
1478     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
1479     */
1480  pending = GCweakvll;
1481  GCweakvll = (LispObj)NULL;
1482  while (pending) {
1483    this = pending;
1484    pending = deref(this,1);
1485    deref(this,1) = (LispObj)NULL;
1486    mark_root(deref(this,1+3));
1487  }
1488}
1489
1490/* Mark the lisp objects in an exception frame */
1491void
1492mark_xp(ExceptionInformation *xp)
1493{
1494  natural *regs = (natural *) xpGPRvector(xp), dnode;
1495  LispObj rip;
1496   
1497 
1498
1499  mark_root(regs[Iarg_z]);
1500  mark_root(regs[Iarg_y]);
1501  mark_root(regs[Iarg_x]);
1502  mark_root(regs[Isave3]);
1503  mark_root(regs[Isave2]);
1504  mark_root(regs[Isave1]);
1505  mark_root(regs[Isave0]);
1506  mark_root(regs[Ifn]);
1507  mark_root(regs[Itemp0]);
1508  mark_root(regs[Itemp1]);
1509  mark_root(regs[Itemp2]);
1510  /* If the RIP isn't pointing into a marked function,
1511     we can -maybe- recover from that if it's tagged as
1512     a TRA. */
1513  rip = regs[Iip];
1514  dnode = gc_area_dnode(rip);
1515  if ((dnode < GCndnodes_in_area) &&
1516      (! ref_bit(GCmarkbits,dnode))) {
1517    if (tag_of(rip) == tag_tra) {
1518      mark_root(rip);
1519    } else if ((fulltag_of(rip) == fulltag_function) &&
1520               (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) &&
1521               (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) &&
1522               ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) {
1523      mark_root(rip);
1524    } else {
1525      Bug(NULL, "Can't find function for rip 0x%16lx",rip);
1526    }
1527  }
1528}
1529
1530void
1531mark_tcr_tlb(TCR *tcr)
1532{
1533  natural n = tcr->tlb_limit;
1534  LispObj
1535    *start = tcr->tlb_pointer,
1536    *end = (LispObj *) ((BytePtr)start+n),
1537    node;
1538
1539  while (start < end) {
1540    node = *start;
1541    if (node != no_thread_local_binding_marker) {
1542      mark_root(node);
1543    }
1544    start++;
1545  }
1546}
1547
1548/*
1549  Mark things that're only reachable through some (suspended) TCR.
1550  (This basically means the tcr's gc_context and the exception
1551  frames on its xframe_list.)
1552*/
1553
1554void
1555mark_tcr_xframes(TCR *tcr)
1556{
1557  xframe_list *xframes;
1558  ExceptionInformation *xp;
1559
1560  xp = tcr->gc_context;
1561  if (xp) {
1562    mark_xp(xp);
1563  }
1564 
1565  for (xframes = (xframe_list *) tcr->xframe; 
1566       xframes; 
1567       xframes = xframes->prev) {
1568      mark_xp(xframes->curr);
1569  }
1570}
1571     
1572
1573void *postGCptrs = NULL;
1574
1575void
1576postGCfree(void *p)
1577{
1578  *(void **)p = postGCptrs;
1579  postGCptrs = p;
1580}
1581
1582void
1583freeGCptrs()
1584{
1585  void *p, *next;
1586
1587  for (p = postGCptrs; p; p = next) {
1588    next = *((void **)p);
1589    free(p);
1590  }
1591  postGCptrs = NULL;
1592}
1593
1594void
1595reap_gcable_ptrs()
1596{
1597  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
1598  xmacptr_flag flag;
1599  natural dnode;
1600  xmacptr *x;
1601
1602  while((next = *prev) != (LispObj)NULL) {
1603    dnode = gc_area_dnode(next);
1604    x = (xmacptr *) ptr_from_lispobj(untag(next));
1605
1606    if ((dnode >= GCndnodes_in_area) ||
1607        (ref_bit(GCmarkbits,dnode))) {
1608      prev = &(x->link);
1609    } else {
1610      *prev = x->link;
1611      flag = (xmacptr_flag)(x->flags);
1612      ptr = x->address;
1613
1614      if (ptr) {
1615        switch (flag) {
1616        case xmacptr_flag_recursive_lock:
1617          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
1618          break;
1619
1620        case xmacptr_flag_ptr:
1621          postGCfree((void *)ptr_from_lispobj(ptr));
1622          break;
1623
1624        case xmacptr_flag_rwlock:
1625          break;
1626
1627        case xmacptr_flag_semaphore:
1628          destroy_semaphore((void**)&(x->address));
1629          break;
1630
1631        default:
1632          /* (warn "unknown xmacptr_flag: ~s" flag) */
1633          /* Unknowd, and perhaps unknowdable. */
1634          /* Fall in: */
1635        case xmacptr_flag_none:
1636          break;
1637        }
1638      }
1639    }
1640  }
1641}
1642
1643
1644
1645#if  WORD_SIZE == 64
1646unsigned short *_one_bits = NULL;
1647
1648unsigned short
1649logcount16(unsigned short n)
1650{
1651  unsigned short c=0;
1652 
1653  while(n) {
1654    n = n & (n-1);
1655    c++;
1656  }
1657  return c;
1658}
1659
1660void
1661gc_init()
1662{
1663  int i;
1664 
1665  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
1666
1667  for (i = 0; i < (1<<16); i++) {
1668    _one_bits[i] = dnode_size*logcount16(i);
1669  }
1670}
1671
1672#define one_bits(x) _one_bits[x]
1673
1674#else
1675const unsigned char _one_bits[256] = {
1676    0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,
1677    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1678    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1679    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1680    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1681    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1682    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1683    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1684    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
1685    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1686    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1687    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1688    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
1689    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1690    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
1691    4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8
1692};
1693
1694#define one_bits(x) _one_bits[x]
1695
1696void
1697gc_init()
1698{
1699}
1700
1701#endif
1702
1703/* A "pagelet" contains 32 doublewords.  The relocation table contains
1704   a word for each pagelet which defines the lowest address to which
1705   dnodes on that pagelet will be relocated.
1706
1707   The relocation address of a given pagelet is the sum of the relocation
1708   address for the preceding pagelet and the number of bytes occupied by
1709   marked objects on the preceding pagelet.
1710*/
1711
1712LispObj
1713calculate_relocation()
1714{
1715  LispObj *relocptr = GCrelocptr;
1716  LispObj current = GCareadynamiclow;
1717  bitvector
1718    markbits = GCdynamic_markbits;
1719  qnode *q = (qnode *) markbits;
1720  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1721  natural thesebits;
1722  LispObj first = 0;
1723
1724  if (npagelets) {
1725    do {
1726      *relocptr++ = current;
1727      thesebits = *markbits++;
1728      if (thesebits == ALL_ONES) {
1729        current += nbits_in_word*dnode_size;
1730        q += 4; /* sic */
1731      } else {
1732        if (!first) {
1733          first = current;
1734          while (thesebits & BIT0_MASK) {
1735            first += dnode_size;
1736            thesebits += thesebits;
1737          }
1738        }
1739        /* We're counting bits in qnodes in the wrong order here, but
1740           that's OK.  I think ... */
1741        current += one_bits(*q++);
1742        current += one_bits(*q++);
1743        current += one_bits(*q++);
1744        current += one_bits(*q++);
1745      }
1746    } while(--npagelets);
1747  }
1748  *relocptr++ = current;
1749  return first ? first : current;
1750}
1751
1752
1753#if 0
1754LispObj
1755dnode_forwarding_address(natural dnode, int tag_n)
1756{
1757  natural pagelet, nbits;
1758  unsigned int near_bits;
1759  LispObj new;
1760
1761  if (GCDebug) {
1762    if (! ref_bit(GCdynamic_markbits, dnode)) {
1763      Bug(NULL, "unmarked object being forwarded!\n");
1764    }
1765  }
1766
1767  pagelet = dnode >> bitmap_shift;
1768  nbits = dnode & bitmap_shift_count_mask;
1769  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
1770
1771  if (nbits < 32) {
1772    new = GCrelocptr[pagelet] + tag_n;;
1773    /* Increment "new" by the count of 1 bits which precede the dnode */
1774    if (near_bits == 0xffffffff) {
1775      return (new + (nbits << 4));
1776    } else {
1777      near_bits &= (0xffffffff00000000 >> nbits);
1778      if (nbits > 15) {
1779        new += one_bits(near_bits & 0xffff);
1780      }
1781      return (new + (one_bits(near_bits >> 16)));
1782    }
1783  } else {
1784    new = GCrelocptr[pagelet+1] + tag_n;
1785    nbits = 64-nbits;
1786
1787    if (near_bits == 0xffffffff) {
1788      return (new - (nbits << 4));
1789    } else {
1790      near_bits &= (1<<nbits)-1;
1791      if (nbits > 15) {
1792        new -= one_bits(near_bits >> 16);
1793      }
1794      return (new -  one_bits(near_bits & 0xffff));
1795    }
1796  }
1797}
1798#else
1799
1800/* Quicker, dirtier */
1801LispObj
1802dnode_forwarding_address(natural dnode, int tag_n)
1803{
1804  natural pagelet, nbits, marked;
1805  LispObj new;
1806
1807  if (GCDebug) {
1808    if (! ref_bit(GCdynamic_markbits, dnode)) {
1809      Bug(NULL, "unmarked object being forwarded!\n");
1810    }
1811  }
1812
1813  pagelet = dnode >> bitmap_shift;
1814  nbits = dnode & bitmap_shift_count_mask;
1815  new = GCrelocptr[pagelet] + tag_n;;
1816  if (nbits) {
1817    marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits);
1818    while (marked) {
1819      new += one_bits((qnode)marked);
1820      marked >>=16;
1821    }
1822  }
1823  return new;
1824}
1825#endif
1826
1827LispObj
1828locative_forwarding_address(LispObj obj)
1829{
1830  int tag_n = fulltag_of(obj);
1831  natural dnode = gc_dynamic_area_dnode(obj);
1832
1833
1834  if ((dnode >= GCndynamic_dnodes_in_area) ||
1835      (obj < GCfirstunmarked)) {
1836    return obj;
1837  }
1838
1839  return dnode_forwarding_address(dnode, tag_n);
1840}
1841
1842LispObj
1843node_forwarding_address(LispObj node)
1844{
1845  int tag_n;
1846  natural dnode = gc_dynamic_area_dnode(node);
1847
1848  if ((dnode >= GCndynamic_dnodes_in_area) ||
1849      (node < GCfirstunmarked)) {
1850    return node;
1851  }
1852
1853  tag_n = fulltag_of(node);
1854  if (!is_node_fulltag(tag_n)) {
1855    return node;
1856  }
1857
1858  return dnode_forwarding_address(dnode, tag_n);
1859}
1860
1861Boolean
1862update_noderef(LispObj *noderef)
1863{
1864  LispObj
1865    node = *noderef,
1866    new = node_forwarding_address(node);
1867
1868  if (new != node) {
1869    *noderef = new;
1870    return true;
1871  }
1872  return false;
1873}
1874
1875void
1876update_locref(LispObj *locref)
1877{
1878  LispObj
1879    obj = *locref,
1880    new = locative_forwarding_address(obj);
1881
1882  if (new != obj) {
1883    *locref = new;
1884  }
1885}
1886
1887void
1888forward_gcable_ptrs()
1889{
1890  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
1891
1892  while ((next = *prev) != (LispObj)NULL) {
1893    *prev = node_forwarding_address(next);
1894    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1895  }
1896}
1897
1898void
1899forward_headerless_range(LispObj *range_start, LispObj *range_end)
1900{
1901  LispObj *p = range_start;
1902
1903  while (p < range_end) {
1904    update_noderef(p);
1905    p++;
1906  }
1907}
1908
1909void
1910forward_range(LispObj *range_start, LispObj *range_end)
1911{
1912  LispObj *p = range_start, node, new;
1913  int tag_n;
1914  natural nwords;
1915  hash_table_vector_header *hashp;
1916
1917  while (p < range_end) {
1918    node = *p;
1919    tag_n = fulltag_of(node);
1920    if (immheader_tag_p(tag_n)) {
1921      p = (LispObj *) skip_over_ivector((natural) p, node);
1922    } else if (nodeheader_tag_p(tag_n)) {
1923      nwords = header_element_count(node);
1924      nwords += (1 - (nwords&1));
1925      if ((header_subtag(node) == subtag_hash_vector) &&
1926          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1927        natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1928        hashp = (hash_table_vector_header *) p;
1929        p++;
1930        nwords -= skip;
1931        while(skip--) {
1932          update_noderef(p);
1933          p++;
1934        }
1935        /* "nwords" is odd at this point: there are (floor nwords 2)
1936           key/value pairs to look at, and then an extra word for
1937           alignment.  Process them two at a time, then bump "p"
1938           past the alignment word. */
1939        nwords >>= 1;
1940        while(nwords--) {
1941          if (update_noderef(p) && hashp) {
1942            hashp->flags |= nhash_key_moved_mask;
1943            hashp = NULL;
1944          }
1945          p++;
1946          update_noderef(p);
1947          p++;
1948        }
1949        *p++ = 0;
1950      } else {
1951        if (header_subtag(node) == subtag_function) {
1952          int skip = (int)(p[1]);
1953          p += skip;
1954          nwords -= skip;
1955        }
1956        p++;
1957        while(nwords--) {
1958          update_noderef(p);
1959          p++;
1960        }
1961      }
1962    } else {
1963      new = node_forwarding_address(node);
1964      if (new != node) {
1965        *p = new;
1966      }
1967      p++;
1968      update_noderef(p);
1969      p++;
1970    }
1971  }
1972}
1973
1974
1975void
1976forward_memoized_area(area *a, natural num_memo_dnodes)
1977{
1978  bitvector refbits = a->refbits;
1979  LispObj *p = (LispObj *) a->low, x1, x2, new;
1980  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
1981  int tag_x1;
1982  hash_table_vector_header *hashp = NULL;
1983  Boolean header_p;
1984
1985  if (GCDebug) {
1986    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1987  }
1988
1989  /* This is pretty straightforward, but we have to note
1990     when we move a key in a hash table vector that wants
1991     us to tell it about that. */
1992
1993  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1994  while (memo_dnode < num_memo_dnodes) {
1995    if (bits == 0) {
1996      int remain = nbits_in_word - bitidx;
1997      memo_dnode += remain;
1998      p += (remain+remain);
1999      bits = *++bitsp;
2000      bitidx = 0;
2001    } else {
2002      nextbit = count_leading_zeros(bits);
2003      if ((diff = (nextbit - bitidx)) != 0) {
2004        memo_dnode += diff;
2005        bitidx = nextbit;
2006        p += (diff+diff);
2007      }
2008      x1 = p[0];
2009      x2 = p[1];
2010      tag_x1 = fulltag_of(x1);
2011      bits &= ~(BIT0_MASK >> bitidx);
2012      header_p = (nodeheader_tag_p(tag_x1));
2013
2014      if (header_p &&
2015          (header_subtag(x1) == subtag_hash_vector)) {
2016        hashp = (hash_table_vector_header *) p;
2017        if (hashp->flags & nhash_track_keys_mask) {
2018          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
2019        } else {
2020          hashp = NULL;
2021        }
2022      }
2023
2024
2025      if (! header_p) {
2026        new = node_forwarding_address(x1);
2027        if (new != x1) {
2028          *p = new;
2029        }
2030      }
2031      p++;
2032
2033      new = node_forwarding_address(x2);
2034      if (new != x2) {
2035        *p = new;
2036        if (memo_dnode < hash_dnode_limit) {
2037          hashp->flags |= nhash_key_moved_mask;
2038          hash_dnode_limit = 0;
2039          hashp = NULL;
2040        }
2041      }
2042      p++;
2043      memo_dnode++;
2044      bitidx++;
2045
2046    }
2047  }
2048}
2049
2050
2051
2052/* Forward a tstack area */
2053void
2054forward_tstack_area(area *a)
2055{
2056  LispObj
2057    *current,
2058    *next,
2059    *start = (LispObj *) a->active,
2060    *end = start,
2061    *limit = (LispObj *) (a->high);
2062
2063  for (current = start;
2064       end != limit;
2065       current = next) {
2066    next = ptr_from_lispobj(*current);
2067    end = ((next >= start) && (next < limit)) ? next : limit;
2068    forward_range(current+2, end);
2069  }
2070}
2071
2072/* Forward a vstack area */
2073void
2074forward_vstack_area(area *a)
2075{
2076  LispObj
2077    *p = (LispObj *) a->active,
2078    *q = (LispObj *) a->high;
2079
2080  forward_headerless_range(p, q);
2081}
2082
2083
2084void
2085forward_xp(ExceptionInformation *xp)
2086{
2087  natural *regs = (natural *) xpGPRvector(xp);
2088
2089  update_noderef(&(regs[Iarg_z]));
2090  update_noderef(&(regs[Iarg_y]));
2091  update_noderef(&(regs[Iarg_x]));
2092  update_noderef(&(regs[Isave3]));
2093  update_noderef(&(regs[Isave2]));
2094  update_noderef(&(regs[Isave1]));
2095  update_noderef(&(regs[Isave0]));
2096  update_noderef(&(regs[Ifn]));
2097  update_noderef(&(regs[Itemp0]));
2098  update_noderef(&(regs[Itemp1]));
2099  update_noderef(&(regs[Itemp2]));
2100  update_locref(&(regs[Iip]));
2101}
2102
2103void
2104forward_tcr_tlb(TCR *tcr)
2105{
2106  natural n = tcr->tlb_limit;
2107  LispObj
2108    *start = tcr->tlb_pointer, 
2109    *end = (LispObj *) ((BytePtr)start+n),
2110    node;
2111
2112  while (start < end) {
2113    node = *start;
2114    if (node != no_thread_local_binding_marker) {
2115      update_noderef(start);
2116    }
2117    start++;
2118  }
2119}
2120
2121void
2122forward_tcr_xframes(TCR *tcr)
2123{
2124  xframe_list *xframes;
2125  ExceptionInformation *xp;
2126
2127  xp = tcr->gc_context;
2128  if (xp) {
2129    forward_xp(xp);
2130  }
2131  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2132    forward_xp(xframes->curr);
2133  }
2134}
2135
2136void
2137forward_and_resolve_static_references(area *a)
2138{
2139  natural
2140    nstatic = static_dnodes_for_area(a),
2141    nstatic_bitmap_words = nstatic >> bitmap_shift;
2142  if (nstatic != 0) {
2143    /* exploit the fact that a cons is the same size as a dnode. */
2144    cons *pagelet_start = (cons *) a->low, *work;
2145    bitvector markbits = GCmarkbits, 
2146      usedbits = tenured_area->static_used;
2147    natural marked, used, used_but_not_marked, ndeleted = 0, i;
2148
2149    while (nstatic_bitmap_words--) {
2150      marked = *markbits++;
2151      used = *usedbits;
2152      if (marked != used) {
2153        *usedbits = marked;
2154      }
2155      used |= marked;
2156      used_but_not_marked = used & ~marked;
2157
2158      while (marked) {
2159        i = count_leading_zeros(marked);
2160        marked &= ~(BIT0_MASK >> i);
2161        work = pagelet_start+i;
2162        update_noderef(&work->cdr);
2163        update_noderef(&work->car);
2164      }
2165
2166      while (used_but_not_marked) {
2167        i = count_leading_zeros(used_but_not_marked);
2168        used_but_not_marked &= ~(BIT0_MASK >> i);
2169        work = pagelet_start+i;
2170        if ((work->cdr != undefined) &&
2171            (work->cdr != slot_unbound)) {
2172          work->car = slot_unbound;
2173          work->cdr = slot_unbound;
2174          ndeleted++;
2175        }
2176      }
2177      usedbits++;
2178      pagelet_start += nbits_in_word;
2179    }
2180    lisp_global(DELETED_STATIC_PAIRS) += box_fixnum(ndeleted);
2181  }
2182}
2183
2184
2185/*
2186  Compact the dynamic heap (from GCfirstunmarked through its end.)
2187  Return the doublenode address of the new freeptr.
2188  */
2189
2190LispObj
2191compact_dynamic_heap()
2192{
2193  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
2194  natural
2195    elements, 
2196    dnode = gc_area_dnode(GCfirstunmarked), 
2197    node_dnodes = 0, 
2198    imm_dnodes = 0, 
2199    bitidx, 
2200    *bitsp, 
2201    bits, 
2202    nextbit, 
2203    diff;
2204  int tag;
2205  bitvector markbits = GCmarkbits;
2206    /* keep track of whether or not we saw any
2207       code_vector headers, and only flush cache if so. */
2208  Boolean GCrelocated_code_vector = false;
2209
2210  if (dnode < GCndnodes_in_area) {
2211    lisp_global(FWDNUM) += (1<<fixnum_shift);
2212 
2213    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2214    while (dnode < GCndnodes_in_area) {
2215      if (bits == 0) {
2216        int remain = nbits_in_word - bitidx;
2217        dnode += remain;
2218        src += (remain+remain);
2219        bits = *++bitsp;
2220        bitidx = 0;
2221      } else {
2222        /* Have a non-zero markbits word; all bits more significant
2223           than "bitidx" are 0.  Count leading zeros in "bits"
2224           (there'll be at least "bitidx" of them.)  If there are more
2225           than "bitidx" leading zeros, bump "dnode", "bitidx", and
2226           "src" by the difference. */
2227        nextbit = count_leading_zeros(bits);
2228        if ((diff = (nextbit - bitidx)) != 0) {
2229          dnode += diff;
2230          bitidx = nextbit;
2231          src += (diff+diff);
2232        }
2233        prev = current;
2234        current = src;
2235        if (GCDebug) {
2236          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
2237            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
2238                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
2239          }
2240        }
2241
2242        node = *src++;
2243        tag = fulltag_of(node);
2244        if (nodeheader_tag_p(tag)) {
2245          elements = header_element_count(node);
2246          node_dnodes = (elements+2)>>1;
2247          dnode += node_dnodes;
2248          if (header_subtag(node) == subtag_function) {
2249            int skip = *((int *)src);
2250            *dest++ = node;
2251            elements -= skip;
2252            while(skip--) {
2253              *dest++ = *src++;
2254            }
2255            while(elements--) {
2256              *dest++ = node_forwarding_address(*src++);
2257            }
2258            if (((LispObj)src) & node_size) {
2259              src++;
2260              *dest++ = 0;
2261            }
2262          } else {
2263            if ((header_subtag(node) == subtag_hash_vector) &&
2264                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
2265              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
2266              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2267             
2268              *dest++ = node;
2269              elements -= skip;
2270              while(skip--) {
2271                *dest++ = node_forwarding_address(*src++);
2272              }
2273              /* There should be an even number of (key/value) pairs in elements;
2274                 an extra alignment word follows. */
2275              elements >>= 1;
2276              while (elements--) {
2277                if (hashp) {
2278                  node = *src++;
2279                  new = node_forwarding_address(node);
2280                  if (new != node) {
2281                    hashp->flags |= nhash_key_moved_mask;
2282                    hashp = NULL;
2283                    *dest++ = new;
2284                  } else {
2285                    *dest++ = node;
2286                  }
2287                } else {
2288                  *dest++ = node_forwarding_address(*src++);
2289                }
2290                *dest++ = node_forwarding_address(*src++);
2291              }
2292              *dest++ = 0;
2293              src++;
2294            } else {
2295              *dest++ = node;
2296              *dest++ = node_forwarding_address(*src++);
2297              while(--node_dnodes) {
2298                *dest++ = node_forwarding_address(*src++);
2299                *dest++ = node_forwarding_address(*src++);
2300              }
2301            }
2302          }
2303          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2304        } else if (immheader_tag_p(tag)) {
2305          *dest++ = node;
2306          *dest++ = *src++;
2307          elements = header_element_count(node);
2308          tag = header_subtag(node);
2309
2310
2311          switch(fulltag_of(tag)) {
2312          case ivector_class_64_bit:
2313            imm_dnodes = ((elements+1)+1)>>1;
2314            break;
2315          case ivector_class_32_bit:
2316            imm_dnodes = (((elements+2)+3)>>2);
2317            break;
2318          case ivector_class_other_bit:
2319            if (tag == subtag_bit_vector) {
2320              imm_dnodes = (((elements+64)+127)>>7);
2321            } else if (tag >= min_8_bit_ivector_subtag) {
2322              imm_dnodes = (((elements+8)+15)>>4);
2323            } else {
2324              imm_dnodes = (((elements+4)+7)>>3);
2325            }
2326          }
2327          dnode += imm_dnodes;
2328          while (--imm_dnodes) {
2329            *dest++ = *src++;
2330            *dest++ = *src++;
2331          }
2332          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2333        } else {
2334          *dest++ = node_forwarding_address(node);
2335          *dest++ = node_forwarding_address(*src++);
2336          bits &= ~(BIT0_MASK >> bitidx);
2337          dnode++;
2338          bitidx++;
2339        }
2340      }
2341 
2342    }
2343
2344  }
2345  return ptr_to_lispobj(dest);
2346}
2347
2348
2349Boolean
2350youngest_non_null_area_p (area *a)
2351{
2352  if (a->active == a->high) {
2353    return false;
2354  } else {
2355    for (a = a->younger; a; a = a->younger) {
2356      if (a->active != a->high) {
2357        return false;
2358      }
2359    }
2360  };
2361  return true;
2362}
2363
2364Boolean just_purified_p = false;
2365
2366
2367/*
2368  All thread's stack areas have been "normalized", as
2369  has the dynamic heap.  (The "active" pointer in these areas
2370  matches the stack pointer/freeptr value at the time that
2371  the exception occurred.)
2372*/
2373
2374
2375#define get_time(when) gettimeofday(&when, NULL)
2376
2377
2378
2379#ifdef FORCE_DWS_MARK
2380#warning recursive marker disabled for testing; remember to re-enable it
2381#endif
2382
2383void 
2384gc(TCR *tcr, signed_natural param)
2385{
2386  xframe_list *xframes = (tcr->xframe);
2387  struct timeval start, stop;
2388  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
2389  unsigned timeidx = 1;
2390  xframe_list *x;
2391  LispObj
2392    pkg,
2393    itabvec = 0;
2394  BytePtr oldfree = a->active;
2395  TCR *other_tcr;
2396  natural static_dnodes;
2397
2398#ifndef FORCE_DWS_MARK
2399  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
2400    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
2401  } else {
2402    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
2403  }
2404#else
2405  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
2406#endif
2407
2408  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
2409  if (GCephemeral_low) {
2410    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
2411  } else {
2412    GCn_ephemeral_dnodes = 0;
2413  }
2414 
2415  if (GCn_ephemeral_dnodes) {
2416    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
2417  } else {
2418    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
2419  }
2420
2421  if (GCephemeral_low) {
2422    if ((oldfree-g1_area->low) < g1_area->threshold) {
2423      to = g1_area;
2424      note = a;
2425      timeidx = 4;
2426    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
2427      to = g2_area;
2428      from = g1_area;
2429      note = g1_area;
2430      timeidx = 3;
2431    } else {
2432      to = tenured_area;
2433      from = g2_area;
2434      note = g2_area;
2435      timeidx = 2;
2436    } 
2437  } else {
2438    note = tenured_area;
2439  }
2440
2441  if (GCverbose) {
2442    char buf[16];
2443   
2444    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
2445    if (GCephemeral_low) {
2446      fprintf(stderr,
2447              "\n\n;;; Starting EGC of generation %d",
2448              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
2449    } else {
2450      fprintf(stderr,"\n\n;;; Starting full GC");
2451    }
2452    fprintf(stderr, ", %s bytes allocated.\n", buf);
2453  }
2454
2455
2456  get_time(start);
2457  lisp_global(IN_GC) = (1<<fixnumshift);
2458
2459
2460  if (just_purified_p) {
2461    just_purified_p = false;
2462    GCDebug = false;
2463  } else {
2464    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
2465    if (GCDebug) {
2466      check_all_areas();
2467    }
2468  }
2469
2470  if (from) {
2471    untenure_from_area(from);
2472  }
2473  static_dnodes = static_dnodes_for_area(a);
2474  GCmarkbits = a->markbits;
2475  GCarealow = ptr_to_lispobj(a->low);
2476  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
2477  GCndnodes_in_area = gc_area_dnode(oldfree);
2478
2479  if (GCndnodes_in_area) {
2480    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
2481    GCdynamic_markbits = 
2482      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
2483
2484    zero_bits(GCmarkbits, GCndnodes_in_area);
2485    GCweakvll = (LispObj)NULL;
2486 
2487
2488    if (GCn_ephemeral_dnodes == 0) {
2489      /* For GCTWA, mark the internal package hash table vector of
2490       *PACKAGE*, but don't mark its contents. */
2491      {
2492        LispObj
2493          itab;
2494        natural
2495          dnode, ndnodes;
2496     
2497        pkg = nrs_PACKAGE.vcell;
2498        if ((fulltag_of(pkg) == fulltag_misc) &&
2499            (header_subtag(header_of(pkg)) == subtag_package)) {
2500          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
2501          itabvec = car(itab);
2502          dnode = gc_area_dnode(itabvec);
2503          if (dnode < GCndnodes_in_area) {
2504            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
2505            set_n_bits(GCmarkbits, dnode, ndnodes);
2506          }
2507        }
2508      }
2509    }
2510
2511    {
2512      area *next_area;
2513      area_code code;
2514
2515      /* Could make a jump table instead of the typecase */
2516
2517      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2518        switch (code) {
2519        case AREA_TSTACK:
2520          mark_tstack_area(next_area);
2521          break;
2522
2523        case AREA_VSTACK:
2524          mark_vstack_area(next_area);
2525          break;
2526
2527        case AREA_STATIC:
2528        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
2529          /* In both of these cases, we -could- use the area's "markbits"
2530             bitvector as a reference map.  It's safe (but slower) to
2531             ignore that map and process the entire area.
2532          */
2533          if (next_area->younger == NULL) {
2534            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
2535          }
2536          break;
2537
2538        default:
2539          break;
2540        }
2541      }
2542    }
2543 
2544    if (lisp_global(OLDEST_EPHEMERAL)) {
2545      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
2546    }
2547
2548    other_tcr = tcr;
2549    do {
2550      mark_tcr_xframes(other_tcr);
2551      mark_tcr_tlb(other_tcr);
2552      other_tcr = other_tcr->next;
2553    } while (other_tcr != tcr);
2554
2555
2556
2557
2558    /* Go back through *package*'s internal symbols, marking
2559       any that aren't worthless.
2560    */
2561   
2562    if (itabvec) {
2563      natural
2564        i,
2565        n = header_element_count(header_of(itabvec));
2566      LispObj
2567        sym,
2568        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
2569
2570      for (i = 0; i < n; i++) {
2571        sym = *raw++;
2572        if (fulltag_of(sym) == fulltag_symbol) {
2573          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
2574          natural dnode = gc_area_dnode(sym);
2575         
2576          if ((dnode < GCndnodes_in_area) &&
2577              (!ref_bit(GCmarkbits,dnode))) {
2578            /* Symbol is in GC area, not marked.
2579               Mark it if fboundp, boundp, or if
2580               it has a plist or another home package.
2581            */
2582           
2583            if (FBOUNDP(rawsym) ||
2584                BOUNDP(rawsym) ||
2585                (rawsym->flags != 0) || /* SPECIAL, etc. */
2586                (rawsym->plist != lisp_nil) ||
2587                ((rawsym->package_predicate != pkg) &&
2588                 (rawsym->package_predicate != lisp_nil))) {
2589              mark_root(sym);
2590            }
2591          }
2592        }
2593      }
2594    }
2595
2596    (void)markhtabvs();
2597
2598    if (itabvec) {
2599      natural
2600        i,
2601        n = header_element_count(header_of(itabvec));
2602      LispObj
2603        sym,
2604        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
2605
2606      for (i = 0; i < n; i++, raw++) {
2607        sym = *raw;
2608        if (fulltag_of(sym) == fulltag_symbol) {
2609          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
2610          natural dnode = gc_area_dnode(sym);
2611
2612          if ((dnode < GCndnodes_in_area) &&
2613              (!ref_bit(GCmarkbits,dnode))) {
2614            *raw = unbound_marker;
2615          }
2616        }
2617      }
2618    }
2619 
2620    reap_gcable_ptrs();
2621
2622    GCrelocptr = global_reloctab;
2623    GCfirstunmarked = calculate_relocation();
2624
2625    forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
2626
2627    other_tcr = tcr;
2628    do {
2629      forward_tcr_xframes(other_tcr);
2630      forward_tcr_tlb(other_tcr);
2631      other_tcr = other_tcr->next;
2632    } while (other_tcr != tcr);
2633
2634 
2635    forward_gcable_ptrs();
2636
2637
2638
2639    {
2640      area *next_area;
2641      area_code code;
2642
2643      /* Could make a jump table instead of the typecase */
2644
2645      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2646        switch (code) {
2647        case AREA_TSTACK:
2648          forward_tstack_area(next_area);
2649          break;
2650
2651        case AREA_VSTACK:
2652          forward_vstack_area(next_area);
2653          break;
2654
2655
2656        case AREA_STATIC:
2657        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
2658          if (next_area->younger == NULL) {
2659            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
2660          }
2661          break;
2662
2663        default:
2664          break;
2665        }
2666      }
2667    }
2668 
2669    if (GCephemeral_low) {
2670      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
2671    } else {
2672      /* Full GC, need to process static space */
2673      forward_and_resolve_static_references(a);
2674    }
2675 
2676    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
2677    if (to) {
2678      tenure_to_area(to);
2679    }
2680
2681    zero_memory_range(a->active, oldfree);
2682
2683    resize_dynamic_heap(a->active,
2684                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
2685
2686    /*
2687      If the EGC is enabled: If there's no room for the youngest
2688      generation, untenure everything.  If this was a full GC and
2689      there's now room for the youngest generation, tenure everything.
2690    */
2691    if (a->older != NULL) {
2692      natural nfree = (a->high - a->active);
2693
2694
2695      if (nfree < a->threshold) {
2696        untenure_from_area(tenured_area);
2697      } else {
2698        if (GCephemeral_low == 0) {
2699          tenure_to_area(tenured_area);
2700        }
2701      }
2702    }
2703  }
2704  lisp_global(GC_NUM) += (1<<fixnumshift);
2705  if (note) {
2706    note->gccount += (1<<fixnumshift);
2707  }
2708
2709  if (GCDebug) {
2710    check_all_areas();
2711  }
2712
2713 
2714  lisp_global(IN_GC) = 0;
2715
2716  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
2717  get_time(stop);
2718
2719  {
2720    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
2721    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
2722    LispObj val;
2723    struct timeval *timeinfo, elapsed;
2724
2725    val = total_gc_microseconds->vcell;
2726    if ((fulltag_of(val) == fulltag_misc) &&
2727        (header_subtag(header_of(val)) == subtag_macptr)) {
2728      timersub(&stop, &start, &elapsed);
2729      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
2730      timeradd(timeinfo,  &elapsed, timeinfo);
2731      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
2732    }
2733
2734    val = total_bytes_freed->vcell;
2735    if ((fulltag_of(val) == fulltag_misc) &&
2736        (header_subtag(header_of(val)) == subtag_macptr)) {
2737      long long justfreed = oldfree - a->active;
2738      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
2739      if (GCverbose) {
2740        char buf[16];
2741        if (justfreed <= heap_segment_size) {
2742          justfreed = 0;
2743        }
2744        comma_output_decimal(buf,16,justfreed);
2745        if (note == tenured_area) {
2746          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
2747        } else {
2748          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
2749                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
2750                  buf, 
2751                  elapsed.tv_sec, elapsed.tv_usec);
2752        }
2753      }
2754    }
2755  }
2756}
2757
2758     
2759   
2760/*
2761  Total the (physical) byte sizes of all ivectors in the indicated memory range
2762*/
2763
2764natural
2765unboxed_bytes_in_range(LispObj *start, LispObj *end)
2766{
2767  natural total=0, elements, tag, subtag, bytes;
2768  LispObj header;
2769
2770  while (start < end) {
2771    header = *start;
2772    tag = fulltag_of(header);
2773   
2774    if ((nodeheader_tag_p(tag)) ||
2775        (immheader_tag_p(tag))) {
2776      elements = header_element_count(header);
2777      if (nodeheader_tag_p(tag)) {
2778        start += ((elements+2) & ~1);
2779      } else {
2780        subtag = header_subtag(header);
2781
2782        switch(fulltag_of(header)) {
2783        case ivector_class_64_bit:
2784          bytes = 8 + (elements<<3);
2785          break;
2786        case ivector_class_32_bit:
2787          bytes = 8 + (elements<<2);
2788          break;
2789        case ivector_class_other_bit:
2790        default:
2791          if (subtag == subtag_bit_vector) {
2792            bytes = 8 + ((elements+7)>>3);
2793          } else if (subtag >= min_8_bit_ivector_subtag) {
2794            bytes = 8 + elements;
2795          } else {
2796            bytes = 8 + (elements<<1);
2797          }
2798        }
2799        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
2800        total += bytes;
2801        start += (bytes >> node_shift);
2802      }
2803    } else {
2804      start += 2;
2805    }
2806  }
2807  return total;
2808}
2809
2810
2811/*
2812  This assumes that it's getting called with a simple-{base,general}-string
2813  or code vector as an argument and that there's room for the object in the
2814  destination area.
2815*/
2816
2817
2818LispObj
2819purify_displaced_object(LispObj obj, area *dest, natural disp)
2820{
2821  BytePtr
2822    free = dest->active,
2823    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
2824  LispObj
2825    header = header_of(obj), 
2826    new;
2827  natural
2828    subtag = header_subtag(header), 
2829    element_count = header_element_count(header),
2830    physbytes;
2831
2832  switch(subtag) {
2833  case subtag_simple_base_string:
2834    physbytes = node_size + (element_count << 2);
2835    break;
2836
2837#ifndef X86
2838  case subtag_code_vector:
2839    physbytes = node_size + (element_count << 2);
2840    break;
2841#endif
2842
2843  default:
2844    Bug(NULL, "Can't purify object at 0x%08x", obj);
2845    return obj;
2846  }
2847  physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1);
2848  dest->active += physbytes;
2849
2850  new = ptr_to_lispobj(free)+disp;
2851
2852  memcpy(free, (BytePtr)old, physbytes);
2853  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
2854  /* Actually, it's best to always leave a trail, for two reasons.
2855     a) We may be walking the same heap that we're leaving forwaring
2856     pointers in, so we don't want garbage that we leave behind to
2857     look like a header.
2858     b) We'd like to be able to forward code-vector locatives, and
2859     it's easiest to do so if we leave a {forward_marker, dnode_locative}
2860     pair at every doubleword in the old vector.
2861     */
2862  while(physbytes) {
2863    *old++ = (BytePtr) forward_marker;
2864    *old++ = (BytePtr) free;
2865    free += dnode_size;
2866    physbytes -= dnode_size;
2867  }
2868  return new;
2869}
2870
2871LispObj
2872purify_object(LispObj obj, area *dest)
2873{
2874  return purify_displaced_object(obj, dest, fulltag_of(obj));
2875}
2876
2877
2878#define FORWARD_ONLY 0
2879#define COPY_CODE (1<<0)
2880#define COPY_STRINGS (1<<1)
2881
2882
2883/*
2884  This may overestimate a bit, if the same symbol is accessible from multiple
2885  packages.
2886*/
2887natural
2888interned_pname_bytes_in_range(LispObj *start, LispObj *end)
2889{
2890  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
2891  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
2892  package *p;
2893  cons *c;
2894  natural elements, i, nbytes = 0;
2895
2896  while (fulltag_of(pkg_list) == fulltag_cons) {
2897    c = (cons *) ptr_from_lispobj(untag(pkg_list));
2898    p = (package *) ptr_from_lispobj(untag(c->car));
2899    pkg_list = c->cdr;
2900    c = (cons *) ptr_from_lispobj(untag(p->itab));
2901    htab = c->car;
2902    elements = header_element_count(header_of(htab));
2903    for (i = 1; i<= elements; i++) {
2904      obj = deref(htab,i);
2905      if (fulltag_of(obj) == fulltag_symbol) {
2906        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
2907        pname = rawsym->pname;
2908
2909        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
2910          pname_header = header_of(pname);
2911          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
2912        }
2913      }
2914    }
2915    c = (cons *) ptr_from_lispobj(untag(p->etab));
2916    htab = c->car;
2917    elements = header_element_count(header_of(htab));
2918    for (i = 1; i<= elements; i++) {
2919      obj = deref(htab,i);
2920      if (fulltag_of(obj) == fulltag_symbol) {
2921        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
2922        pname = rawsym->pname;
2923
2924        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
2925          pname_header = header_of(pname);
2926          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
2927        }
2928      }
2929    }
2930  }
2931  return nbytes;
2932}
2933
2934Boolean
2935copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy)
2936{
2937  LispObj obj = *ref, header, new;
2938  natural tag = fulltag_of(obj), header_tag, header_subtag;
2939  Boolean changed = false;
2940
2941  if ((tag == fulltag_misc) &&
2942      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
2943      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
2944    header = deref(obj, 0);
2945    if (header == forward_marker) { /* already copied */
2946      *ref = (untag(deref(obj,1)) + tag);
2947      changed = true;
2948    } else {
2949      header_tag = fulltag_of(header);
2950      if (immheader_tag_p(header_tag)) {
2951        header_subtag = header_subtag(header);
2952        if ((what_to_copy & COPY_STRINGS) && 
2953            ((header_subtag == subtag_simple_base_string))) {
2954          new = purify_object(obj, dest);
2955          *ref = new;
2956          changed = (new != obj);
2957        }
2958      }
2959    }
2960  }
2961  return changed;
2962}
2963
2964
2965void purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
2966{
2967  while (start < end) { 
2968    copy_ivector_reference(start, low, high, to, what);
2969    start++;
2970  }
2971}
2972   
2973void
2974purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
2975{
2976  LispObj header;
2977  unsigned tag;
2978  natural nwords;
2979  hash_table_vector_header *hashp;
2980
2981  while (start < end) {
2982    header = *start;
2983    if (header == forward_marker) {
2984      start += 2;
2985    } else {
2986      tag = fulltag_of(header);
2987      if (immheader_tag_p(tag)) {
2988        start = (LispObj *)skip_over_ivector((natural)start, header);
2989      } else if (nodeheader_tag_p(tag)) {
2990        nwords = header_element_count(header);
2991        nwords += (1 - (nwords&1));
2992        if ((header_subtag(header) == subtag_hash_vector) &&
2993          ((((hash_table_vector_header *)start)->flags) & 
2994           nhash_track_keys_mask)) {
2995          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2996
2997          hashp = (hash_table_vector_header *) start;
2998          start++;
2999          nwords -= skip;
3000          while(skip--) {
3001            copy_ivector_reference(start, low, high, to, what);
3002            start++;
3003          }
3004          /* "nwords" is odd at this point: there are (floor nwords 2)
3005             key/value pairs to look at, and then an extra word for
3006             alignment.  Process them two at a time, then bump "start"
3007             past the alignment word. */
3008          nwords >>= 1;
3009          while(nwords--) {
3010            if (copy_ivector_reference(start, low, high, to, what) && hashp) {
3011              hashp->flags |= nhash_key_moved_mask;
3012              hashp = NULL;
3013            }
3014            start++;
3015            copy_ivector_reference(start, low, high, to, what);
3016            start++;
3017          }
3018          *start++ = 0;
3019        } else {
3020          if (header_subtag(header) == subtag_function) {
3021            int skip = (int)(start[1]);
3022            start += skip;
3023            nwords -= skip;
3024          }
3025          start++;
3026          while(nwords--) {
3027            copy_ivector_reference(start, low, high, to, what);
3028            start++;
3029          }
3030        }
3031      } else {
3032        /* Not a header, just a cons cell */
3033        copy_ivector_reference(start, low, high, to, what);
3034        start++;
3035        copy_ivector_reference(start, low, high, to, what);
3036        start++;
3037      }
3038    }
3039  }
3040}
3041       
3042/* Purify references from tstack areas */
3043void
3044purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3045{
3046  LispObj
3047    *current,
3048    *next,
3049    *start = (LispObj *) (a->active),
3050    *end = start,
3051    *limit = (LispObj *) (a->high);
3052
3053  for (current = start;
3054       end != limit;
3055       current = next) {
3056    next = (LispObj *) ptr_from_lispobj(*current);
3057    end = ((next >= start) && (next < limit)) ? next : limit;
3058    if (current[1] == 0) {
3059      purify_range(current+2, end, low, high, to, what);
3060    }
3061  }
3062}
3063
3064/* Purify a vstack area */
3065void
3066purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
3067{
3068  LispObj
3069    *p = (LispObj *) a->active,
3070    *q = (LispObj *) a->high;
3071 
3072  purify_headerless_range(p, q, low, high, to, what);
3073}
3074
3075
3076void
3077purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what)
3078{
3079  natural *regs = (natural *) xpGPRvector(xp);
3080
3081
3082#ifdef X8664
3083  copy_ivector_reference(&(regs[Iarg_z]), low, high, to, what);
3084  copy_ivector_reference(&(regs[Iarg_y]), low, high, to, what);
3085  copy_ivector_reference(&(regs[Iarg_x]), low, high, to, what);
3086  copy_ivector_reference(&(regs[Isave3]), low, high, to, what);
3087  copy_ivector_reference(&(regs[Isave2]), low, high, to, what);
3088  copy_ivector_reference(&(regs[Isave1]), low, high, to, what);
3089  copy_ivector_reference(&(regs[Isave0]), low, high, to, what);
3090  copy_ivector_reference(&(regs[Ifn]), low, high, to, what);
3091  copy_ivector_reference(&(regs[Itemp0]), low, high, to, what);
3092  copy_ivector_reference(&(regs[Itemp1]), low, high, to, what);
3093  copy_ivector_reference(&(regs[Itemp2]), low, high, to, what);
3094#if 0
3095  purify_locref(&(regs[Iip]), low, high, to, what);
3096#endif
3097#else
3098#endif
3099}
3100
3101void
3102purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3103{
3104  natural n = tcr->tlb_limit;
3105  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3106
3107  purify_range(start, end, low, high, to, what);
3108}
3109
3110void
3111purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
3112{
3113  xframe_list *xframes;
3114  ExceptionInformation *xp;
3115 
3116  xp = tcr->gc_context;
3117  if (xp) {
3118    purify_xp(xp, low, high, to, what);
3119  }
3120
3121  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3122    purify_xp(xframes->curr, low, high, to, what);
3123  }
3124}
3125
3126
3127void
3128purify_areas(BytePtr low, BytePtr high, area *target, int what)
3129{
3130  area *next_area;
3131  area_code code;
3132     
3133  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3134    switch (code) {
3135    case AREA_TSTACK:
3136      purify_tstack_area(next_area, low, high, target, what);
3137      break;
3138     
3139    case AREA_VSTACK:
3140      purify_vstack_area(next_area, low, high, target, what);
3141      break;
3142     
3143    case AREA_CSTACK:
3144#ifdef PPC
3145      purify_cstack_area(next_area, low, high, target, what);
3146#endif
3147      break;
3148     
3149    case AREA_STATIC:
3150    case AREA_DYNAMIC:
3151      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what);
3152      break;
3153     
3154    default:
3155      break;
3156    }
3157  }
3158}
3159
3160/*
3161  So far, this is mostly for save_application's benefit.
3162  We -should- be able to return to lisp code after doing this,
3163  however.
3164
3165*/
3166
3167
3168int
3169purify(TCR *tcr, signed_natural param)
3170{
3171  extern area *extend_readonly_area(unsigned);
3172  area
3173    *a = active_dynamic_area,
3174    *new_pure_area;
3175
3176  TCR  *other_tcr;
3177  natural max_pure_size;
3178  OSErr err;
3179  BytePtr new_pure_start;
3180
3181
3182
3183  max_pure_size = interned_pname_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
3184                                         (LispObj *) a->active);
3185  new_pure_area = extend_readonly_area(max_pure_size);
3186  if (new_pure_area) {
3187    new_pure_start = new_pure_area->active;
3188    lisp_global(IN_GC) = (1<<fixnumshift);
3189
3190    /*
3191      First, loop thru *all-packages* and purify the pnames of all
3192      interned symbols.  Then walk every place that could reference
3193      a heap-allocated object (all_areas, the xframe_list) and
3194      purify code_vectors (and update the odd case of a shared
3195      reference to a pname.)
3196       
3197      Make the new_pure_area executable, just in case.
3198
3199      Caller will typically GC again (and that should recover quite a bit of
3200      the dynamic heap.)
3201      */
3202
3203    {
3204      lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
3205      LispObj pkg_list = rawsym->vcell, htab, obj;
3206      package *p;
3207      cons *c;
3208      natural elements, i;
3209
3210      while (fulltag_of(pkg_list) == fulltag_cons) {
3211        c = (cons *) ptr_from_lispobj(untag(pkg_list));
3212        p = (package *) ptr_from_lispobj(untag(c->car));
3213        pkg_list = c->cdr;
3214        c = (cons *) ptr_from_lispobj(untag(p->itab));
3215        htab = c->car;
3216        elements = header_element_count(header_of(htab));
3217        for (i = 1; i<= elements; i++) {
3218          obj = deref(htab,i);
3219          if (fulltag_of(obj) == fulltag_symbol) {
3220            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3221            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3222          }
3223        }
3224        c = (cons *) ptr_from_lispobj(untag(p->etab));
3225        htab = c->car;
3226        elements = header_element_count(header_of(htab));
3227        for (i = 1; i<= elements; i++) {
3228          obj = deref(htab,i);
3229          if (fulltag_of(obj) == fulltag_symbol) {
3230            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
3231            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
3232          }
3233        }
3234      }
3235    }
3236   
3237    purify_areas(a->low, a->active, new_pure_area, FORWARD_ONLY);
3238   
3239    other_tcr = tcr;
3240    do {
3241      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
3242      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
3243      other_tcr = other_tcr->next;
3244    } while (other_tcr != tcr);
3245
3246
3247    {
3248      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
3249      if (puresize != 0) {
3250        xMakeDataExecutable(new_pure_start, puresize);
3251 
3252      }
3253    }
3254    ProtectMemory(new_pure_area->low,
3255                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
3256                                      log2_page_size));
3257    lisp_global(IN_GC) = 0;
3258    just_purified_p = true;
3259    return 0;
3260  }
3261  return -1;
3262}
3263
3264
3265 
3266Boolean
3267impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
3268{
3269  LispObj q = *p;
3270 
3271  if (is_node_fulltag(fulltag_of(q)) &&
3272      (q >= low) && 
3273      (q < high)) {
3274    *p = (q+delta);
3275    return true;
3276  }
3277  return false;
3278}
3279 
3280
3281
3282void
3283impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
3284{
3285  natural *regs = (natural *) xpGPRvector(xp);
3286
3287
3288#ifdef X8664
3289  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
3290  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
3291  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
3292  impurify_noderef(&(regs[Isave3]), low, high, delta);
3293  impurify_noderef(&(regs[Isave2]), low, high, delta);
3294  impurify_noderef(&(regs[Isave1]), low, high, delta);
3295  impurify_noderef(&(regs[Isave0]), low, high, delta);
3296  impurify_noderef(&(regs[Ifn]), low, high, delta);
3297  impurify_noderef(&(regs[Itemp0]), low, high, delta);
3298  impurify_noderef(&(regs[Itemp1]), low, high, delta);
3299#if 0
3300  impurify_locref(&(regs[Iip]), low, high, delta);
3301#endif
3302#else
3303#endif
3304
3305}
3306
3307void
3308impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3309{
3310  while (start < end) {
3311    impurify_noderef(start, low, high, delta);
3312    start++;
3313  }
3314}
3315
3316
3317void
3318impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
3319{
3320  LispObj header;
3321  unsigned tag;
3322  natural nwords;
3323  hash_table_vector_header *hashp;
3324
3325  while (start < end) {
3326    header = *start;
3327    if (header == forward_marker) {
3328      start += 2;
3329    } else {
3330      tag = fulltag_of(header);
3331      if (immheader_tag_p(tag)) {
3332        start = (LispObj *)skip_over_ivector((natural)start, header);
3333      } else if (nodeheader_tag_p(tag)) {
3334        nwords = header_element_count(header);
3335        nwords += (1 - (nwords&1));
3336        if ((header_subtag(header) == subtag_hash_vector) &&
3337          ((((hash_table_vector_header *)start)->flags) & 
3338           nhash_track_keys_mask)) {
3339          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
3340
3341          hashp = (hash_table_vector_header *) start;
3342          start++;
3343          nwords -= skip;
3344          while(skip--) {
3345            impurify_noderef(start, low, high, delta);
3346            start++;
3347          }
3348          /* "nwords" is odd at this point: there are (floor nwords 2)
3349             key/value pairs to look at, and then an extra word for
3350             alignment.  Process them two at a time, then bump "start"
3351             past the alignment word. */
3352          nwords >>= 1;
3353          while(nwords--) {
3354            if (impurify_noderef(start, low, high, delta) && hashp) {
3355              hashp->flags |= nhash_key_moved_mask;
3356              hashp = NULL;
3357            }
3358            start++;
3359            impurify_noderef(start, low, high, delta);
3360            start++;
3361          }
3362          *start++ = 0;
3363        } else {
3364          if (header_subtag(header) == subtag_function) {
3365            int skip = (int)(start[1]);
3366            start += skip;
3367            nwords -= skip;
3368          }
3369          start++;
3370          while(nwords--) {
3371            impurify_noderef(start, low, high, delta);
3372            start++;
3373          }
3374        }
3375      } else {
3376        /* Not a header, just a cons cell */
3377        impurify_noderef(start, low, high, delta);
3378        start++;
3379        impurify_noderef(start, low, high, delta);
3380        start++;
3381      }
3382    }
3383  }
3384}
3385
3386
3387
3388
3389void
3390impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
3391{
3392  unsigned n = tcr->tlb_limit;
3393  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
3394 
3395  impurify_range(start, end, low, high, delta);
3396}
3397
3398void
3399impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
3400{
3401  xframe_list *xframes;
3402  ExceptionInformation *xp;
3403 
3404  xp = tcr->gc_context;
3405  if (xp) {
3406    impurify_xp(xp, low, high, delta);
3407  }
3408
3409  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3410    impurify_xp(xframes->curr, low, high, delta);
3411  }
3412}
3413
3414void
3415impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
3416{
3417  LispObj
3418    *current,
3419    *next,
3420    *start = (LispObj *) (a->active),
3421    *end = start,
3422    *limit = (LispObj *) (a->high);
3423
3424  for (current = start;
3425       end != limit;
3426       current = next) {
3427    next = (LispObj *) ptr_from_lispobj(*current);
3428    end = ((next >= start) && (next < limit)) ? next : limit;
3429    if (current[1] == 0) {
3430      impurify_range(current+2, end, low, high, delta);
3431    }
3432  }
3433}
3434void
3435impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
3436{
3437  LispObj
3438    *p = (LispObj *) a->active,
3439    *q = (LispObj *) a->high;
3440
3441  impurify_headerless_range(p, q, low, high, delta);
3442}
3443
3444
3445void
3446impurify_areas(LispObj low, LispObj high, int delta)
3447{
3448  area *next_area;
3449  area_code code;
3450     
3451  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
3452    switch (code) {
3453    case AREA_TSTACK:
3454      impurify_tstack_area(next_area, low, high, delta);
3455      break;
3456     
3457    case AREA_VSTACK:
3458      impurify_vstack_area(next_area, low, high, delta);
3459      break;
3460     
3461    case AREA_CSTACK:
3462#ifdef PPC
3463      impurify_cstack_area(next_area, low, high, delta);
3464#endif
3465      break;
3466     
3467    case AREA_STATIC:
3468    case AREA_DYNAMIC:
3469      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
3470      break;
3471     
3472    default:
3473      break;
3474    }
3475  }
3476}
3477
3478int
3479impurify(TCR *tcr, signed_natural param)
3480{
3481  area *r = find_readonly_area();
3482
3483  if (r) {
3484    area *a = active_dynamic_area;
3485    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
3486      oldhigh = a->high, newhigh; 
3487    unsigned n = ro_limit - ro_base;
3488    int delta = oldfree-ro_base;
3489    TCR *other_tcr;
3490
3491    if (n) {
3492      lisp_global(IN_GC) = 1;
3493      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
3494                                               log2_heap_segment_size));
3495      if (newhigh > oldhigh) {
3496        grow_dynamic_area(newhigh-oldhigh);
3497      }
3498      a->active += n;
3499      bcopy(ro_base, oldfree, n);
3500      munmap((void *)ro_base, n);
3501      a->ndnodes = area_dnode(a, a->active);
3502      pure_space_active = r->active = r->low;
3503      r->ndnodes = 0;
3504
3505      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3506
3507      other_tcr = tcr;
3508      do {
3509        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3510        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
3511        other_tcr = other_tcr->next;
3512      } while (other_tcr != tcr);
3513      lisp_global(IN_GC) = 0;
3514    }
3515    return 0;
3516  }
3517  return -1;
3518}
3519
3520
3521void
3522adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
3523{
3524  LispObj p = *loc;
3525 
3526  if (area_dnode(p, base) < limit) {
3527    *loc = p+delta;
3528  }
3529}
3530
3531/* like adjust_locref() above, but only changes the contents of LOC if it's
3532   a tagged lisp pointer */
3533void
3534adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
3535{
3536  LispObj p = *loc;
3537  int tag_n = fulltag_of(p);
3538
3539  if (is_node_fulltag(tag_n)) {
3540    if (area_dnode(p, base) < limit) {
3541      *loc = p+delta;
3542    }
3543  }
3544}
3545
3546/*
3547   If *loc is a tagged pointer into the address range denoted by BASE and LIMIT,
3548   nuke it (set it to NIL.)
3549*/
3550void
3551nuke_noderef(LispObj *loc, LispObj base, LispObj limit)
3552{
3553  LispObj p = *loc;
3554  int tag_n = fulltag_of(p);
3555
3556  if (is_node_fulltag(tag_n)) {
3557    if (area_dnode(p, base) < limit) {
3558      *loc = lisp_nil;
3559    }
3560  }
3561}
3562
3563
3564void
3565adjust_pointers_in_xp(ExceptionInformation *xp, 
3566                      LispObj base, 
3567                      LispObj limit, 
3568                      signed_natural delta) 
3569{
3570  natural *regs = (natural *) xpGPRvector(xp);
3571
3572  adjust_noderef((LispObj *) (&(regs[Iarg_z])),base,limit,delta);
3573  adjust_noderef((LispObj *) (&(regs[Iarg_y])),base,limit,delta);
3574  adjust_noderef((LispObj *) (&(regs[Iarg_x])),base,limit,delta);
3575  adjust_noderef((LispObj *) (&(regs[Isave3])),base,limit,delta);
3576  adjust_noderef((LispObj *) (&(regs[Isave2])),base,limit,delta);
3577  adjust_noderef((LispObj *) (&(regs[Isave1])),base,limit,delta);
3578  adjust_noderef((LispObj *) (&(regs[Isave0])),base,limit,delta);
3579  adjust_noderef((LispObj *) (&(regs[Ifn])),base,limit,delta);
3580  adjust_noderef((LispObj *) (&(regs[Itemp0])),base,limit,delta);
3581  adjust_noderef((LispObj *) (&(regs[Itemp1])),base,limit,delta);
3582  adjust_noderef((LispObj *) (&(regs[Itemp2])),base,limit,delta);
3583  adjust_locref((LispObj *) (&(xpPC(xp))),base,limit,delta);
3584}
3585
3586void
3587nuke_pointers_in_xp(ExceptionInformation *xp, 
3588                      LispObj base, 
3589                      LispObj limit) 
3590{
3591  natural *regs = (natural *) xpGPRvector(xp);
3592
3593  nuke_noderef((LispObj *) (&(regs[Iarg_z])),base,limit);
3594  nuke_noderef((LispObj *) (&(regs[Iarg_y])),base,limit);
3595  nuke_noderef((LispObj *) (&(regs[Iarg_x])),base,limit);
3596  nuke_noderef((LispObj *) (&(regs[Isave3])),base,limit);
3597  nuke_noderef((LispObj *) (&(regs[Isave2])),base,limit);
3598  nuke_noderef((LispObj *) (&(regs[Isave1])),base,limit);
3599  nuke_noderef((LispObj *) (&(regs[Isave0])),base,limit);
3600  nuke_noderef((LispObj *) (&(regs[Ifn])),base,limit);
3601  nuke_noderef((LispObj *) (&(regs[Itemp0])),base,limit);
3602  nuke_noderef((LispObj *) (&(regs[Itemp1])),base,limit);
3603  nuke_noderef((LispObj *) (&(regs[Itemp2])),base,limit);
3604
3605}
3606
3607void
3608adjust_pointers_in_headerless_range(LispObj *range_start,
3609                                    LispObj *range_end,
3610                                    LispObj base,
3611                                    LispObj limit,
3612                                    signed_natural delta)
3613{
3614  LispObj *p = range_start;
3615
3616  while (p < range_end) {
3617    adjust_noderef(p, base, limit, delta);
3618    p++;
3619  }
3620}
3621
3622
3623void
3624adjust_pointers_in_range(LispObj *range_start,
3625                         LispObj *range_end,
3626                         LispObj base,
3627                         LispObj limit,
3628                         signed_natural delta)
3629{
3630  LispObj *p = range_start, node, new;
3631  int tag_n;
3632  natural nwords;
3633  hash_table_vector_header *hashp;
3634
3635  while (p < range_end) {
3636    node = *p;
3637    tag_n = fulltag_of(node);
3638    if (immheader_tag_p(tag_n)) {
3639      p = (LispObj *) skip_over_ivector((natural) p, node);
3640    } else if (nodeheader_tag_p(tag_n)) {
3641      nwords = header_element_count(node);
3642      nwords += (1 - (nwords&1));
3643      if ((header_subtag(node) == subtag_hash_vector) &&
3644          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
3645        hashp = (hash_table_vector_header *) p;
3646        hashp->flags |= nhash_key_moved_mask;
3647      } else if (header_subtag(node) == subtag_function) {
3648        int skip = (int)(p[1]);
3649        p += skip;
3650        nwords -= skip;
3651      }
3652      p++;
3653      while (nwords--) {
3654        adjust_noderef(p, base, limit, delta);
3655        p++;
3656      }
3657    } else {
3658      /* just a cons */
3659      adjust_noderef(p, base, limit, delta);
3660      p++;
3661      adjust_noderef(p, base, limit, delta);
3662      p++;
3663    }
3664  }
3665}
3666
3667void
3668nuke_pointers_in_headerless_range(LispObj *range_start,
3669                                  LispObj *range_end,
3670                                  LispObj base,
3671                                  LispObj limit)
3672{
3673  LispObj *p = range_start;
3674
3675  while (p < range_end) {
3676    nuke_noderef(p, base, limit);
3677    p++;
3678  }
3679}
3680
3681
3682void
3683nuke_pointers_in_range(LispObj *range_start,
3684                         LispObj *range_end,
3685                         LispObj base,
3686                         LispObj limit)
3687{
3688  LispObj *p = range_start, node, new;
3689  int tag_n;
3690  natural nwords;
3691
3692  while (p < range_end) {
3693    node = *p;
3694    tag_n = fulltag_of(node);
3695    if (immheader_tag_p(tag_n)) {
3696      p = (LispObj *) skip_over_ivector((natural) p, node);
3697    } else if (nodeheader_tag_p(tag_n)) {
3698      nwords = header_element_count(node);
3699      nwords += (1 - (nwords&1));
3700      if (header_subtag(node) == subtag_function) {
3701        int skip = (int)(p[1]);
3702        p += skip;
3703        nwords -= skip;
3704      }
3705      p++;
3706      while (nwords--) {
3707        nuke_noderef(p, base, limit);
3708        p++;
3709      }
3710    } else {
3711      /* just a cons */
3712      nuke_noderef(p, base, limit);
3713      p++;
3714      nuke_noderef(p, base, limit);
3715      p++;
3716    }
3717  }
3718}
3719
3720void
3721adjust_pointers_in_tstack_area(area *a,
3722                               LispObj base,
3723                               LispObj limit,
3724                               LispObj delta)
3725{
3726  LispObj
3727    *current,
3728    *next,
3729    *start = (LispObj *) a->active,
3730    *end = start,
3731    *area_limit = (LispObj *) (a->high);
3732
3733  for (current = start;
3734       end != area_limit;
3735       current = next) {
3736    next = ptr_from_lispobj(*current);
3737    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
3738    adjust_pointers_in_range(current+2, end, base, limit, delta);
3739  }
3740}
3741
3742void
3743nuke_pointers_in_tstack_area(area *a,
3744                             LispObj base,
3745                             LispObj limit)
3746{
3747  LispObj
3748    *current,
3749    *next,
3750    *start = (LispObj *) a->active,
3751    *end = start,
3752    *area_limit = (LispObj *) (a->high);
3753
3754  for (current = start;
3755       end != area_limit;
3756       current = next) {
3757    next = ptr_from_lispobj(*current);
3758    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
3759    if (current[1] == 0) {
3760      nuke_pointers_in_range(current+2, end, base, limit);
3761    }
3762  }
3763}
3764
3765void
3766adjust_pointers_in_vstack_area(area *a,
3767                               LispObj base,
3768                               LispObj limit,
3769                               LispObj delta)
3770{
3771  LispObj
3772    *p = (LispObj *) a->active,
3773    *q = (LispObj *) a->high;
3774
3775  adjust_pointers_in_headerless_range(p, q, base, limit, delta);
3776}
3777
3778void
3779nuke_pointers_in_vstack_area(area *a,
3780                             LispObj base,
3781                             LispObj limit)
3782{
3783  LispObj
3784    *p = (LispObj *) a->active,
3785    *q = (LispObj *) a->high;
3786
3787  nuke_pointers_in_headerless_range(p, q, base, limit);
3788}
3789
3790#ifdef PPC
3791void
3792adjust_pointers_in_cstack_area(area *a,
3793                               LispObj base,
3794                               LispObj limit,
3795                               LispObj delta)
3796{
3797  BytePtr
3798    current,
3799    next,
3800    area_limit = a->high,
3801    low = a->low;
3802
3803  for (current = a->active; (current >= low) && (current < area_limit); current = next) {
3804    next = *((BytePtr *)current);
3805    if (next == NULL) break;
3806    if (((next - current) == sizeof(lisp_frame)) &&
3807        (((((lisp_frame *)current)->savefn) == 0) ||
3808         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
3809      adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta);
3810      adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta);
3811    }
3812  }
3813}
3814#endif
3815
3816
3817
3818void
3819adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta)
3820{
3821  TCR *tcr = current;
3822  xframe_list *xframes;
3823  LispObj *tlb_start, *tlb_end;
3824  ExceptionInformation *xp;
3825
3826  do {
3827    xp = tcr->gc_context;
3828    if (xp) {
3829      adjust_pointers_in_xp(xp, base, limit, delta);
3830    }
3831    for (xframes = (xframe_list *) tcr->xframe;
3832         xframes;
3833         xframes = xframes->prev) {
3834      adjust_pointers_in_xp(xframes->curr, base, limit, delta);
3835    }
3836    adjust_pointers_in_range(tcr->tlb_pointer,
3837                             (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
3838                             base,
3839                             limit,
3840                             delta);
3841    tcr = tcr->next;
3842  } while (tcr != current);
3843}
3844
3845void
3846nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit)
3847{
3848  TCR *tcr = current;
3849  xframe_list *xframes;
3850  LispObj *tlb_start, *tlb_end;
3851  ExceptionInformation *xp;
3852
3853  do {
3854    xp = tcr->gc_context;
3855    if (xp) {
3856      nuke_pointers_in_xp(xp, base, limit);
3857    }
3858    for (xframes = (xframe_list *) tcr->xframe;
3859         xframes;
3860         xframes = xframes->prev) {
3861      nuke_pointers_in_xp(xframes->curr, base, limit);
3862    }
3863    nuke_pointers_in_range(tcr->tlb_pointer,
3864                           (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
3865                           base,
3866                           limit);
3867    tcr = tcr->next;
3868  } while (tcr != current);
3869}
3870
3871void
3872adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta)
3873{
3874  /* These need to be special-cased, because xmacptrs are immediate
3875     objects that contain (in their "link" fields") tagged pointers
3876     to other xmacptrs */
3877  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
3878
3879  while ((next = *prev) != (LispObj)NULL) {
3880    adjust_noderef(prev, base, limit, delta);
3881    if (delta < 0) {
3882      /* Assume that we've already moved things */
3883      next = *prev;
3884    }
3885    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
3886  }
3887}
3888   
3889
3890void
3891adjust_pointers_in_dynamic_area(area *a, 
3892                                LispObj base, 
3893                                LispObj limit,
3894                                signed_natural delta)
3895{
3896  natural
3897    nstatic = static_dnodes_for_area(a),
3898    nstatic_bitmap_words = nstatic >> bitmap_shift;
3899  LispObj
3900    *low = (LispObj *) (a->low),
3901    *active = (LispObj *) (a->active),
3902    *dynamic_low = low + (2 * nstatic);
3903
3904  adjust_pointers_in_range(dynamic_low, active, base, limit, delta);
3905
3906  if (nstatic && (nstatic <= a->ndnodes)) {
3907    cons *pagelet_start = (cons *) a->low, *work;
3908    bitvector usedbits = tenured_area->static_used;
3909    natural used, i;
3910   
3911    while (nstatic_bitmap_words--) {
3912      used = *usedbits++;
3913
3914      while (used) {
3915        i = count_leading_zeros(used);
3916        used &= ~(BIT0_MASK >> i);
3917        work = pagelet_start+i;
3918        adjust_noderef(&(work->cdr), base, limit, delta);
3919        adjust_noderef(&(work->car), base, limit, delta);
3920      }
3921      pagelet_start += nbits_in_word;
3922    }
3923  }
3924}
3925
3926void
3927nuke_pointers_in_dynamic_area(area *a, 
3928                              LispObj base, 
3929                              LispObj limit)
3930{
3931  natural
3932    nstatic = static_dnodes_for_area(a),
3933    nstatic_bitmap_words = nstatic >> bitmap_shift;
3934  LispObj
3935    *low = (LispObj *) (a->low),
3936    *active = (LispObj *) (a->active),
3937    *dynamic_low = low + (2 * nstatic);
3938
3939  nuke_pointers_in_range(dynamic_low, active, base, limit);
3940
3941  if (nstatic && (nstatic <= a->ndnodes)) {
3942    cons *pagelet_start = (cons *) a->low, *work;
3943    bitvector usedbits = tenured_area->static_used;
3944    natural used, i;
3945   
3946    while (nstatic_bitmap_words--) {
3947      used = *usedbits++;
3948
3949      while (used) {
3950        i = count_leading_zeros(used);
3951        used &= ~(BIT0_MASK >> i);
3952        work = pagelet_start+i;
3953        nuke_noderef(&(work->cdr), base, limit);
3954        nuke_noderef(&(work->car), base, limit);
3955      }
3956      pagelet_start += nbits_in_word;
3957    }
3958  }
3959}
3960
3961   
3962void
3963adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta)
3964{
3965  area *next_area;
3966  area_code code;
3967
3968  for (next_area = active_dynamic_area; 
3969       (code = next_area->code) != AREA_VOID;
3970       next_area = next_area->succ) {
3971    switch (code) {
3972    case AREA_TSTACK:
3973      adjust_pointers_in_tstack_area(next_area, base, limit, delta);
3974      break;
3975     
3976    case AREA_VSTACK:
3977      adjust_pointers_in_vstack_area(next_area, base, limit, delta);
3978      break;
3979
3980    case AREA_CSTACK:
3981#ifndef X86
3982      adjust_pointers_in_cstack_area(next_area, base, limit, delta);
3983#endif
3984      break;
3985
3986    case AREA_STATIC:
3987    case AREA_MANAGED_STATIC:
3988      adjust_pointers_in_range((LispObj *) (next_area->low),
3989                               (LispObj *) (next_area->active),
3990                               base,
3991                               limit,
3992                               delta);
3993      break;
3994
3995    case AREA_DYNAMIC:
3996      adjust_pointers_in_dynamic_area(next_area, base, limit, delta);
3997      break;
3998    }
3999  }
4000  adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta);
4001  adjust_gcable_ptrs(base, limit, delta);
4002}
4003
4004void
4005nuke_all_pointers(LispObj base, LispObj limit)
4006{
4007  area *next_area;
4008  area_code code;
4009
4010  for (next_area = active_dynamic_area; 
4011       (code = next_area->code) != AREA_VOID;
4012       next_area = next_area->succ) {
4013    switch (code) {
4014    case AREA_TSTACK:
4015      nuke_pointers_in_tstack_area(next_area, base, limit);
4016      break;
4017     
4018    case AREA_VSTACK:
4019      nuke_pointers_in_vstack_area(next_area, base, limit);
4020      break;
4021
4022    case AREA_CSTACK:
4023      /* There aren't any "nukable" pointers in a cstack area */
4024      break;
4025
4026    case AREA_STATIC:
4027    case AREA_MANAGED_STATIC:
4028      nuke_pointers_in_range((LispObj *) (next_area->low),
4029                               (LispObj *) (next_area->active),
4030                               base,
4031                               limit);
4032      break;
4033
4034    case AREA_DYNAMIC:
4035      nuke_pointers_in_dynamic_area(next_area, base, limit);
4036      break;
4037    }
4038  }
4039  nuke_pointers_in_tcrs(get_tcr(false), base, limit);
4040}
4041
4042#ifndef MREMAP_MAYMOVE
4043#define MREMAP_MAYMOVE 1
4044#endif
4045
4046#if defined(FREEBSD) || defined(SOLARIS)
4047void *
4048freebsd_mremap(void *old_address, 
4049               size_t old_size, 
4050               size_t new_size, 
4051               unsigned long flags)
4052{
4053  return old_address;
4054}
4055#define mremap freebsd_mremap
4056
4057#endif
4058
4059#ifdef DARWIN
4060void *
4061darwin_mremap(void *old_address, 
4062              size_t old_size, 
4063              size_t new_size, 
4064              unsigned long flags)
4065{
4066  void *end = (void *) ((char *)old_address+old_size);
4067
4068  if (old_size == new_size) {
4069    return old_address;
4070  }
4071  if (new_size < old_size) {
4072    munmap(end, old_size-new_size);
4073    return old_address;
4074  }
4075  {
4076    void * new_address = mmap(NULL,
4077                              new_size,
4078                              PROT_READ|PROT_WRITE,
4079                              MAP_PRIVATE | MAP_ANON,
4080                              -1,
4081                              0);
4082    if (new_address !=  MAP_FAILED) {
4083      vm_copy(mach_task_self(),
4084              (vm_address_t)old_address,
4085              old_size,
4086              (vm_address_t)new_address);
4087      munmap(old_address, old_size);
4088    }
4089    return new_address;
4090  }
4091}
4092
4093#define mremap darwin_mremap
4094#endif
4095
4096Boolean
4097resize_used_bitvector(natural new_dnodes, bitvector *newbits)
4098{
4099  natural
4100    old_dnodes = tenured_area->static_dnodes,
4101    old_page_aligned_size =
4102    (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3),
4103                         log2_page_size)),
4104    new_page_aligned_size =
4105    (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3),
4106                         log2_page_size));
4107  bitvector old_used = tenured_area->static_used, new_used = NULL;
4108
4109  if (old_page_aligned_size == new_page_aligned_size) {
4110    *newbits = old_used;
4111    return true;
4112  }
4113
4114  if (old_used == NULL) {
4115    new_used = (bitvector)mmap(NULL,
4116                               new_page_aligned_size,
4117                               PROT_READ|PROT_WRITE,
4118                               MAP_PRIVATE | MAP_ANON,
4119                               -1,
4120                               0);
4121    if (new_used == MAP_FAILED) {
4122      *newbits = NULL;
4123      return false;
4124    } else {
4125      *newbits = new_used;
4126      return true;
4127    }
4128  }
4129  if (new_page_aligned_size == 0) {
4130    munmap((void *)old_used, old_page_aligned_size);
4131    *newbits = NULL;
4132    return true;
4133  }
4134   
4135  /* Have to try to remap the old bitmap.  That's implementation-dependent,
4136     and (naturally) Mach sucks, but no one understands how.
4137  */
4138  new_used = mremap(old_used, 
4139                    old_page_aligned_size, 
4140                    new_page_aligned_size, 
4141                    MREMAP_MAYMOVE);
4142  if (new_used == MAP_FAILED) {
4143    *newbits = NULL;
4144    return false;
4145  }
4146  *newbits = new_used;
4147  return true;
4148}
4149
4150 
4151int
4152grow_hons_area(signed_natural delta_in_bytes)
4153{
4154  bitvector new_used;
4155  area *ada = active_dynamic_area;
4156  natural
4157    delta_in_dnodes = delta_in_bytes >> dnode_shift,
4158    current_static_dnodes = tenured_area->static_dnodes,
4159    new_static_dnodes;
4160   
4161  delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word);
4162  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
4163  delta_in_bytes = delta_in_dnodes << dnode_shift;
4164  if (grow_dynamic_area((natural) delta_in_bytes)) {
4165    LispObj
4166      base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)),
4167      oldactive = (LispObj) ada->active,
4168      limit = area_dnode(oldactive, base);
4169    if (!resize_used_bitvector(new_static_dnodes, &new_used)) {
4170      shrink_dynamic_area(delta_in_bytes);
4171      return -1;
4172    }
4173    tenured_area->static_used = new_used;
4174    adjust_all_pointers(base, limit, delta_in_bytes);
4175    memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base);
4176    ada->ndnodes = area_dnode(ada->high, ada->low);
4177    ada->active += delta_in_bytes;
4178    {
4179      LispObj *p;
4180      natural i;
4181      for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0;
4182           i< delta_in_dnodes;
4183           i++ ) {
4184        *p++ = undefined;
4185        *p++ = undefined;
4186      }
4187      tenured_area->static_dnodes += delta_in_dnodes;
4188         
4189    }
4190    return 0;
4191  }
4192  return -1;
4193}
4194
4195int 
4196shrink_hons_area(signed_natural delta_in_bytes)
4197{
4198  area *ada = active_dynamic_area;
4199  signed_natural
4200    delta_in_dnodes = delta_in_bytes >> dnode_shift;
4201  natural
4202    current_static_dnodes = tenured_area->static_dnodes,
4203    new_static_dnodes;
4204  LispObj base, limit, oldactive;
4205  bitvector newbits;
4206
4207   
4208  delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word);
4209  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
4210  delta_in_bytes = delta_in_dnodes << dnode_shift;
4211  oldactive = (LispObj) (ada->active);
4212
4213  resize_used_bitvector(new_static_dnodes, &newbits);
4214  tenured_area->static_used = newbits; /* redundant */
4215
4216  memmove(ada->low+(new_static_dnodes << dnode_shift),
4217          ada->low+(current_static_dnodes << dnode_shift),
4218          oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift)));
4219  tenured_area->static_dnodes = new_static_dnodes;
4220  ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */
4221  shrink_dynamic_area(-delta_in_bytes);
4222
4223  base = (LispObj) (tenured_area->low + 
4224                    (new_static_dnodes << dnode_shift));
4225  limit = area_dnode(tenured_area->low + 
4226                     (current_static_dnodes << dnode_shift), base);
4227  nuke_all_pointers(base, limit);
4228
4229  base = (LispObj) (tenured_area->low + 
4230                    (current_static_dnodes << dnode_shift));
4231  limit = area_dnode(oldactive, base);
4232  adjust_all_pointers(base, limit, delta_in_bytes);
4233
4234  xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift),
4235                      ada->active-(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift)));
4236  return 0;
4237}
4238
4239int
4240change_hons_area_size(TCR *tcr, signed_natural delta_in_bytes)
4241{
4242  if (delta_in_bytes > 0) {
4243    return grow_hons_area(delta_in_bytes);
4244  }
4245  if (delta_in_bytes < 0) {
4246    return shrink_hons_area(delta_in_bytes);
4247  }
4248  return 0;
4249}
4250
Note: See TracBrowser for help on using the repository browser.