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

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

In purify_range(), if we're walking the dynamic area and encounter
an ivector or function before encountering a reference to that ivector/
function and we're copying ivectors/functions to the readonly area,
do the copy at that point. (We otherwise miss some things that're
forward-referenced and wind up copying them to the static area instead.)

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