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

Last change on this file since 7680 was 7680, checked in by gb, 12 years ago

back out of r7673

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