source: branches/working-0710/ccl/lisp-kernel/x86-gc.c @ 7418

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

Lots of changes to support new rwlocks, heap freeze, deferred GC.

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