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

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

Changes for x8632.

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