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

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

image.c: in prepare_to_write_dynamic_area(), don't skip frozen dnodes
when looking for macptrs to kill.
x86-gc.c, ppc-gc.c: in copy_ivector_reference(), don't purify macptrs:

1) they're small, and there usually aren't that many of them
2) they're mutable, though heap-allocated macptrs probably don't often

get written to after initialization

3) they need to be where prepare_to_write_dynamic_area() can find and

invalidate them.

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