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

Last change on this file since 13263 was 13263, checked in by gz, 11 years ago

Changes in handling of weak vectors (i.e. populations and weak hash vectors) in ephemeral gc. Depending on how these changes affect performance in different use cases, it might be necessary to make them user-configurable, but for now I just made them unconditional.

  • all populations (including in particular all terminable populations) are processed at every gc. In normal use, population data has newest conses at the front, and processing will terminate as soon as it reaches a cons not in the area being gc'd, so in practice this will only process cells actually added in the current generation, which should limit the performance impact on ephemeral gc.
  • all weak hash vectors that have keys in ephemeral areas are processed at every gc. (Unfortunately, that means weak-on-value hash tables are NOT processed during egc).
  • egc always uses the :non-circular weak processing method for hash vectors. This means that certain kinds of cross-references between weak keys and values in weak hash tables will keep objects from being collected during ephemeral gc.

Details:

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