source: release/1.7/source/lisp-kernel/x86-gc.c @ 15267

Last change on this file since 15267 was 14723, checked in by gb, 8 years ago

In mark_memoized_area() on all platforms, don't do any special
processing of weak-on-value hash vectors. (This means that otherwise
unreferenced values in weak-on-value hash tables will only be free
on a full GC.) This seems to fix (at least the symptom of) ticket:817,
or at least allows my test case to run to completion.

The real problem is that sometimes those weak-on-value hash vectors
aren't on GCweakvll; if we don't mark the values in the weak vector
in mark_memoized_area(), nothing deletes unmarked values from the
hash table (or otherwise completes weak processing.) I was unable
to determine why the vectors were sometimes missing from the list;
not dropping them in init_weakvll() didn't seem to fix anything.

One approach to fixing the real problem is to say:

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