source: release/1.4/source/lisp-kernel/x86-gc.c @ 13075

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

Merge trunk changes r13066 through r13067.
(copyright notices)

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