source: release/1.9/source/lisp-kernel/x86-gc.c @ 16083

Last change on this file since 16083 was 15785, checked in by gb, 6 years ago

Fix typo.

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