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

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

Lisp kernel support for watching/unwatching objects on x8632.

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