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

Last change on this file since 14619 was 14619, checked in by rme, 10 years ago

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

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