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

Last change on this file since 10104 was 10104, checked in by rme, 12 years ago

Remove unused function interned_pname_bytes_in_range().

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 59.1 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 = NULL;
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(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;
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
1442  if (dnode < GCndnodes_in_area) {
1443    lisp_global(FWDNUM) += (1<<fixnum_shift);
1444 
1445    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1446    while (dnode < GCndnodes_in_area) {
1447      if (bits == 0) {
1448        int remain = nbits_in_word - bitidx;
1449        dnode += remain;
1450        src += (remain+remain);
1451        bits = *++bitsp;
1452        bitidx = 0;
1453      } else {
1454        /* Have a non-zero markbits word; all bits more significant
1455           than "bitidx" are 0.  Count leading zeros in "bits"
1456           (there'll be at least "bitidx" of them.)  If there are more
1457           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1458           "src" by the difference. */
1459        nextbit = count_leading_zeros(bits);
1460        if ((diff = (nextbit - bitidx)) != 0) {
1461          dnode += diff;
1462          bitidx = nextbit;
1463          src += (diff+diff);
1464        }
1465        prev = current;
1466        current = src;
1467        if (GCDebug) {
1468          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1469            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1470                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1471          }
1472        }
1473
1474        node = *src++;
1475        tag = fulltag_of(node);
1476        if (nodeheader_tag_p(tag)) {
1477          elements = header_element_count(node);
1478          node_dnodes = (elements+2)>>1;
1479          dnode += node_dnodes;
1480          if (header_subtag(node) == subtag_function) {
1481            int skip = *((int *)src);
1482            *dest++ = node;
1483            elements -= skip;
1484            while(skip--) {
1485              *dest++ = *src++;
1486            }
1487            while(elements--) {
1488              *dest++ = node_forwarding_address(*src++);
1489            }
1490            if (((LispObj)src) & node_size) {
1491              src++;
1492              *dest++ = 0;
1493            }
1494          } else {
1495            if ((header_subtag(node) == subtag_hash_vector) &&
1496                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1497              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1498              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1499             
1500              *dest++ = node;
1501              elements -= skip;
1502              while(skip--) {
1503                *dest++ = node_forwarding_address(*src++);
1504              }
1505              /* There should be an even number of (key/value) pairs in elements;
1506                 an extra alignment word follows. */
1507              elements >>= 1;
1508              while (elements--) {
1509                if (hashp) {
1510                  node = *src++;
1511                  new = node_forwarding_address(node);
1512                  if (new != node) {
1513                    hashp->flags |= nhash_key_moved_mask;
1514                    hashp = NULL;
1515                    *dest++ = new;
1516                  } else {
1517                    *dest++ = node;
1518                  }
1519                } else {
1520                  *dest++ = node_forwarding_address(*src++);
1521                }
1522                *dest++ = node_forwarding_address(*src++);
1523              }
1524              *dest++ = 0;
1525              src++;
1526            } else {
1527              *dest++ = node;
1528              *dest++ = node_forwarding_address(*src++);
1529              while(--node_dnodes) {
1530                *dest++ = node_forwarding_address(*src++);
1531                *dest++ = node_forwarding_address(*src++);
1532              }
1533            }
1534          }
1535          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1536        } else if (immheader_tag_p(tag)) {
1537          *dest++ = node;
1538          *dest++ = *src++;
1539          elements = header_element_count(node);
1540          tag = header_subtag(node);
1541
1542
1543          switch(fulltag_of(tag)) {
1544          case ivector_class_64_bit:
1545            imm_dnodes = ((elements+1)+1)>>1;
1546            break;
1547          case ivector_class_32_bit:
1548            imm_dnodes = (((elements+2)+3)>>2);
1549            break;
1550          case ivector_class_other_bit:
1551            if (tag == subtag_bit_vector) {
1552              imm_dnodes = (((elements+64)+127)>>7);
1553            } else if (tag >= min_8_bit_ivector_subtag) {
1554              imm_dnodes = (((elements+8)+15)>>4);
1555            } else {
1556              imm_dnodes = (((elements+4)+7)>>3);
1557            }
1558          }
1559          dnode += imm_dnodes;
1560          while (--imm_dnodes) {
1561            *dest++ = *src++;
1562            *dest++ = *src++;
1563          }
1564          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1565        } else {
1566          *dest++ = node_forwarding_address(node);
1567          *dest++ = node_forwarding_address(*src++);
1568          bits &= ~(BIT0_MASK >> bitidx);
1569          dnode++;
1570          bitidx++;
1571        }
1572      }
1573 
1574    }
1575
1576  }
1577  return ptr_to_lispobj(dest);
1578}
1579
1580
1581
1582
1583
1584     
1585   
1586/*
1587  Total the (physical) byte sizes of all ivectors in the indicated memory range
1588*/
1589
1590natural
1591unboxed_bytes_in_range(LispObj *start, LispObj *end)
1592{
1593  natural total=0, elements, tag, subtag, bytes;
1594  LispObj header;
1595
1596  while (start < end) {
1597    header = *start;
1598    tag = fulltag_of(header);
1599   
1600    if ((nodeheader_tag_p(tag)) ||
1601        (immheader_tag_p(tag))) {
1602      elements = header_element_count(header);
1603      if (nodeheader_tag_p(tag)) {
1604        start += ((elements+2) & ~1);
1605      } else {
1606        subtag = header_subtag(header);
1607
1608        switch(fulltag_of(header)) {
1609        case ivector_class_64_bit:
1610          bytes = 8 + (elements<<3);
1611          break;
1612        case ivector_class_32_bit:
1613          bytes = 8 + (elements<<2);
1614          break;
1615        case ivector_class_other_bit:
1616        default:
1617          if (subtag == subtag_bit_vector) {
1618            bytes = 8 + ((elements+7)>>3);
1619          } else if (subtag >= min_8_bit_ivector_subtag) {
1620            bytes = 8 + elements;
1621          } else {
1622            bytes = 8 + (elements<<1);
1623          }
1624        }
1625        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1626        total += bytes;
1627        start += (bytes >> node_shift);
1628      }
1629    } else {
1630      start += 2;
1631    }
1632  }
1633  return total;
1634}
1635
1636
1637/*
1638  This assumes that it's getting called with a simple-{base,general}-string
1639  or code vector as an argument and that there's room for the object in the
1640  destination area.
1641*/
1642
1643
1644LispObj
1645purify_displaced_object(LispObj obj, area *dest, natural disp)
1646{
1647  BytePtr
1648    free = dest->active,
1649    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1650  LispObj
1651    header = header_of(obj), 
1652    new;
1653  natural
1654    start = (natural)old,
1655    physbytes;
1656
1657  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1658
1659  dest->active += physbytes;
1660
1661  new = ptr_to_lispobj(free)+disp;
1662
1663  memcpy(free, (BytePtr)old, physbytes);
1664  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1665  /* Actually, it's best to always leave a trail, for two reasons.
1666     a) We may be walking the same heap that we're leaving forwaring
1667     pointers in, so we don't want garbage that we leave behind to
1668     look like a header.
1669     b) We'd like to be able to forward code-vector locatives, and
1670     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1671     pair at every doubleword in the old vector.
1672     */
1673  while(physbytes) {
1674    *old++ = (BytePtr) forward_marker;
1675    *old++ = (BytePtr) free;
1676    free += dnode_size;
1677    physbytes -= dnode_size;
1678  }
1679  return new;
1680}
1681
1682LispObj
1683purify_object(LispObj obj, area *dest)
1684{
1685  return purify_displaced_object(obj, dest, fulltag_of(obj));
1686}
1687
1688Boolean
1689copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1690{
1691  LispObj obj = *ref, header, new;
1692  natural tag = fulltag_of(obj), header_tag;
1693  Boolean changed = false;
1694
1695  if ((tag == fulltag_misc) &&
1696      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1697      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1698    header = deref(obj, 0);
1699    if (header == forward_marker) { /* already copied */
1700      *ref = (untag(deref(obj,1)) + tag);
1701      changed = true;
1702    } else {
1703      header_tag = fulltag_of(header);
1704      if (immheader_tag_p(header_tag)) {
1705        if (header_subtag(header) != subtag_macptr) {
1706          new = purify_object(obj, dest);
1707          *ref = new;
1708          changed = (new != obj);
1709        }
1710      }
1711    }
1712  }
1713  return changed;
1714}
1715
1716
1717void
1718purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
1719{
1720  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
1721
1722  while ((*prev) != (LispObj)NULL) {
1723    copy_ivector_reference(prev, low, high, to);
1724    next = *prev;
1725    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1726  }
1727}
1728
1729void 
1730purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1731{
1732  while (start < end) { 
1733    copy_ivector_reference(start, low, high, to);
1734    start++;
1735  }
1736}
1737   
1738void
1739purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1740{
1741  LispObj header;
1742  unsigned tag;
1743  natural nwords;
1744  hash_table_vector_header *hashp;
1745
1746  while (start < end) {
1747    header = *start;
1748    if (header == forward_marker) {
1749      start += 2;
1750    } else {
1751      tag = fulltag_of(header);
1752      if (immheader_tag_p(tag)) {
1753        start = (LispObj *)skip_over_ivector((natural)start, header);
1754      } else if (nodeheader_tag_p(tag)) {
1755        nwords = header_element_count(header);
1756        nwords += (1 - (nwords&1));
1757        if ((header_subtag(header) == subtag_hash_vector) &&
1758          ((((hash_table_vector_header *)start)->flags) & 
1759           nhash_track_keys_mask)) {
1760          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1761
1762          hashp = (hash_table_vector_header *) start;
1763          start++;
1764          nwords -= skip;
1765          while(skip--) {
1766            copy_ivector_reference(start, low, high, to);
1767            start++;
1768          }
1769          /* "nwords" is odd at this point: there are (floor nwords 2)
1770             key/value pairs to look at, and then an extra word for
1771             alignment.  Process them two at a time, then bump "start"
1772             past the alignment word. */
1773          nwords >>= 1;
1774          while(nwords--) {
1775            if (copy_ivector_reference(start, low, high, to) && hashp) {
1776              hashp->flags |= nhash_key_moved_mask;
1777              hashp = NULL;
1778            }
1779            start++;
1780            copy_ivector_reference(start, low, high, to);
1781            start++;
1782          }
1783          *start++ = 0;
1784        } else {
1785          if (header_subtag(header) == subtag_function) {
1786            int skip = (int)(start[1]);
1787            start += skip;
1788            nwords -= skip;
1789          }
1790          start++;
1791          while(nwords--) {
1792            copy_ivector_reference(start, low, high, to);
1793            start++;
1794          }
1795        }
1796      } else {
1797        /* Not a header, just a cons cell */
1798        copy_ivector_reference(start, low, high, to);
1799        start++;
1800        copy_ivector_reference(start, low, high, to);
1801        start++;
1802      }
1803    }
1804  }
1805}
1806       
1807/* Purify references from tstack areas */
1808void
1809purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
1810{
1811  LispObj
1812    *current,
1813    *next,
1814    *start = (LispObj *) (a->active),
1815    *end = start,
1816    *limit = (LispObj *) (a->high);
1817
1818  for (current = start;
1819       end != limit;
1820       current = next) {
1821    next = (LispObj *) ptr_from_lispobj(*current);
1822    end = ((next >= start) && (next < limit)) ? next : limit;
1823    purify_range(current+2, end, low, high, to);
1824  }
1825}
1826
1827/* Purify a vstack area */
1828void
1829purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
1830{
1831  LispObj
1832    *p = (LispObj *) a->active,
1833    *q = (LispObj *) a->high;
1834 
1835  purify_headerless_range(p, q, low, high, to);
1836}
1837
1838
1839void
1840purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
1841{
1842  natural *regs = (natural *) xpGPRvector(xp);
1843
1844
1845#ifdef X8664
1846  copy_ivector_reference(&(regs[Iarg_z]), low, high, to);
1847  copy_ivector_reference(&(regs[Iarg_y]), low, high, to);
1848  copy_ivector_reference(&(regs[Iarg_x]), low, high, to);
1849  copy_ivector_reference(&(regs[Isave3]), low, high, to);
1850  copy_ivector_reference(&(regs[Isave2]), low, high, to);
1851  copy_ivector_reference(&(regs[Isave1]), low, high, to);
1852  copy_ivector_reference(&(regs[Isave0]), low, high, to);
1853  copy_ivector_reference(&(regs[Ifn]), low, high, to);
1854  copy_ivector_reference(&(regs[Itemp0]), low, high, to);
1855  copy_ivector_reference(&(regs[Itemp1]), low, high, to);
1856  copy_ivector_reference(&(regs[Itemp2]), low, high, to);
1857#if 0
1858  purify_locref(&(regs[Iip]), low, high, to);
1859#endif
1860#else
1861#endif
1862}
1863
1864void
1865purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
1866{
1867  natural n = tcr->tlb_limit;
1868  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
1869
1870  purify_range(start, end, low, high, to);
1871}
1872
1873void
1874purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
1875{
1876  xframe_list *xframes;
1877  ExceptionInformation *xp;
1878 
1879  xp = tcr->gc_context;
1880  if (xp) {
1881    purify_xp(xp, low, high, to);
1882  }
1883
1884  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1885    purify_xp(xframes->curr, low, high, to);
1886  }
1887}
1888
1889
1890void
1891purify_areas(BytePtr low, BytePtr high, area *target)
1892{
1893  area *next_area;
1894  area_code code;
1895     
1896  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1897    switch (code) {
1898    case AREA_TSTACK:
1899      purify_tstack_area(next_area, low, high, target);
1900      break;
1901     
1902    case AREA_VSTACK:
1903      purify_vstack_area(next_area, low, high, target);
1904      break;
1905     
1906    case AREA_CSTACK:
1907      break;
1908     
1909    case AREA_STATIC:
1910    case AREA_DYNAMIC:
1911      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
1912      break;
1913     
1914    default:
1915      break;
1916    }
1917  }
1918}
1919
1920/*
1921  So far, this is mostly for save_application's benefit.
1922  We -should- be able to return to lisp code after doing this,
1923  however.
1924
1925*/
1926
1927
1928int
1929purify(TCR *tcr, signed_natural param)
1930{
1931  extern area *extend_readonly_area(unsigned);
1932  area
1933    *a = active_dynamic_area,
1934    *new_pure_area;
1935
1936  TCR  *other_tcr;
1937  natural max_pure_size;
1938  BytePtr new_pure_start;
1939
1940
1941
1942  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
1943                                         (LispObj *) a->active);
1944  new_pure_area = extend_readonly_area(max_pure_size);
1945  if (new_pure_area) {
1946    new_pure_start = new_pure_area->active;
1947    lisp_global(IN_GC) = (1<<fixnumshift);
1948
1949    /*
1950
1951       
1952      Make the new_pure_area executable, just in case.
1953
1954      Caller will typically GC again (and that should recover quite a bit of
1955      the dynamic heap.)
1956      */
1957
1958
1959   
1960    purify_areas(a->low, a->active, new_pure_area);
1961   
1962    other_tcr = tcr;
1963    do {
1964      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
1965      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
1966      other_tcr = other_tcr->next;
1967    } while (other_tcr != tcr);
1968
1969    purify_gcable_ptrs(a->low, a->active, new_pure_area);
1970    {
1971      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
1972      if (puresize != 0) {
1973        xMakeDataExecutable(new_pure_start, puresize);
1974 
1975      }
1976    }
1977    ProtectMemory(new_pure_area->low,
1978                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
1979                                      log2_page_size));
1980    lisp_global(IN_GC) = 0;
1981    just_purified_p = true;
1982    return 0;
1983  }
1984  return -1;
1985}
1986
1987
1988 
1989Boolean
1990impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
1991{
1992  LispObj q = *p;
1993 
1994  if (is_node_fulltag(fulltag_of(q)) &&
1995      (q >= low) && 
1996      (q < high)) {
1997    *p = (q+delta);
1998    return true;
1999  }
2000  return false;
2001}
2002 
2003
2004void
2005impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2006{
2007  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2008
2009  while ((*prev) != (LispObj)NULL) {
2010    impurify_noderef(prev, low, high, delta);
2011    next = *prev;
2012    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2013  }
2014}
2015
2016
2017void
2018impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2019{
2020  natural *regs = (natural *) xpGPRvector(xp);
2021
2022
2023#ifdef X8664
2024  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2025  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2026  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2027  impurify_noderef(&(regs[Isave3]), low, high, delta);
2028  impurify_noderef(&(regs[Isave2]), low, high, delta);
2029  impurify_noderef(&(regs[Isave1]), low, high, delta);
2030  impurify_noderef(&(regs[Isave0]), low, high, delta);
2031  impurify_noderef(&(regs[Ifn]), low, high, delta);
2032  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2033  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2034#if 0
2035  impurify_locref(&(regs[Iip]), low, high, delta);
2036#endif
2037#else
2038#endif
2039
2040}
2041
2042void
2043impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2044{
2045  while (start < end) {
2046    impurify_noderef(start, low, high, delta);
2047    start++;
2048  }
2049}
2050
2051
2052void
2053impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2054{
2055  LispObj header;
2056  unsigned tag;
2057  natural nwords;
2058  hash_table_vector_header *hashp;
2059
2060  while (start < end) {
2061    header = *start;
2062    if (header == forward_marker) {
2063      start += 2;
2064    } else {
2065      tag = fulltag_of(header);
2066      if (immheader_tag_p(tag)) {
2067        start = (LispObj *)skip_over_ivector((natural)start, header);
2068      } else if (nodeheader_tag_p(tag)) {
2069        nwords = header_element_count(header);
2070        nwords += (1 - (nwords&1));
2071        if ((header_subtag(header) == subtag_hash_vector) &&
2072          ((((hash_table_vector_header *)start)->flags) & 
2073           nhash_track_keys_mask)) {
2074          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2075
2076          hashp = (hash_table_vector_header *) start;
2077          start++;
2078          nwords -= skip;
2079          while(skip--) {
2080            impurify_noderef(start, low, high, delta);
2081            start++;
2082          }
2083          /* "nwords" is odd at this point: there are (floor nwords 2)
2084             key/value pairs to look at, and then an extra word for
2085             alignment.  Process them two at a time, then bump "start"
2086             past the alignment word. */
2087          nwords >>= 1;
2088          while(nwords--) {
2089            if (impurify_noderef(start, low, high, delta) && hashp) {
2090              hashp->flags |= nhash_key_moved_mask;
2091              hashp = NULL;
2092            }
2093            start++;
2094            impurify_noderef(start, low, high, delta);
2095            start++;
2096          }
2097          *start++ = 0;
2098        } else {
2099          if (header_subtag(header) == subtag_function) {
2100            int skip = (int)(start[1]);
2101            start += skip;
2102            nwords -= skip;
2103          }
2104          start++;
2105          while(nwords--) {
2106            impurify_noderef(start, low, high, delta);
2107            start++;
2108          }
2109        }
2110      } else {
2111        /* Not a header, just a cons cell */
2112        impurify_noderef(start, low, high, delta);
2113        start++;
2114        impurify_noderef(start, low, high, delta);
2115        start++;
2116      }
2117    }
2118  }
2119}
2120
2121
2122
2123
2124void
2125impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2126{
2127  unsigned n = tcr->tlb_limit;
2128  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2129 
2130  impurify_range(start, end, low, high, delta);
2131}
2132
2133void
2134impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2135{
2136  xframe_list *xframes;
2137  ExceptionInformation *xp;
2138 
2139  xp = tcr->gc_context;
2140  if (xp) {
2141    impurify_xp(xp, low, high, delta);
2142  }
2143
2144  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2145    impurify_xp(xframes->curr, low, high, delta);
2146  }
2147}
2148
2149void
2150impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2151{
2152  LispObj
2153    *current,
2154    *next,
2155    *start = (LispObj *) (a->active),
2156    *end = start,
2157    *limit = (LispObj *) (a->high);
2158
2159  for (current = start;
2160       end != limit;
2161       current = next) {
2162    next = (LispObj *) ptr_from_lispobj(*current);
2163    end = ((next >= start) && (next < limit)) ? next : limit;
2164    if (current[1] == 0) {
2165      impurify_range(current+2, end, low, high, delta);
2166    }
2167  }
2168}
2169void
2170impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2171{
2172  LispObj
2173    *p = (LispObj *) a->active,
2174    *q = (LispObj *) a->high;
2175
2176  impurify_headerless_range(p, q, low, high, delta);
2177}
2178
2179
2180void
2181impurify_areas(LispObj low, LispObj high, signed_natural delta)
2182{
2183  area *next_area;
2184  area_code code;
2185     
2186  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2187    switch (code) {
2188    case AREA_TSTACK:
2189      impurify_tstack_area(next_area, low, high, delta);
2190      break;
2191     
2192    case AREA_VSTACK:
2193      impurify_vstack_area(next_area, low, high, delta);
2194      break;
2195     
2196    case AREA_CSTACK:
2197      break;
2198     
2199    case AREA_STATIC:
2200    case AREA_DYNAMIC:
2201      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2202      break;
2203     
2204    default:
2205      break;
2206    }
2207  }
2208}
2209
2210#ifdef WINDOWS
2211int
2212impurify(TCR *tcr, signed_natural param)
2213{
2214}
2215#else
2216int
2217impurify(TCR *tcr, signed_natural param)
2218{
2219  area *r = find_readonly_area();
2220
2221  if (r) {
2222    area *a = active_dynamic_area;
2223    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2224      oldhigh = a->high, newhigh; 
2225    unsigned n = ro_limit - ro_base;
2226    signed_natural delta = oldfree-ro_base;
2227    TCR *other_tcr;
2228
2229    if (n) {
2230      lisp_global(IN_GC) = 1;
2231      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2232                                               log2_heap_segment_size));
2233      if (newhigh > oldhigh) {
2234        grow_dynamic_area(newhigh-oldhigh);
2235      }
2236      a->active += n;
2237      memmove(oldfree, ro_base, n);
2238      munmap((void *)ro_base, n);
2239      a->ndnodes = area_dnode(a, a->active);
2240      pure_space_active = r->active = r->low;
2241      r->ndnodes = 0;
2242
2243      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2244
2245      other_tcr = tcr;
2246      do {
2247        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2248        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2249        other_tcr = other_tcr->next;
2250      } while (other_tcr != tcr);
2251
2252      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2253      lisp_global(IN_GC) = 0;
2254    }
2255    return 0;
2256  }
2257  return -1;
2258}
2259#endif
Note: See TracBrowser for help on using the repository browser.