source: branches/qres/ccl/lisp-kernel/x86-gc.c @ 15278

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

Third try, I think this approach works in all cases: keep hash tables
(as well as populations) on WEAKVLL. Handle weak-on-value hash tables
as well as weak-on-key. Don't mess with refbits, just special-case
weak hash vectors in mark_memoized_area. This leaves open the
possiblity of using refbits in mark_weak_hash_vector and reaphashv,
though I didn't do that yet (want to test what I've got so far).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 82.0 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" LISP "\n", 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  natural hash_dnode_limit = 0;
1228  hash_table_vector_header *hashp = NULL;
1229  int mark_method = 3;
1230
1231  if (GCDebug) {
1232    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1233  }
1234
1235  /* The distinction between "inbits" and "outbits" is supposed to help us
1236     detect cases where "uninteresting" setfs have been memoized.  Storing
1237     NIL, fixnums, immediates (characters, etc.) or node pointers to static
1238     or readonly areas is definitely uninteresting, but other cases are
1239     more complicated (and some of these cases are hard to detect.)
1240
1241     Some headers are "interesting", to the forwarder if not to us.
1242
1243     */
1244
1245  /*
1246    We need to ensure that there are no bits set at or beyond
1247    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
1248    tenures/untenures things.)  We find bits by grabbing a fullword at
1249    a time and doing a cntlzw instruction; and don't want to have to
1250    check for (< memo_dnode num_memo_dnodes) in the loop.
1251    */
1252
1253  {
1254    natural
1255      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
1256      index_of_last_word = (num_memo_dnodes >> bitmap_shift);
1257
1258    if (bits_in_last_word != 0) {
1259      natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1);
1260      refbits[index_of_last_word] &= mask;
1261    }
1262  }
1263       
1264  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1265  inbits = outbits = bits;
1266  while (memo_dnode < num_memo_dnodes) {
1267    if (bits == 0) {
1268      int remain = nbits_in_word - bitidx;
1269      memo_dnode += remain;
1270      p += (remain+remain);
1271      if (outbits != inbits) {
1272        *bitsp = outbits;
1273      }
1274      bits = *++bitsp;
1275      inbits = outbits = bits;
1276      bitidx = 0;
1277    } else {
1278      nextbit = count_leading_zeros(bits);
1279      if ((diff = (nextbit - bitidx)) != 0) {
1280        memo_dnode += diff;
1281        bitidx = nextbit;
1282        p += (diff+diff);
1283      }
1284      x1 = *p++;
1285      x2 = *p++;
1286      bits &= ~(BIT0_MASK >> bitidx);
1287
1288      if (hashp) {
1289        Boolean force_x1 = false;
1290        if ((memo_dnode >= hash_dnode_limit) && (mark_method == 3)) {
1291          /* if vector_header_count is odd, x1 might be the last word of the header */
1292          force_x1 = (hash_table_vector_header_count & 1) && (memo_dnode == hash_dnode_limit);
1293          /* was marking header, switch to data */
1294          hash_dnode_limit = area_dnode(((LispObj *)hashp)
1295                                        + 1
1296                                        + header_element_count(hashp->header),
1297                                        a->low);
1298          /* In traditional weak method, don't mark vector entries at all. */
1299          /* Otherwise mark the non-weak elements only */
1300          mark_method = ((lisp_global(WEAK_GC_METHOD) == 0) ? 0 :
1301                         ((hashp->flags & nhash_weak_value_mask)
1302                          ? (1 + (hash_table_vector_header_count & 1))
1303                          : (2 - (hash_table_vector_header_count & 1))));
1304        }
1305
1306        if (memo_dnode < hash_dnode_limit) {
1307          /* perhaps ignore one or both of the elements */
1308          if (!force_x1 && !(mark_method & 1)) x1 = 0;
1309          if (!(mark_method & 2)) x2 = 0;
1310        } else {
1311          hashp = NULL;
1312        }
1313      }
1314
1315      if (header_subtag(x1) == subtag_hash_vector) {
1316        if (hashp) Bug(NULL, "header inside hash vector?");
1317        hash_table_vector_header *hp = (hash_table_vector_header *)(p - 2);
1318        if (hp->flags & nhash_weak_mask) {
1319          /* If header_count is odd, this cuts off the last header field */
1320          /* That case is handled specially above */
1321          hash_dnode_limit = memo_dnode + ((hash_table_vector_header_count) >>1);
1322          hashp = hp;
1323          mark_method = 3;
1324        }
1325      }
1326
1327      keep_x1 = mark_ephemeral_root(x1);
1328      keep_x2 = mark_ephemeral_root(x2);
1329      if ((keep_x1 == false) && 
1330          (keep_x2 == false) &&
1331          (hashp == NULL)) {
1332        outbits &= ~(BIT0_MASK >> bitidx);
1333      }
1334      memo_dnode++;
1335      bitidx++;
1336    }
1337  }
1338  if (GCDebug) {
1339    p = (LispObj *) a->low;
1340    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1341  }
1342}
1343
1344void
1345mark_headerless_area_range(LispObj *start, LispObj *end)
1346{
1347  while (start < end) {
1348    mark_root(*start++);
1349  }
1350}
1351
1352void
1353mark_simple_area_range(LispObj *start, LispObj *end)
1354{
1355  LispObj x1, *base;
1356  int tag;
1357
1358  while (start < end) {
1359    x1 = *start;
1360    tag = fulltag_of(x1);
1361    if (immheader_tag_p(tag)) {
1362      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
1363    } else if (!nodeheader_tag_p(tag)) {
1364      ++start;
1365      mark_root(x1);
1366      mark_root(*start++);
1367    } else {
1368      int subtag = header_subtag(x1);
1369      natural element_count = header_element_count(x1);
1370      natural size = (element_count+1 + 1) & ~1;
1371
1372      if (subtag == subtag_hash_vector) {
1373        LispObj flags = ((hash_table_vector_header *) start)->flags;
1374
1375        if (flags & nhash_weak_mask) {
1376          ((hash_table_vector_header *) start)->cache_key = undefined;
1377          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1378          mark_weak_htabv((LispObj)start);
1379          element_count = 0;
1380        }
1381      } 
1382      if (subtag == subtag_pool) {
1383        start[1] = lisp_nil;
1384      }
1385
1386      if (subtag == subtag_weak) {
1387        natural weak_type = (natural) start[2];
1388        if (weak_type >> population_termination_bit)
1389          element_count -= 2;
1390        else
1391          element_count -= 1; 
1392        start[1] = GCweakvll;
1393        GCweakvll = ptr_to_lispobj(start);
1394      }
1395
1396      base = start + element_count + 1;
1397      if (subtag == subtag_function) {
1398#ifdef X8632
1399        natural skip = (unsigned short)start[1];
1400
1401        /* XXX bootstrapping */
1402        if (skip & 0x8000)
1403          skip = element_count - (skip & 0x7fff);
1404
1405        element_count -= skip;
1406
1407#else
1408        element_count -= (int)start[1];
1409#endif
1410      }
1411      while(element_count--) {
1412        mark_root(*--base);
1413      }
1414      start += size;
1415    }
1416  }
1417}
1418
1419
1420/* Mark a tstack area */
1421void
1422mark_tstack_area(area *a)
1423{
1424  LispObj
1425    *current,
1426    *next,
1427    *start = (LispObj *) (a->active),
1428    *end = start,
1429    *limit = (LispObj *) (a->high);
1430
1431  for (current = start;
1432       end != limit;
1433       current = next) {
1434    next = (LispObj *) ptr_from_lispobj(*current);
1435    end = ((next >= start) && (next < limit)) ? next : limit;
1436    mark_simple_area_range(current+2, end);
1437  }
1438}
1439
1440/*
1441  It's really important that headers never wind up in tagged registers.
1442  Those registers would (possibly) get pushed on the vstack and confuse
1443  the hell out of this routine.
1444
1445  vstacks are just treated as a "simple area range", possibly with
1446  an extra word at the top (where the area's active pointer points.)
1447  */
1448
1449void
1450mark_vstack_area(area *a)
1451{
1452  LispObj
1453    *start = (LispObj *) a->active,
1454    *end = (LispObj *) a->high;
1455
1456#if 0
1457  fprintf(dbgout, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end);
1458#endif
1459  mark_headerless_area_range(start, end);
1460}
1461
1462/* No lisp objects on cstack on x86, at least x86-64 */
1463void
1464mark_cstack_area(area *a)
1465{
1466}
1467
1468
1469/* Mark the lisp objects in an exception frame */
1470#ifdef X8664
1471void
1472mark_xp(ExceptionInformation *xp)
1473{
1474  natural *regs = (natural *) xpGPRvector(xp), dnode;
1475  LispObj rip;
1476   
1477 
1478
1479  mark_root(regs[Iarg_z]);
1480  mark_root(regs[Iarg_y]);
1481  mark_root(regs[Iarg_x]);
1482  mark_root(regs[Isave3]);
1483  mark_root(regs[Isave2]);
1484  mark_root(regs[Isave1]);
1485  mark_root(regs[Isave0]);
1486  mark_root(regs[Ifn]);
1487  mark_root(regs[Itemp0]);
1488  mark_root(regs[Itemp1]);
1489  mark_root(regs[Itemp2]);
1490  /* If the RIP isn't pointing into a marked function,
1491     we can -maybe- recover from that if it's tagged as
1492     a TRA. */
1493  rip = regs[Iip];
1494  dnode = gc_area_dnode(rip);
1495  if ((dnode < GCndnodes_in_area) &&
1496      (! ref_bit(GCmarkbits,dnode))) {
1497    if (tag_of(rip) == tag_tra) {
1498      mark_root(rip);
1499    } else if ((fulltag_of(rip) == fulltag_function) &&
1500               (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) &&
1501               (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) &&
1502               ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) {
1503      mark_root(rip);
1504    } else {
1505      Bug(NULL, "Can't find function for rip 0x%16lx",rip);
1506    }
1507  }
1508}
1509#else
1510void
1511mark_xp(ExceptionInformation *xp, natural node_regs_mask)
1512{
1513  natural *regs = (natural *) xpGPRvector(xp), dnode;
1514  LispObj eip;
1515  int i;
1516
1517  if (node_regs_mask & (1<<0)) mark_root(regs[REG_EAX]);
1518  if (node_regs_mask & (1<<1)) mark_root(regs[REG_ECX]);
1519  if (regs[REG_EFL] & EFL_DF) {
1520    /* DF set means EDX should be treated as an imm reg */
1521    ;
1522  } else
1523    if (node_regs_mask & (1<<2)) mark_root(regs[REG_EDX]);
1524
1525  if (node_regs_mask & (1<<3)) mark_root(regs[REG_EBX]);
1526  if (node_regs_mask & (1<<4)) mark_root(regs[REG_ESP]);
1527  if (node_regs_mask & (1<<5)) mark_root(regs[REG_EBP]);
1528  if (node_regs_mask & (1<<6)) mark_root(regs[REG_ESI]);
1529  if (node_regs_mask & (1<<7)) mark_root(regs[REG_EDI]);
1530
1531  /* If the EIP isn't pointing into a marked function, we're probably
1532     in trouble.  We can -maybe- recover from that if it's tagged as a
1533     TRA. */
1534  eip = regs[Ieip];
1535  dnode = gc_area_dnode(eip);
1536  if ((dnode < GCndnodes_in_area) &&
1537      (! ref_bit(GCmarkbits,dnode))) {
1538    if (fulltag_of(eip) == fulltag_tra) {
1539      mark_root(eip);
1540    } else if ((fulltag_of(eip) == fulltag_misc) &&
1541               (header_subtag(header_of(eip)) == subtag_function) &&
1542               (*(unsigned char *)eip == RECOVER_FN_OPCODE) &&
1543               (*(LispObj *)(eip + 1)) == eip) {
1544      mark_root(eip);
1545    } else {
1546      Bug(NULL, "Can't find function for eip 0x%4x", eip);
1547    }
1548  }
1549}
1550#endif
1551
1552/* A "pagelet" contains 32 doublewords.  The relocation table contains
1553   a word for each pagelet which defines the lowest address to which
1554   dnodes on that pagelet will be relocated.
1555
1556   The relocation address of a given pagelet is the sum of the relocation
1557   address for the preceding pagelet and the number of bytes occupied by
1558   marked objects on the preceding pagelet.
1559*/
1560
1561LispObj
1562calculate_relocation()
1563{
1564  LispObj *relocptr = GCrelocptr;
1565  LispObj current = GCareadynamiclow;
1566  bitvector
1567    markbits = GCdynamic_markbits;
1568  qnode *q = (qnode *) markbits;
1569  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1570  natural thesebits;
1571  LispObj first = 0;
1572
1573  if (npagelets) {
1574    do {
1575      *relocptr++ = current;
1576      thesebits = *markbits++;
1577      if (thesebits == ALL_ONES) {
1578        current += nbits_in_word*dnode_size;
1579        q += 4; /* sic */
1580      } else {
1581        if (!first) {
1582          first = current;
1583          while (thesebits & BIT0_MASK) {
1584            first += dnode_size;
1585            thesebits += thesebits;
1586          }
1587        }
1588        /* We're counting bits in qnodes in the wrong order here, but
1589           that's OK.  I think ... */
1590        current += one_bits(*q++);
1591        current += one_bits(*q++);
1592        current += one_bits(*q++);
1593        current += one_bits(*q++);
1594      }
1595    } while(--npagelets);
1596  }
1597  *relocptr++ = current;
1598  return first ? first : current;
1599}
1600
1601
1602#if 0
1603LispObj
1604dnode_forwarding_address(natural dnode, int tag_n)
1605{
1606  natural pagelet, nbits;
1607  unsigned int near_bits;
1608  LispObj new;
1609
1610  if (GCDebug) {
1611    if (! ref_bit(GCdynamic_markbits, dnode)) {
1612      Bug(NULL, "unmarked object being forwarded!\n");
1613    }
1614  }
1615
1616  pagelet = dnode >> bitmap_shift;
1617  nbits = dnode & bitmap_shift_count_mask;
1618  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
1619
1620  if (nbits < 32) {
1621    new = GCrelocptr[pagelet] + tag_n;;
1622    /* Increment "new" by the count of 1 bits which precede the dnode */
1623    if (near_bits == 0xffffffff) {
1624      return (new + (nbits << 4));
1625    } else {
1626      near_bits &= (0xffffffff00000000 >> nbits);
1627      if (nbits > 15) {
1628        new += one_bits(near_bits & 0xffff);
1629      }
1630      return (new + (one_bits(near_bits >> 16)));
1631    }
1632  } else {
1633    new = GCrelocptr[pagelet+1] + tag_n;
1634    nbits = 64-nbits;
1635
1636    if (near_bits == 0xffffffff) {
1637      return (new - (nbits << 4));
1638    } else {
1639      near_bits &= (1<<nbits)-1;
1640      if (nbits > 15) {
1641        new -= one_bits(near_bits >> 16);
1642      }
1643      return (new -  one_bits(near_bits & 0xffff));
1644    }
1645  }
1646}
1647#else
1648#ifdef X8664
1649/* Quicker, dirtier */
1650LispObj
1651dnode_forwarding_address(natural dnode, int tag_n)
1652{
1653  natural pagelet, nbits, marked;
1654  LispObj new;
1655
1656  if (GCDebug) {
1657    if (! ref_bit(GCdynamic_markbits, dnode)) {
1658      Bug(NULL, "unmarked object being forwarded!\n");
1659    }
1660  }
1661
1662  pagelet = dnode >> bitmap_shift;
1663  nbits = dnode & bitmap_shift_count_mask;
1664  new = GCrelocptr[pagelet] + tag_n;;
1665  if (nbits) {
1666    marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits);
1667    while (marked) {
1668      new += one_bits((qnode)marked);
1669      marked >>=16;
1670    }
1671  }
1672  return new;
1673}
1674#endif
1675#ifdef X8632
1676LispObj
1677dnode_forwarding_address(natural dnode, int tag_n)
1678{
1679  natural pagelet, nbits;
1680  unsigned short near_bits;
1681  LispObj new;
1682
1683  if (GCDebug) {
1684    if (! ref_bit(GCdynamic_markbits, dnode)) {
1685      Bug(NULL, "unmarked object being forwarded!\n");
1686    }
1687  }
1688
1689  pagelet = dnode >> 5;
1690  nbits = dnode & 0x1f;
1691  /* On little-endian x86, we have to flip the low bit of dnode>>4 to
1692     get the near_bits from the appropriate half-word. */
1693  near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1];
1694
1695  if (nbits < 16) {
1696    new = GCrelocptr[pagelet] + tag_n;;
1697    /* Increment "new" by the count of 1 bits which precede the dnode */
1698    if (near_bits == 0xffff) {
1699      return (new + (nbits << 3));
1700    } else {
1701      near_bits &= (0xffff0000 >> nbits);
1702      if (nbits > 7) {
1703        new += one_bits(near_bits & 0xff);
1704      }
1705      return (new + (one_bits(near_bits >> 8))); 
1706    }
1707  } else {
1708    new = GCrelocptr[pagelet+1] + tag_n;
1709    nbits = 32-nbits;
1710
1711    if (near_bits == 0xffff) {
1712      return (new - (nbits << 3));
1713    } else {
1714      near_bits &= (1<<nbits)-1;
1715      if (nbits > 7) {
1716        new -= one_bits(near_bits >> 8);
1717      }
1718      return (new - one_bits(near_bits & 0xff));
1719    }
1720  }
1721}
1722#endif
1723#endif
1724
1725LispObj
1726locative_forwarding_address(LispObj obj)
1727{
1728  int tag_n = fulltag_of(obj);
1729  natural dnode = gc_dynamic_area_dnode(obj);
1730
1731
1732  if ((dnode >= GCndynamic_dnodes_in_area) ||
1733      (obj < GCfirstunmarked)) {
1734    return obj;
1735  }
1736
1737  return dnode_forwarding_address(dnode, tag_n);
1738}
1739
1740
1741void
1742forward_headerless_range(LispObj *range_start, LispObj *range_end)
1743{
1744  LispObj *p = range_start;
1745
1746  while (p < range_end) {
1747    update_noderef(p);
1748    p++;
1749  }
1750}
1751
1752void
1753forward_range(LispObj *range_start, LispObj *range_end)
1754{
1755  LispObj *p = range_start, node, new;
1756  int tag_n;
1757  natural nwords;
1758  hash_table_vector_header *hashp;
1759
1760  while (p < range_end) {
1761    node = *p;
1762    tag_n = fulltag_of(node);
1763    if (immheader_tag_p(tag_n)) {
1764      p = (LispObj *) skip_over_ivector((natural) p, node);
1765    } else if (nodeheader_tag_p(tag_n)) {
1766      nwords = header_element_count(node);
1767      nwords += (1 - (nwords&1));
1768      if ((header_subtag(node) == subtag_hash_vector) &&
1769          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1770        natural skip = hash_table_vector_header_count-1;
1771        hashp = (hash_table_vector_header *) p;
1772        p++;
1773        nwords -= skip;
1774        while(skip--) {
1775          update_noderef(p);
1776          p++;
1777        }
1778        /* "nwords" is odd at this point: there are (floor nwords 2)
1779           key/value pairs to look at, and then an extra word for
1780           alignment.  Process them two at a time, then bump "p"
1781           past the alignment word. */
1782        nwords >>= 1;
1783        while(nwords--) {
1784          if (update_noderef(p) && hashp) {
1785            hashp->flags |= nhash_key_moved_mask;
1786            hashp = NULL;
1787          }
1788          p++;
1789          update_noderef(p);
1790          p++;
1791        }
1792        *p++ = 0;
1793      } else {
1794        if (header_subtag(node) == subtag_function) {
1795#ifdef X8632
1796          int skip = (unsigned short)(p[1]);
1797
1798          /* XXX bootstrapping */
1799          if (skip & 0x8000)
1800            skip = header_element_count(node) - (skip & 0x7fff);
1801
1802#else
1803          int skip = (int)(p[1]);
1804#endif
1805          p += skip;
1806          nwords -= skip;
1807        }
1808        p++;
1809        while(nwords--) {
1810          update_noderef(p);
1811          p++;
1812        }
1813      }
1814    } else {
1815      new = node_forwarding_address(node);
1816      if (new != node) {
1817        *p = new;
1818      }
1819      p++;
1820      update_noderef(p);
1821      p++;
1822    }
1823  }
1824}
1825
1826
1827
1828
1829
1830
1831/* Forward a tstack area */
1832void
1833forward_tstack_area(area *a)
1834{
1835  LispObj
1836    *current,
1837    *next,
1838    *start = (LispObj *) a->active,
1839    *end = start,
1840    *limit = (LispObj *) (a->high);
1841
1842  for (current = start;
1843       end != limit;
1844       current = next) {
1845    next = ptr_from_lispobj(*current);
1846    end = ((next >= start) && (next < limit)) ? next : limit;
1847    forward_range(current+2, end);
1848  }
1849}
1850
1851/* Forward a vstack area */
1852void
1853forward_vstack_area(area *a)
1854{
1855  LispObj
1856    *p = (LispObj *) a->active,
1857    *q = (LispObj *) a->high;
1858
1859  forward_headerless_range(p, q);
1860}
1861
1862/* Nothing of interest on x86 cstack */
1863void
1864forward_cstack_area(area *a)
1865{
1866}
1867
1868#ifdef X8664
1869void
1870forward_xp(ExceptionInformation *xp)
1871{
1872  natural *regs = (natural *) xpGPRvector(xp);
1873
1874  update_noderef(&(regs[Iarg_z]));
1875  update_noderef(&(regs[Iarg_y]));
1876  update_noderef(&(regs[Iarg_x]));
1877  update_noderef(&(regs[Isave3]));
1878  update_noderef(&(regs[Isave2]));
1879  update_noderef(&(regs[Isave1]));
1880  update_noderef(&(regs[Isave0]));
1881  update_noderef(&(regs[Ifn]));
1882  update_noderef(&(regs[Itemp0]));
1883  update_noderef(&(regs[Itemp1]));
1884  update_noderef(&(regs[Itemp2]));
1885  update_locref(&(regs[Iip]));
1886}
1887#else
1888void
1889forward_xp(ExceptionInformation *xp, natural node_regs_mask)
1890{
1891  natural *regs = (natural *) xpGPRvector(xp);
1892
1893  if (node_regs_mask & (1<<0)) update_noderef(&regs[REG_EAX]);
1894  if (node_regs_mask & (1<<1)) update_noderef(&regs[REG_ECX]);
1895
1896  if (regs[REG_EFL] & EFL_DF) {
1897    /* then EDX is an imm reg */
1898    ;
1899  } else
1900    if (node_regs_mask & (1<<2)) update_noderef(&regs[REG_EDX]);
1901
1902  if (node_regs_mask & (1<<3)) update_noderef(&regs[REG_EBX]);
1903  if (node_regs_mask & (1<<4)) update_noderef(&regs[REG_ESP]);
1904  if (node_regs_mask & (1<<5)) update_noderef(&regs[REG_EBP]);
1905  if (node_regs_mask & (1<<6)) update_noderef(&regs[REG_ESI]);
1906  if (node_regs_mask & (1<<7)) update_noderef(&regs[REG_EDI]);
1907
1908  update_locref(&(regs[Iip]));
1909}
1910#endif
1911
1912
1913void
1914forward_tcr_xframes(TCR *tcr)
1915{
1916  xframe_list *xframes;
1917  ExceptionInformation *xp;
1918
1919  xp = tcr->gc_context;
1920  if (xp) {
1921#ifdef X8664
1922    forward_xp(xp);
1923#else
1924    forward_xp(xp, tcr->node_regs_mask);
1925
1926    update_noderef(&tcr->save0);
1927    update_noderef(&tcr->save1);
1928    update_noderef(&tcr->save2);
1929    update_noderef(&tcr->save3);
1930    update_noderef(&tcr->next_method_context);
1931#endif
1932  }
1933  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1934#ifdef X8664
1935    forward_xp(xframes->curr);
1936#else
1937    forward_xp(xframes->curr, xframes->node_regs_mask);
1938#endif
1939  }
1940}
1941
1942
1943#ifdef X8632
1944void
1945update_self_references(LispObj *node)
1946{
1947  LispObj fn = fulltag_misc + (LispObj)node;
1948  unsigned char *p = (unsigned char *)node;
1949  natural i = imm_word_count(fn);
1950
1951  if (i) {
1952    natural offset = node[--i];
1953
1954    while (offset) {
1955      *(LispObj *)(p + offset) = fn;
1956      offset = node[--i];
1957    }
1958  }   
1959}
1960#endif
1961
1962/*
1963  Compact the dynamic heap (from GCfirstunmarked through its end.)
1964  Return the doublenode address of the new freeptr.
1965  */
1966
1967LispObj
1968compact_dynamic_heap()
1969{
1970  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
1971  natural
1972    elements, 
1973    dnode = gc_area_dnode(GCfirstunmarked), 
1974    node_dnodes = 0, 
1975    imm_dnodes = 0, 
1976    bitidx, 
1977    *bitsp, 
1978    bits, 
1979    nextbit, 
1980    diff;
1981  int tag;
1982  bitvector markbits = GCmarkbits;
1983
1984  if (dnode < GCndnodes_in_area) {
1985    lisp_global(FWDNUM) += (1<<fixnum_shift);
1986 
1987    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1988    while (dnode < GCndnodes_in_area) {
1989      if (bits == 0) {
1990        int remain = nbits_in_word - bitidx;
1991        dnode += remain;
1992        src += (remain+remain);
1993        bits = *++bitsp;
1994        bitidx = 0;
1995      } else {
1996        /* Have a non-zero markbits word; all bits more significant
1997           than "bitidx" are 0.  Count leading zeros in "bits"
1998           (there'll be at least "bitidx" of them.)  If there are more
1999           than "bitidx" leading zeros, bump "dnode", "bitidx", and
2000           "src" by the difference. */
2001        nextbit = count_leading_zeros(bits);
2002        if ((diff = (nextbit - bitidx)) != 0) {
2003          dnode += diff;
2004          bitidx = nextbit;
2005          src += (diff+diff);
2006        }
2007        prev = current;
2008        current = src;
2009        if (GCDebug) {
2010          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
2011            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x" LISP " to 0x" LISP ",\n expected to go to 0x" LISP "\n", 
2012                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
2013          }
2014        }
2015
2016        node = *src++;
2017        tag = fulltag_of(node);
2018        if (nodeheader_tag_p(tag)) {
2019          elements = header_element_count(node);
2020          node_dnodes = (elements+2)>>1;
2021          dnode += node_dnodes;
2022          if (header_subtag(node) == subtag_function) {
2023#ifdef X8632
2024            LispObj *f = dest;
2025            int skip = imm_word_count(fulltag_misc + (LispObj)current);
2026#else
2027            int skip = *((int *)src);
2028#endif
2029            *dest++ = node;
2030            if (skip) {
2031              elements -= skip;
2032              while(skip--) {
2033                *dest++ = *src++;
2034              }
2035#ifdef X8632
2036              update_self_references(f);
2037#endif
2038            }
2039            while(elements--) {
2040              *dest++ = node_forwarding_address(*src++);
2041            }
2042            if (((LispObj)src) & node_size) {
2043              src++;
2044              *dest++ = 0;
2045            }
2046          } else {
2047            if ((header_subtag(node) == subtag_hash_vector) &&
2048                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
2049              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
2050              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2051             
2052              *dest++ = node;
2053              elements -= skip;
2054              while(skip--) {
2055                *dest++ = node_forwarding_address(*src++);
2056              }
2057              /* There should be an even number of (key/value) pairs in elements;
2058                 an extra alignment word follows. */
2059              elements >>= 1;
2060              while (elements--) {
2061                if (hashp) {
2062                  node = *src++;
2063                  new = node_forwarding_address(node);
2064                  if (new != node) {
2065                    hashp->flags |= nhash_key_moved_mask;
2066                    hashp = NULL;
2067                    *dest++ = new;
2068                  } else {
2069                    *dest++ = node;
2070                  }
2071                } else {
2072                  *dest++ = node_forwarding_address(*src++);
2073                }
2074                *dest++ = node_forwarding_address(*src++);
2075              }
2076              *dest++ = 0;
2077              src++;
2078            } else {
2079              *dest++ = node;
2080              *dest++ = node_forwarding_address(*src++);
2081              while(--node_dnodes) {
2082                *dest++ = node_forwarding_address(*src++);
2083                *dest++ = node_forwarding_address(*src++);
2084              }
2085            }
2086          }
2087          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2088        } else if (immheader_tag_p(tag)) {
2089          *dest++ = node;
2090          *dest++ = *src++;
2091          elements = header_element_count(node);
2092          tag = header_subtag(node);
2093
2094#ifdef X8664
2095          switch(fulltag_of(tag)) {
2096          case ivector_class_64_bit:
2097            imm_dnodes = ((elements+1)+1)>>1;
2098            break;
2099          case ivector_class_32_bit:
2100            imm_dnodes = (((elements+2)+3)>>2);
2101            break;
2102          case ivector_class_other_bit:
2103            if (tag == subtag_bit_vector) {
2104              imm_dnodes = (((elements+64)+127)>>7);
2105            } else if (tag >= min_8_bit_ivector_subtag) {
2106              imm_dnodes = (((elements+8)+15)>>4);
2107            } else {
2108              imm_dnodes = (((elements+4)+7)>>3);
2109            }
2110          }
2111#endif
2112#ifdef X8632
2113          if (tag <= max_32_bit_ivector_subtag) {
2114            imm_dnodes = (((elements+1)+1)>>1);
2115          } else if (tag <= max_8_bit_ivector_subtag) {
2116            imm_dnodes = (((elements+4)+7)>>3);
2117          } else if (tag <= max_16_bit_ivector_subtag) {
2118            imm_dnodes = (((elements+2)+3)>>2);
2119          } else if (tag == subtag_bit_vector) {
2120            imm_dnodes = (((elements+32)+63)>>6);
2121          } else {
2122            imm_dnodes = elements+1;
2123          }
2124#endif
2125
2126          dnode += imm_dnodes;
2127          while (--imm_dnodes) {
2128            *dest++ = *src++;
2129            *dest++ = *src++;
2130          }
2131          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2132        } else {
2133          *dest++ = node_forwarding_address(node);
2134          *dest++ = node_forwarding_address(*src++);
2135          bits &= ~(BIT0_MASK >> bitidx);
2136          dnode++;
2137          bitidx++;
2138        }
2139      }
2140    }
2141  }
2142  return ptr_to_lispobj(dest);
2143}
2144
2145
2146
2147
2148
2149     
2150   
2151/*
2152  Total the (physical) byte sizes of all ivectors in the indicated memory range
2153*/
2154
2155natural
2156unboxed_bytes_in_range(LispObj *start, LispObj *end)
2157{
2158  natural total=0, elements, tag, subtag, bytes;
2159  LispObj header;
2160
2161  while (start < end) {
2162    header = *start;
2163    tag = fulltag_of(header);
2164   
2165    if ((nodeheader_tag_p(tag)) ||
2166        (immheader_tag_p(tag))) {
2167      elements = header_element_count(header);
2168      if (nodeheader_tag_p(tag)) {
2169        start += ((elements+2) & ~1);
2170      } else {
2171        subtag = header_subtag(header);
2172
2173#ifdef X8664
2174        switch(fulltag_of(header)) {
2175        case ivector_class_64_bit:
2176          bytes = 8 + (elements<<3);
2177          break;
2178        case ivector_class_32_bit:
2179          bytes = 8 + (elements<<2);
2180          break;
2181        case ivector_class_other_bit:
2182        default:
2183          if (subtag == subtag_bit_vector) {
2184            bytes = 8 + ((elements+7)>>3);
2185          } else if (subtag >= min_8_bit_ivector_subtag) {
2186            bytes = 8 + elements;
2187          } else {
2188            bytes = 8 + (elements<<1);
2189          }
2190        }
2191#endif
2192#ifdef X8632
2193          if (subtag <= max_32_bit_ivector_subtag) {
2194            bytes = 4 + (elements<<2);
2195          } else if (subtag <= max_8_bit_ivector_subtag) {
2196            bytes = 4 + elements;
2197          } else if (subtag <= max_16_bit_ivector_subtag) {
2198            bytes = 4 + (elements<<1);
2199          } else if (subtag == subtag_double_float_vector) {
2200            bytes = 8 + (elements<<3);
2201          } else {
2202            bytes = 4 + ((elements+7)>>3);
2203          }
2204#endif
2205
2206        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
2207        total += bytes;
2208        start += (bytes >> node_shift);
2209      }
2210    } else {
2211      start += 2;
2212    }
2213  }
2214  return total;
2215}
2216
2217
2218/*
2219  This assumes that it's getting called with a simple-{base,general}-string
2220  or code vector as an argument and that there's room for the object in the
2221  destination area.
2222*/
2223
2224
2225LispObj
2226purify_displaced_object(LispObj obj, area *dest, natural disp)
2227{
2228  BytePtr
2229    free = dest->active,
2230    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
2231  LispObj
2232    header = header_of(obj), 
2233    new;
2234  natural
2235    start = (natural)old,
2236    physbytes;
2237
2238  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
2239
2240  dest->active += physbytes;
2241
2242  new = ptr_to_lispobj(free)+disp;
2243
2244  memcpy(free, (BytePtr)old, physbytes);
2245  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
2246  /* Actually, it's best to always leave a trail, for two reasons.
2247     a) We may be walking the same heap that we're leaving forwaring
2248     pointers in, so we don't want garbage that we leave behind to
2249     look like a header.
2250     b) We'd like to be able to forward code-vector locatives, and
2251     it's easiest to do so if we leave a {forward_marker, dnode_locative}
2252     pair at every doubleword in the old vector.
2253     */
2254  while(physbytes) {
2255    *old++ = (BytePtr) forward_marker;
2256    *old++ = (BytePtr) free;
2257    free += dnode_size;
2258    physbytes -= dnode_size;
2259  }
2260  return new;
2261}
2262
2263LispObj
2264purify_object(LispObj obj, area *dest)
2265{
2266  return purify_displaced_object(obj, dest, fulltag_of(obj));
2267}
2268
2269Boolean
2270copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
2271{
2272  LispObj obj = *ref, header, new;
2273  natural tag = fulltag_of(obj), header_tag;
2274  Boolean changed = false;
2275
2276  if ((tag == fulltag_misc) &&
2277      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
2278      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
2279    header = deref(obj, 0);
2280    if (header == forward_marker) { /* already copied */
2281      *ref = (untag(deref(obj,1)) + tag);
2282      changed = true;
2283    } else {
2284      header_tag = fulltag_of(header);
2285      if (immheader_tag_p(header_tag)) {
2286        if (header_subtag(header) != subtag_macptr) {
2287          new = purify_object(obj, dest);
2288          *ref = new;
2289          changed = (new != obj);
2290        }
2291      }
2292    }
2293  }
2294  return changed;
2295}
2296
2297
2298void
2299purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
2300{
2301  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2302
2303  while ((*prev) != (LispObj)NULL) {
2304    copy_ivector_reference(prev, low, high, to);
2305    next = *prev;
2306    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2307  }
2308}
2309
2310void 
2311purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
2312{
2313  while (start < end) { 
2314    copy_ivector_reference(start, low, high, to);
2315    start++;
2316  }
2317}
2318   
2319void
2320purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
2321{
2322  LispObj header;
2323  unsigned tag;
2324  natural nwords;
2325  hash_table_vector_header *hashp;
2326
2327  while (start < end) {
2328    header = *start;
2329    if (header == forward_marker) {
2330      start += 2;
2331    } else {
2332      tag = fulltag_of(header);
2333      if (immheader_tag_p(tag)) {
2334        start = (LispObj *)skip_over_ivector((natural)start, header);
2335      } else if (nodeheader_tag_p(tag)) {
2336        nwords = header_element_count(header);
2337        nwords += (1 - (nwords&1));
2338        if ((header_subtag(header) == subtag_hash_vector) &&
2339          ((((hash_table_vector_header *)start)->flags) & 
2340           nhash_track_keys_mask)) {
2341          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2342
2343          hashp = (hash_table_vector_header *) start;
2344          start++;
2345          nwords -= skip;
2346          while(skip--) {
2347            copy_ivector_reference(start, low, high, to);
2348            start++;
2349          }
2350          /* "nwords" is odd at this point: there are (floor nwords 2)
2351             key/value pairs to look at, and then an extra word for
2352             alignment.  Process them two at a time, then bump "start"
2353             past the alignment word. */
2354          nwords >>= 1;
2355          while(nwords--) {
2356            if (copy_ivector_reference(start, low, high, to) && hashp) {
2357              hashp->flags |= nhash_key_moved_mask;
2358              hashp = NULL;
2359            }
2360            start++;
2361            copy_ivector_reference(start, low, high, to);
2362            start++;
2363          }
2364          *start++ = 0;
2365        } else {
2366          if (header_subtag(header) == subtag_function) {
2367#ifdef X8632
2368            int skip = (unsigned short)(start[1]);
2369
2370            /* XXX bootstrapping */
2371            if (skip & 0x8000)
2372              skip = header_element_count(header) - (skip & 0x7fff);
2373#else
2374            int skip = (int)(start[1]);
2375#endif
2376            start += skip;
2377            nwords -= skip;
2378          }
2379          start++;
2380          while(nwords--) {
2381            copy_ivector_reference(start, low, high, to);
2382            start++;
2383          }
2384        }
2385      } else {
2386        /* Not a header, just a cons cell */
2387        copy_ivector_reference(start, low, high, to);
2388        start++;
2389        copy_ivector_reference(start, low, high, to);
2390        start++;
2391      }
2392    }
2393  }
2394}
2395       
2396/* Purify references from tstack areas */
2397void
2398purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
2399{
2400  LispObj
2401    *current,
2402    *next,
2403    *start = (LispObj *) (a->active),
2404    *end = start,
2405    *limit = (LispObj *) (a->high);
2406
2407  for (current = start;
2408       end != limit;
2409       current = next) {
2410    next = (LispObj *) ptr_from_lispobj(*current);
2411    end = ((next >= start) && (next < limit)) ? next : limit;
2412    purify_range(current+2, end, low, high, to);
2413  }
2414}
2415
2416/* Purify a vstack area */
2417void
2418purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
2419{
2420  LispObj
2421    *p = (LispObj *) a->active,
2422    *q = (LispObj *) a->high;
2423 
2424  purify_headerless_range(p, q, low, high, to);
2425}
2426
2427
2428void
2429purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
2430{
2431  natural *regs = (natural *) xpGPRvector(xp);
2432
2433
2434#ifdef X8664
2435  copy_ivector_reference(&(regs[Iarg_z]), low, high, to);
2436  copy_ivector_reference(&(regs[Iarg_y]), low, high, to);
2437  copy_ivector_reference(&(regs[Iarg_x]), low, high, to);
2438  copy_ivector_reference(&(regs[Isave3]), low, high, to);
2439  copy_ivector_reference(&(regs[Isave2]), low, high, to);
2440  copy_ivector_reference(&(regs[Isave1]), low, high, to);
2441  copy_ivector_reference(&(regs[Isave0]), low, high, to);
2442  copy_ivector_reference(&(regs[Ifn]), low, high, to);
2443  copy_ivector_reference(&(regs[Itemp0]), low, high, to);
2444  copy_ivector_reference(&(regs[Itemp1]), low, high, to);
2445  copy_ivector_reference(&(regs[Itemp2]), low, high, to);
2446#if 0
2447  purify_locref(&(regs[Iip]), low, high, to);
2448#endif
2449#else
2450#endif
2451}
2452
2453void
2454purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
2455{
2456  natural n = tcr->tlb_limit;
2457  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2458
2459  purify_range(start, end, low, high, to);
2460}
2461
2462void
2463purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
2464{
2465  xframe_list *xframes;
2466  ExceptionInformation *xp;
2467 
2468  xp = tcr->gc_context;
2469  if (xp) {
2470    purify_xp(xp, low, high, to);
2471  }
2472
2473  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2474    purify_xp(xframes->curr, low, high, to);
2475  }
2476}
2477
2478
2479void
2480purify_areas(BytePtr low, BytePtr high, area *target)
2481{
2482  area *next_area;
2483  area_code code;
2484     
2485  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2486    switch (code) {
2487    case AREA_TSTACK:
2488      purify_tstack_area(next_area, low, high, target);
2489      break;
2490     
2491    case AREA_VSTACK:
2492      purify_vstack_area(next_area, low, high, target);
2493      break;
2494     
2495    case AREA_CSTACK:
2496      break;
2497     
2498    case AREA_STATIC:
2499    case AREA_DYNAMIC:
2500      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
2501      break;
2502     
2503    default:
2504      break;
2505    }
2506  }
2507}
2508
2509/*
2510  So far, this is mostly for save_application's benefit.
2511  We -should- be able to return to lisp code after doing this,
2512  however.
2513
2514*/
2515
2516
2517signed_natural
2518purify(TCR *tcr, signed_natural param)
2519{
2520  extern area *extend_readonly_area(unsigned);
2521  area
2522    *a = active_dynamic_area,
2523    *new_pure_area;
2524
2525  TCR  *other_tcr;
2526  natural max_pure_size;
2527  BytePtr new_pure_start,
2528    low = (a->low + (static_dnodes_for_area(a) << dnode_shift)),
2529    high = a->active;
2530
2531
2532  max_pure_size = unboxed_bytes_in_range((LispObj *) low, (LispObj *) high);
2533  new_pure_area = extend_readonly_area(max_pure_size);
2534  if (new_pure_area) {
2535    new_pure_start = new_pure_area->active;
2536    lisp_global(IN_GC) = (1<<fixnumshift);
2537
2538    /*
2539
2540       
2541      Make the new_pure_area executable, just in case.
2542
2543      Caller will typically GC again (and that should recover quite a bit of
2544      the dynamic heap.)
2545      */
2546
2547
2548   
2549    purify_areas(low, high, new_pure_area);
2550   
2551    other_tcr = tcr;
2552    do {
2553      purify_tcr_xframes(other_tcr, low, high, new_pure_area);
2554      purify_tcr_tlb(other_tcr, low, high, new_pure_area);
2555      other_tcr = other_tcr->next;
2556    } while (other_tcr != tcr);
2557
2558    purify_gcable_ptrs(low, high, new_pure_area);
2559    {
2560      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2561      if (puresize != 0) {
2562        xMakeDataExecutable(new_pure_start, puresize);
2563 
2564      }
2565    }
2566    ProtectMemory(new_pure_area->low,
2567                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2568                                      log2_page_size));
2569    lisp_global(IN_GC) = 0;
2570    just_purified_p = true;
2571    return 0;
2572  }
2573  return -1;
2574}
2575
2576
2577 
2578Boolean
2579impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2580{
2581  LispObj q = *p;
2582 
2583  if (is_node_fulltag(fulltag_of(q)) &&
2584      (q >= low) && 
2585      (q < high)) {
2586    *p = (q+delta);
2587    return true;
2588  }
2589  return false;
2590}
2591 
2592
2593void
2594impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2595{
2596  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2597
2598  while ((*prev) != (LispObj)NULL) {
2599    impurify_noderef(prev, low, high, delta);
2600    next = *prev;
2601    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2602  }
2603}
2604
2605
2606void
2607impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2608{
2609  natural *regs = (natural *) xpGPRvector(xp);
2610
2611
2612#ifdef X8664
2613  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2614  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2615  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2616#ifndef WINDOWS
2617  impurify_noderef(&(regs[Isave3]), low, high, delta);
2618#endif
2619  impurify_noderef(&(regs[Isave2]), low, high, delta);
2620  impurify_noderef(&(regs[Isave1]), low, high, delta);
2621  impurify_noderef(&(regs[Isave0]), low, high, delta);
2622  impurify_noderef(&(regs[Ifn]), low, high, delta);
2623  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2624  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2625#if 0
2626  impurify_locref(&(regs[Iip]), low, high, delta);
2627#endif
2628#else
2629#endif
2630
2631}
2632
2633void
2634impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2635{
2636  while (start < end) {
2637    impurify_noderef(start, low, high, delta);
2638    start++;
2639  }
2640}
2641
2642
2643void
2644impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2645{
2646  LispObj header;
2647  unsigned tag;
2648  natural nwords;
2649  hash_table_vector_header *hashp;
2650
2651  while (start < end) {
2652    header = *start;
2653    if (header == forward_marker) {
2654      start += 2;
2655    } else {
2656      tag = fulltag_of(header);
2657      if (immheader_tag_p(tag)) {
2658        start = (LispObj *)skip_over_ivector((natural)start, header);
2659      } else if (nodeheader_tag_p(tag)) {
2660        nwords = header_element_count(header);
2661        nwords += (1 - (nwords&1));
2662        if ((header_subtag(header) == subtag_hash_vector) &&
2663          ((((hash_table_vector_header *)start)->flags) & 
2664           nhash_track_keys_mask)) {
2665          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2666
2667          hashp = (hash_table_vector_header *) start;
2668          start++;
2669          nwords -= skip;
2670          while(skip--) {
2671            impurify_noderef(start, low, high, delta);
2672            start++;
2673          }
2674          /* "nwords" is odd at this point: there are (floor nwords 2)
2675             key/value pairs to look at, and then an extra word for
2676             alignment.  Process them two at a time, then bump "start"
2677             past the alignment word. */
2678          nwords >>= 1;
2679          while(nwords--) {
2680            if (impurify_noderef(start, low, high, delta) && hashp) {
2681              hashp->flags |= nhash_key_moved_mask;
2682              hashp = NULL;
2683            }
2684            start++;
2685            impurify_noderef(start, low, high, delta);
2686            start++;
2687          }
2688          *start++ = 0;
2689        } else {
2690          if (header_subtag(header) == subtag_function) {
2691#ifdef X8632
2692            int skip = (unsigned short)start[1];
2693#else
2694            int skip = (int)(start[1]);
2695#endif
2696            start += skip;
2697            nwords -= skip;
2698          }
2699          start++;
2700          while(nwords--) {
2701            impurify_noderef(start, low, high, delta);
2702            start++;
2703          }
2704        }
2705      } else {
2706        /* Not a header, just a cons cell */
2707        impurify_noderef(start, low, high, delta);
2708        start++;
2709        impurify_noderef(start, low, high, delta);
2710        start++;
2711      }
2712    }
2713  }
2714}
2715
2716
2717
2718
2719void
2720impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2721{
2722  unsigned n = tcr->tlb_limit;
2723  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2724 
2725  impurify_range(start, end, low, high, delta);
2726}
2727
2728void
2729impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2730{
2731  xframe_list *xframes;
2732  ExceptionInformation *xp;
2733 
2734  xp = tcr->gc_context;
2735  if (xp) {
2736    impurify_xp(xp, low, high, delta);
2737  }
2738
2739  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2740    impurify_xp(xframes->curr, low, high, delta);
2741  }
2742}
2743
2744void
2745impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2746{
2747  LispObj
2748    *current,
2749    *next,
2750    *start = (LispObj *) (a->active),
2751    *end = start,
2752    *limit = (LispObj *) (a->high);
2753
2754  for (current = start;
2755       end != limit;
2756       current = next) {
2757    next = (LispObj *) ptr_from_lispobj(*current);
2758    end = ((next >= start) && (next < limit)) ? next : limit;
2759    if (current[1] == 0) {
2760      impurify_range(current+2, end, low, high, delta);
2761    }
2762  }
2763}
2764void
2765impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2766{
2767  LispObj
2768    *p = (LispObj *) a->active,
2769    *q = (LispObj *) a->high;
2770
2771  impurify_headerless_range(p, q, low, high, delta);
2772}
2773
2774
2775void
2776impurify_areas(LispObj low, LispObj high, signed_natural delta)
2777{
2778  area *next_area;
2779  area_code code;
2780     
2781  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2782    switch (code) {
2783    case AREA_TSTACK:
2784      impurify_tstack_area(next_area, low, high, delta);
2785      break;
2786     
2787    case AREA_VSTACK:
2788      impurify_vstack_area(next_area, low, high, delta);
2789      break;
2790     
2791    case AREA_CSTACK:
2792      break;
2793     
2794    case AREA_STATIC:
2795    case AREA_DYNAMIC:
2796      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2797      break;
2798     
2799    default:
2800      break;
2801    }
2802  }
2803}
2804
2805signed_natural
2806impurify(TCR *tcr, signed_natural param)
2807{
2808  area *r = find_readonly_area();
2809
2810  if (r) {
2811    area *a = active_dynamic_area;
2812    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2813      oldhigh = a->high, newhigh; 
2814    unsigned n = ro_limit - ro_base;
2815    signed_natural delta = oldfree-ro_base;
2816    TCR *other_tcr;
2817
2818    if (n) {
2819      lisp_global(IN_GC) = 1;
2820      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2821                                               log2_heap_segment_size));
2822      if (newhigh > oldhigh) {
2823        grow_dynamic_area(newhigh-oldhigh);
2824      }
2825      a->active += n;
2826      memmove(oldfree, ro_base, n);
2827      UnMapMemory((void *)ro_base, n);
2828      a->ndnodes = area_dnode(a, a->active);
2829      pure_space_active = r->active = r->low;
2830      r->ndnodes = 0;
2831
2832      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2833
2834      other_tcr = tcr;
2835      do {
2836        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2837        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2838        other_tcr = other_tcr->next;
2839      } while (other_tcr != tcr);
2840
2841      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2842      lisp_global(IN_GC) = 0;
2843    }
2844    return 0;
2845  }
2846  return -1;
2847}
2848
2849/*
2850 * This stuff is all adapted from the forward_xxx functions for use by
2851 * the watchpoint code.  It's a lot of duplicated code, and it would
2852 * be nice to generalize it somehow.
2853 */
2854
2855static inline int
2856wp_maybe_update(LispObj *p, LispObj old, LispObj new)
2857{
2858  if (*p == old) {
2859    *p = new;
2860    return true;
2861  }
2862  return false;
2863}
2864
2865static void
2866wp_update_headerless_range(LispObj *start, LispObj *end,
2867                           LispObj old, LispObj new)
2868{
2869  LispObj *p = start;
2870
2871  while (p < end) {
2872    wp_maybe_update(p, old, new);
2873    p++;
2874  }
2875}
2876
2877static void
2878wp_update_range(LispObj *start, LispObj *end, LispObj old, LispObj new)
2879{
2880  LispObj *p = start, node;
2881  int tag_n;
2882  natural nwords;
2883
2884  while (p < end) {
2885    node = *p;
2886    tag_n = fulltag_of(node);
2887
2888    if (immheader_tag_p(tag_n)) {
2889      p = (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node);
2890    } else if (nodeheader_tag_p(tag_n)) {
2891      nwords = header_element_count(node);
2892      nwords += 1 - (nwords & 1);
2893
2894      if ((header_subtag(node) == subtag_hash_vector) &&
2895          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
2896        natural skip = hash_table_vector_header_count - 1;
2897        hash_table_vector_header *hashp = (hash_table_vector_header *)p;
2898
2899        p++;
2900        nwords -= skip;
2901        while(skip--) {
2902          wp_maybe_update(p, old, new);
2903          p++;
2904        }
2905        /* "nwords" is odd at this point: there are (floor nwords 2)
2906           key/value pairs to look at, and then an extra word for
2907           alignment.  Process them two at a time, then bump "p"
2908           past the alignment word. */
2909        nwords >>= 1;
2910        while(nwords--) {
2911          if (wp_maybe_update(p, old, new) && hashp) {
2912            hashp->flags |= nhash_key_moved_mask;
2913            hashp = NULL;
2914          }
2915          p++;
2916          wp_maybe_update(p, old, new);
2917          p++;
2918        }
2919        *p++ = 0;
2920      } else {
2921        if (header_subtag(node) == subtag_function) {
2922#ifdef X8632
2923          int skip = (unsigned short)(p[1]);
2924
2925          /* XXX bootstrapping */
2926          if (skip & 0x8000)
2927            skip = header_element_count(node) - (skip & 0x7fff);
2928
2929#else
2930          int skip = (int)(p[1]);
2931#endif
2932          p += skip;
2933          nwords -= skip;
2934        }
2935        p++;
2936        while(nwords--) {
2937          wp_maybe_update(p, old, new);
2938          p++;
2939        }
2940      }
2941    } else {
2942      /* a cons cell */
2943      wp_maybe_update(p, old, new);
2944      p++;
2945      wp_maybe_update(p, old, new);
2946      p++;
2947    }
2948  }
2949}
2950
2951#ifdef X8664
2952static void
2953wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new)
2954{
2955  natural *regs = (natural *)xpGPRvector(xp);
2956
2957  wp_maybe_update(&regs[Iarg_z], old, new);
2958  wp_maybe_update(&regs[Iarg_y], old, new);
2959  wp_maybe_update(&regs[Iarg_x], old, new);
2960  wp_maybe_update(&regs[Isave3], old, new);
2961  wp_maybe_update(&regs[Isave2], old, new);
2962  wp_maybe_update(&regs[Isave1], old, new);
2963  wp_maybe_update(&regs[Isave0], old, new);
2964  wp_maybe_update(&regs[Ifn], old, new);
2965  wp_maybe_update(&regs[Itemp0], old, new);
2966  wp_maybe_update(&regs[Itemp1], old, new);
2967  wp_maybe_update(&regs[Itemp2], old, new);
2968
2969#if 0
2970  /*
2971   * We don't allow watching functions, so this presumably doesn't
2972   * matter.
2973   */
2974  update_locref(&(regs[Iip]));
2975#endif
2976}
2977#else
2978static void
2979wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new, natural node_regs_mask)
2980{
2981  natural *regs = (natural *)xpGPRvector(xp);
2982
2983  if (node_regs_mask & (1<<0)) wp_maybe_update(&regs[REG_EAX], old, new);
2984  if (node_regs_mask & (1<<1)) wp_maybe_update(&regs[REG_ECX], old, new);
2985
2986  if (regs[REG_EFL] & EFL_DF) {
2987    /* then EDX is an imm reg */
2988    ;
2989  } else
2990    if (node_regs_mask & (1<<2)) wp_maybe_update(&regs[REG_EDX], old, new);
2991
2992  if (node_regs_mask & (1<<3)) wp_maybe_update(&regs[REG_EBX], old, new);
2993  if (node_regs_mask & (1<<4)) wp_maybe_update(&regs[REG_ESP], old, new);
2994  if (node_regs_mask & (1<<5)) wp_maybe_update(&regs[REG_EBP], old, new);
2995  if (node_regs_mask & (1<<6)) wp_maybe_update(&regs[REG_ESI], old, new);
2996  if (node_regs_mask & (1<<7)) wp_maybe_update(&regs[REG_EDI], old, new);
2997  /* we shouldn't watch functions, so no need to update PC */
2998}
2999#endif
3000
3001static void
3002wp_update_tcr_xframes(TCR *tcr, LispObj old, LispObj new)
3003{
3004  xframe_list *xframes;
3005  ExceptionInformation *xp;
3006
3007  xp = tcr->gc_context;
3008  if (xp) {
3009#ifdef X8664
3010    wp_update_xp(xp, old, new);
3011#else
3012    wp_update_xp(xp, old, new, tcr->node_regs_mask);
3013    wp_maybe_update(&tcr->save0, old, new);
3014    wp_maybe_update(&tcr->save1, old, new);
3015    wp_maybe_update(&tcr->save2, old, new);
3016    wp_maybe_update(&tcr->save3, old, new);
3017    wp_maybe_update(&tcr->next_method_context, old, new);
3018#endif
3019  }
3020  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
3021#ifdef X8664
3022    wp_update_xp(xframes->curr, old, new);
3023#else
3024    wp_update_xp(xframes->curr, old, new, xframes->node_regs_mask);
3025#endif
3026  }
3027}
3028
3029/*
3030 * Scan all pointer-bearing areas, updating all references to
3031 * "old" to "new".
3032 */
3033static void
3034wp_update_all_areas(LispObj old, LispObj new)
3035{
3036  area *a = active_dynamic_area;
3037  natural code = a->code;
3038
3039  while (code != AREA_VOID) {
3040    switch (code) {
3041      case AREA_DYNAMIC:
3042      case AREA_STATIC:
3043      case AREA_MANAGED_STATIC:
3044      case AREA_WATCHED:
3045        wp_update_range((LispObj *)a->low, (LispObj *)a->active, old, new);
3046        break;
3047      case AREA_VSTACK:
3048      {
3049        LispObj *low = (LispObj *)a->active;
3050        LispObj *high = (LispObj *)a->high;
3051       
3052        wp_update_headerless_range(low, high, old, new);
3053      }
3054      break;
3055      case AREA_TSTACK:
3056      {
3057        LispObj *current, *next;
3058        LispObj *start = (LispObj *)a->active, *end = start;
3059        LispObj *limit = (LispObj *)a->high;
3060       
3061        for (current = start; end != limit; current = next) {
3062          next = ptr_from_lispobj(*current);
3063          end = ((next >= start) && (next < limit)) ? next : limit;
3064          wp_update_range(current+2, end, old, new);
3065        }
3066      break;
3067      }
3068      default:
3069        break;
3070    }
3071    a = a->succ;
3072    code = a->code;
3073  }
3074}
3075
3076static void
3077wp_update_tcr_tlb(TCR *tcr, LispObj old, LispObj new)
3078{
3079  natural n = tcr->tlb_limit;
3080  LispObj *start = tcr->tlb_pointer;
3081  LispObj *end = start + (n >> fixnumshift);
3082
3083  while (start < end) {
3084    wp_maybe_update(start, old, new);
3085    start++;
3086  }
3087}
3088
3089void
3090wp_update_references(TCR *tcr, LispObj old, LispObj new)
3091{
3092  TCR *other_tcr = tcr;
3093
3094  do {
3095    wp_update_tcr_xframes(other_tcr, old, new);
3096    wp_update_tcr_tlb(other_tcr, old, new);
3097    other_tcr = other_tcr->next;
3098  } while (other_tcr != tcr);
3099  unprotect_watched_areas();
3100  wp_update_all_areas(old, new);
3101  protect_watched_areas();
3102}
Note: See TracBrowser for help on using the repository browser.