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

Last change on this file since 13511 was 13511, checked in by gb, 10 years ago

Try to undo some of the damage done (mostly) by r13497.

image.c: handle relocation of weak vectors (hopefully) better.

lisp-debug.c: if we enter the kernel debugger with the batch flag

on, be more careful not to assume that we have exception context.
(We generally don't if 'Bug(NULL, "some message")' was used to
enter the debugger.)

ppc-gc.c, x86-gc.c: don't complain if the refbit for an intergenerational

reference from population.data of a weak list may have been cleared by
init_weakvll().

x86-gc.c: immutable_function_p() returns false on closures. Enter the

kernel debugger if purify_displaced_object() would try to copy a weak
vector out of dynamic space. (For now; need to take care to maintain
WEAKVLL if we do, and it's probably not something we'd want to do.)
Add purify_noderef(), which calls purify_locref() if ref points to
a tagged lisp pointer and does nothing otherwise.
Use purify_noderef() when recursively scanning in copy_reference(),
so we don't misinterpet immediate objects/headers as pointers to
dynamic space (as we've been doing since r13497.)
Make immutable_function_p() - which returns true if the function
can be copied to readonly memory - return false for closures, since
a closure's "constants" aren't as constant as a simple function's.

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