source: branches/acl2-egc/lisp-kernel/x86-gc.c @ 16371

Last change on this file since 16371 was 16371, checked in by gb, 5 years ago

still in progress

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