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

Last change on this file since 15504 was 15504, checked in by gz, 7 years ago

Fix lock-free hash table handling of the partially-inserted state, and took out gc handling of the partially-deleted state. Bumped image version because kernel and runtime changes need to match. This fixes ticket #993, hopefully without breaking much of anything else.

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