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

Last change on this file since 8475 was 8475, checked in by gb, 13 years ago

get impurify() working on x86-64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 60.7 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp_globals.h"
19#include "bits.h"
20#include "gc.h"
21#include "area.h"
22#include "Threads.h"
23#include <stddef.h>
24#include <stdlib.h>
25#include <string.h>
26#include <sys/time.h>
27
28
29/* Heap sanity checking. */
30
31void
32check_node(LispObj n)
33{
34  int tag = fulltag_of(n), header_tag;
35  area *a;
36  LispObj header;
37
38  if (n == (n & 0xff)) {
39    return;
40  }
41
42  switch (tag) {
43  case fulltag_even_fixnum:
44  case fulltag_odd_fixnum:
45  case fulltag_imm_0:
46  case fulltag_imm_1:
47    return;
48
49  case fulltag_nil:
50    if (n != lisp_nil) {
51      Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n);
52    }
53    return;
54
55
56  case fulltag_nodeheader_0: 
57  case fulltag_nodeheader_1: 
58  case fulltag_immheader_0: 
59  case fulltag_immheader_1: 
60  case fulltag_immheader_2: 
61    Bug(NULL, "Header not expected : 0x%lx", n);
62    return;
63
64  case fulltag_tra_0:
65  case fulltag_tra_1:
66    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
67    if (a == NULL) {
68      a = active_dynamic_area;
69      if ((n > (ptr_to_lispobj(a->active))) &&
70          (n < (ptr_to_lispobj(a->high)))) {
71        Bug(NULL, "TRA points to heap free space: 0x%lx", n);
72      }
73      return;
74    }
75    /* tra points into the heap.  Check displacement, then
76       check the function it (should) identify.
77    */
78    {
79      int disp = 0;
80      LispObj m = n;
81
82      if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
83          (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
84        disp = (*(int *) (n+3));
85        n = RECOVER_FN_FROM_RIP_LENGTH+m+disp;
86      }
87      if ((disp == 0) ||
88          (fulltag_of(n) != fulltag_function) ||
89          (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) {
90        Bug(NULL, "TRA at 0x%lx has bad displacement %d\n", n, disp);
91      }
92    }
93    /* Otherwise, fall through and check the header on the function
94       that the tra references */
95
96  case fulltag_misc:
97  case fulltag_cons:
98  case fulltag_symbol:
99  case fulltag_function:
100    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
101   
102    if (a == NULL) {
103      /* Can't do as much sanity checking as we'd like to
104         if object is a defunct stack-consed object.
105         If a dangling reference to the heap, that's
106         bad .. */
107      a = active_dynamic_area;
108      if ((n > (ptr_to_lispobj(a->active))) &&
109          (n < (ptr_to_lispobj(a->high)))) {
110        Bug(NULL, "Node points to heap free space: 0x%lx", n);
111      }
112      return;
113    }
114    break;
115  }
116  /* Node points to heap area, so check header/lack thereof. */
117  header = header_of(n);
118  header_tag = fulltag_of(header);
119  if (tag == fulltag_cons) {
120    if ((nodeheader_tag_p(header_tag)) ||
121        (immheader_tag_p(header_tag))) {
122      Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header);
123    }
124    return;
125  }
126
127  if ((!nodeheader_tag_p(header_tag)) &&
128      (!immheader_tag_p(header_tag))) {
129    Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header);
130  }
131  return;
132}
133
134void
135check_all_mark_bits(LispObj *nodepointer) 
136{
137}
138
139
140
141
142
143void
144check_range(LispObj *start, LispObj *end, Boolean header_allowed)
145{
146  LispObj node, *current = start, *prev;
147  int tag;
148  natural elements;
149
150  while (current < end) {
151    prev = current;
152    node = *current++;
153    tag = fulltag_of(node);
154    if (immheader_tag_p(tag)) {
155      if (! header_allowed) {
156        Bug(NULL, "Header not expected at 0x%lx\n", prev);
157      }
158      current = (LispObj *)skip_over_ivector((natural)prev, node);
159    } else if (nodeheader_tag_p(tag)) {
160      if (! header_allowed) {
161        Bug(NULL, "Header not expected at 0x%lx\n", prev);
162      }
163      elements = header_element_count(node) | 1;
164      if (header_subtag(node) == subtag_function) {
165        int skip = *(int *)current;
166        current += skip;
167        elements -= skip;
168      }
169      while (elements--) {
170        check_node(*current++);
171      }
172    } else {
173      check_node(node);
174      check_node(*current++);
175    }
176  }
177
178  if (current != end) {
179    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
180        start, end, prev, current);
181  }
182}
183
184void
185check_all_areas()
186{
187  area *a = active_dynamic_area;
188  area_code code = a->code;
189
190  while (code != AREA_VOID) {
191    switch (code) {
192    case AREA_DYNAMIC:
193    case AREA_STATIC:
194    case AREA_MANAGED_STATIC:
195      check_range((LispObj *)a->low, (LispObj *)a->active, true);
196      break;
197
198    case AREA_VSTACK:
199      {
200        LispObj* low = (LispObj *)a->active;
201        LispObj* high = (LispObj *)a->high;
202       
203        if (((natural)low) & node_size) {
204          check_node(*low++);
205        }
206        check_range(low, high, false);
207      }
208      break;
209
210    case AREA_TSTACK:
211      {
212        LispObj *current, *next,
213                *start = (LispObj *) a->active,
214                *end = start,
215                *limit = (LispObj *) a->high;
216                 
217        for (current = start;
218             end != limit;
219             current = next) {
220          next = ptr_from_lispobj(*current);
221          end = ((next >= start) && (next < limit)) ? next : limit;
222          check_range(current+2, end, true);
223        }
224      }
225      break;
226    }
227    a = a->succ;
228    code = (a->code);
229  }
230}
231
232
233
234
235
236
237
238/* Sooner or later, this probably wants to be in assembler */
239/* Return false if n is definitely not an ephemeral node, true if
240   it might be */
241void
242mark_root(LispObj n)
243{
244  int tag_n = fulltag_of(n);
245  natural dnode, bits, *bitsp, mask;
246
247  if (!is_node_fulltag(tag_n)) {
248    return;
249  }
250
251  if (tag_of(n) == tag_tra) {
252    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
253        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
254      int sdisp = (*(int *) (n+3));
255      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
256      tag_n = fulltag_function;
257    }
258    else {
259      return;
260    }
261  }
262
263
264  dnode = gc_area_dnode(n);
265  if (dnode >= GCndnodes_in_area) {
266    return;
267  }
268  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
269  if (bits & mask) {
270    return;
271  }
272  *bitsp = (bits | mask);
273
274  if (tag_n == fulltag_cons) {
275    cons *c = (cons *) ptr_from_lispobj(untag(n));
276
277    rmark(c->car);
278    rmark(c->cdr);
279    return;
280  }
281  {
282    LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
283    natural
284      header = *((natural *) base),
285      subtag = header_subtag(header),
286      element_count = header_element_count(header),
287      total_size_in_bytes,      /* including 4/8-byte header */
288      suffix_dnodes;
289    natural prefix_nodes = 0;
290
291    tag_n = fulltag_of(header);
292
293
294    if ((nodeheader_tag_p(tag_n)) ||
295        (tag_n == ivector_class_64_bit)) {
296      total_size_in_bytes = 8 + (element_count<<3);
297    } else if (tag_n == ivector_class_32_bit) {
298      total_size_in_bytes = 8 + (element_count<<2);
299    } else {
300      /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */
301      if (subtag == subtag_bit_vector) {
302        total_size_in_bytes = 8 + ((element_count+7)>>3);
303      } else if (subtag >= min_8_bit_ivector_subtag) {
304        total_size_in_bytes = 8 + element_count;
305      } else {
306        total_size_in_bytes = 8 + (element_count<<1);
307      }
308    }
309
310    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1;
311
312    if (suffix_dnodes) {
313      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
314    }
315
316    if (nodeheader_tag_p(tag_n)) {
317      if (subtag == subtag_hash_vector) {
318        /* Don't invalidate the cache here.  It should get
319           invalidated on the lisp side, if/when we know
320           that rehashing is necessary. */
321        LispObj flags = ((hash_table_vector_header *) base)->flags;
322
323        if (flags & nhash_weak_mask) {
324          ((hash_table_vector_header *) base)->cache_key = undefined;
325          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
326          mark_weak_htabv(n);
327          return;
328        }
329      }
330
331      if (subtag == subtag_pool) {
332        deref(ptr_to_lispobj(base), 1) = lisp_nil;
333      }
334     
335      if (subtag == subtag_weak) {
336        natural weak_type = (natural) base[2];
337        if (weak_type >> population_termination_bit) {
338          element_count -= 2;
339        } else {
340          element_count -= 1;
341        }
342      }
343
344      if (subtag == subtag_function) {
345        prefix_nodes = (natural) ((int) deref(base,1));
346        if (prefix_nodes > element_count) {
347          Bug(NULL, "Function 0x%lx trashed",n);
348        }
349      }
350      base += (1+element_count);
351
352      element_count -= prefix_nodes;
353
354      while(element_count--) {
355        rmark(*--base);
356      }
357      if (subtag == subtag_weak) {
358        deref(ptr_to_lispobj(base),1) = GCweakvll;
359        GCweakvll = n;
360      }
361    }
362  }
363}
364
365
366/*
367  This marks the node if it needs to; it returns true if the node
368  is either a hash table vector header or a cons/misc-tagged pointer
369  to ephemeral space.
370  Note that it  might be a pointer to ephemeral space even if it's
371  not pointing to the current generation.
372*/
373
374Boolean
375mark_ephemeral_root(LispObj n)
376{
377  int tag_n = fulltag_of(n);
378  natural eph_dnode;
379
380  if (nodeheader_tag_p(tag_n)) {
381    return (header_subtag(n) == subtag_hash_vector);
382  }
383 
384  if (is_node_fulltag (tag_n)) {
385    eph_dnode = area_dnode(n, GCephemeral_low);
386    if (eph_dnode < GCn_ephemeral_dnodes) {
387      mark_root(n);             /* May or may not mark it */
388      return true;              /* but return true 'cause it's an ephemeral node */
389    }
390  }
391  return false;                 /* Not a heap pointer or not ephemeral */
392}
393 
394
395
396#ifdef X8664
397#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */
398#define RMARK_PREV_CAR fulltag_nil /* fulltag_nil + node_size. Coincidence ? I think not. */
399#else
400#endif
401
402
403
404/*
405  This wants to be in assembler even more than "mark_root" does.
406  For now, it does link-inversion: hard as that is to express in C,
407  reliable stack-overflow detection may be even harder ...
408*/
409void
410rmark(LispObj n)
411{
412  int tag_n = fulltag_of(n);
413  bitvector markbits = GCmarkbits;
414  natural dnode, bits, *bitsp, mask, original_n = n;
415
416  if (!is_node_fulltag(tag_n)) {
417    return;
418  }
419
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    } else {
427      return;
428    }
429  }
430
431  dnode = gc_area_dnode(n);
432  if (dnode >= GCndnodes_in_area) {
433    return;
434  }
435  set_bits_vars(markbits,dnode,bitsp,bits,mask);
436  if (bits & mask) {
437    return;
438  }
439  *bitsp = (bits | mask);
440
441  if (current_stack_pointer() > GCstack_limit) {
442    if (tag_n == fulltag_cons) {
443      rmark(deref(n,1));
444      rmark(deref(n,0));
445    } else {
446      LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
447      natural
448        header = *((natural *) base),
449        subtag = header_subtag(header),
450        element_count = header_element_count(header),
451        total_size_in_bytes,
452        suffix_dnodes,
453        nmark;
454
455      tag_n = fulltag_of(header);
456
457      if ((nodeheader_tag_p(tag_n)) ||
458          (tag_n == ivector_class_64_bit)) {
459        total_size_in_bytes = 8 + (element_count<<3);
460      } else if (tag_n == ivector_class_32_bit) {
461        total_size_in_bytes = 8 + (element_count<<2);
462      } else {
463        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
464        if (subtag == subtag_bit_vector) {
465          total_size_in_bytes = 8 + ((element_count+7)>>3);
466        } else if (subtag >= min_8_bit_ivector_subtag) {
467          total_size_in_bytes = 8 + element_count;
468        } else {
469          total_size_in_bytes = 8 + (element_count<<1);
470        }
471      }
472      suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
473
474      if (suffix_dnodes) {
475        set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
476      }
477
478      if (!nodeheader_tag_p(tag_n)) return;
479
480      if (subtag == subtag_hash_vector) {
481        /* Splice onto weakvll, then return */
482        /* In general, there's no reason to invalidate the cached
483           key/value pair here.  However, if the hash table's weak,
484           we don't want to retain an otherwise unreferenced key
485           or value simply because they're referenced from the
486           cache.  Clear the cached entries iff the hash table's
487           weak in some sense.
488        */
489        LispObj flags = ((hash_table_vector_header *) base)->flags;
490
491        if (flags & nhash_weak_mask) {
492          ((hash_table_vector_header *) base)->cache_key = undefined;
493          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
494          mark_weak_htabv(n);
495          return;
496        }
497      }
498
499      if (subtag == subtag_pool) {
500        deref(n, 1) = lisp_nil;
501      }
502
503      if (subtag == subtag_weak) {
504        natural weak_type = (natural) base[2];
505        if (weak_type >> population_termination_bit)
506          element_count -= 2;
507        else
508          element_count -= 1;
509      }
510
511      nmark = element_count;
512
513      if (subtag == subtag_function) {
514        if ((int)base[1] >= nmark) {
515          Bug(NULL,"Bad function at 0x%lx",n);
516        }
517        nmark -= (int)base[1];
518      }
519
520      while (nmark--) {
521        rmark(deref(n,element_count));
522        element_count--;
523      }
524
525      if (subtag == subtag_weak) {
526        deref(n, 1) = GCweakvll;
527        GCweakvll = n;
528      }
529
530    }
531  } else {
532
533    /* This is all a bit more complicated than the PPC version:
534
535       - a symbol-vector can be referenced via either a FULLTAG-MISC
536       pointer or a FULLTAG-SYMBOL pointer.  When we've finished
537       marking the symbol-vector's elements, we need to know which tag
538       the object that pointed to the symbol-vector had originally.
539
540       - a function-vector can be referenced via either a FULLTAG-MISC
541       pointer or a FULLTAG-FUNCTION pointer.  That introduces pretty
542       much the same set of issues, but ...
543
544       - a function-vector can also be referenced via a TRA; the
545       offset from the TRA to the function header is arbitrary (though
546       we can probably put an upper bound on it, and it's certainly
547       not going to be more than 32 bits.)
548
549       - function-vectors contain a mixture of code and constants,
550       with a "boundary" word (that doesn't look like a valid
551       constant) in between them.  There are 56 unused bits in the
552       boundary word; the low 8 bits must be = to the constant
553       'function_boundary_marker'.  We can store the byte displacement
554       from the address of the object which references the function
555       (tagged fulltag_misc, fulltag_function, or tra) to the address
556       of the boundary marker when the function vector is first marked
557       and recover that offset when we've finished marking the
558       function vector.  (Note that the offset is signed; it's
559       probably simplest to keep it in the high 32 bits of the
560       boundary word.)
561
562 So:
563
564       - while marking a CONS, the 'this' pointer as a 3-bit tag of
565       tag_list; the 4-bit fulltag indicates which cell is being
566       marked.
567
568       - while marking a gvector (other than a symbol-vector or
569       function-vector), the 'this' pointer is tagged tag_misc.
570       (Obviously, it alternates between fulltag_misc and
571       fulltag_nodeheader_0, arbitrarily.)  When we encounter the
572       gvector header when the 'this' pointer has been tagged as
573       fulltag_misc, we can restore 'this' to the header's address +
574       fulltag_misc and enter the 'climb' state.  (Note that this
575       value happens to be exactly what's in 'this' when the header's
576       encountered.)
577
578       - if we encounter a symbol-vector via the FULLTAG-MISC pointer
579       to the symbol (not very likely, but legal and possible), it's
580       treated exactly like the gvector case above.
581
582       - in the more likely case where a symbol-vector is referenced
583       via a FULLTAG-SYMBOL, we do the same loop as in the general
584       gvector case, backing up through the vector with 'this' tagged
585       as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter
586       the symbol header, 'this' gets fulltag_symbol added to the
587       dnode-aligned address of the header, and we climb.
588
589       - if anything (fulltag_misc, fulltag_function, tra) references
590       an unmarked function function vector, we store the byte offfset
591       from the tagged reference to the address of the boundary word
592       in the high 32 bits of the boundary word, then we back up
593       through the function-vector's constants, with 'this' tagged
594       tag_function/ fulltag_immheader_0, until the (specially-tagged)
595       boundary word is encountered.  The displacement stored in the boundary
596       word is added to the aligned address of the  boundary word (restoring
597       the original 'this' pointer, and we climb.
598
599       Not that bad.
600    */
601       
602    LispObj prev = undefined, this = n, next, *base;
603    natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary;
604
605    if (tag_n == fulltag_cons) goto MarkCons;
606    goto MarkVector;
607
608  ClimbCdr:
609    prev = deref(this,0);
610    deref(this,0) = next;
611
612  Climb:
613    next = this;
614    this = prev;
615    tag_n = fulltag_of(prev);
616    switch(tag_n) {
617    case tag_misc:
618    case fulltag_misc:
619    case tag_symbol:
620    case fulltag_symbol:
621    case tag_function:
622    case fulltag_function:
623      goto ClimbVector;
624
625    case RMARK_PREV_ROOT:
626      return;
627
628    case fulltag_cons:
629      goto ClimbCdr;
630
631    case RMARK_PREV_CAR:
632      goto ClimbCar;
633
634      /* default: abort() */
635    }
636
637  DescendCons:
638    prev = this;
639    this = next;
640
641  MarkCons:
642    next = deref(this,1);
643    this += node_size;
644    tag_n = fulltag_of(next);
645    if (!is_node_fulltag(tag_n)) goto MarkCdr;
646    dnode = gc_area_dnode(next);
647    if (dnode >= GCndnodes_in_area) goto MarkCdr;
648    set_bits_vars(markbits,dnode,bitsp,bits,mask);
649    if (bits & mask) goto MarkCdr;
650    *bitsp = (bits | mask);
651    deref(this,1) = prev;
652    if (tag_n == fulltag_cons) goto DescendCons;
653    goto DescendVector;
654
655  ClimbCar:
656    prev = deref(this,1);
657    deref(this,1) = next;
658
659  MarkCdr:
660    next = deref(this, 0);
661    this -= node_size;
662    tag_n = fulltag_of(next);
663    if (!is_node_fulltag(tag_n)) goto Climb;
664    dnode = gc_area_dnode(next);
665    if (dnode >= GCndnodes_in_area) goto Climb;
666    set_bits_vars(markbits,dnode,bitsp,bits,mask);
667    if (bits & mask) goto Climb;
668    *bitsp = (bits | mask);
669    deref(this, 0) = prev;
670    if (tag_n == fulltag_cons) goto DescendCons;
671    /* goto DescendVector; */
672
673  DescendVector:
674    prev = this;
675    this = next;
676
677  MarkVector:
678    if ((tag_n == fulltag_tra_0) ||
679        (tag_n == fulltag_tra_1)) {
680      int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH;
681
682      base = (LispObj *) (untag(n-disp));
683      header = *((natural *) base);
684      subtag = header_subtag(header);
685      boundary = base + (int)(base[1]);
686      (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
687      this = (LispObj)(base)+fulltag_function;
688      /* Need to set the initial markbit here */
689      dnode = gc_area_dnode(this);
690      set_bit(markbits,dnode);
691    } else {
692      base = (LispObj *) ptr_from_lispobj(untag(this));
693      header = *((natural *) base);
694      subtag = header_subtag(header);
695      if (subtag == subtag_function) {
696        boundary = base + (int)(base[1]);
697        (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
698      }
699    }
700    element_count = header_element_count(header);
701    tag_n = fulltag_of(header);
702
703    if ((nodeheader_tag_p(tag_n)) ||
704        (tag_n == ivector_class_64_bit)) {
705      total_size_in_bytes = 8 + (element_count<<3);
706    } else if (tag_n == ivector_class_32_bit) {
707      total_size_in_bytes = 8 + (element_count<<2);
708    } else {
709      /* ivector_class_other_bit contains 16-bit arrays & bitvector */
710      if (subtag == subtag_bit_vector) {
711        total_size_in_bytes = 8 + ((element_count+7)>>3);
712      } else if (subtag >= min_8_bit_ivector_subtag) {
713        total_size_in_bytes = 8 + element_count;
714      } else {
715        total_size_in_bytes = 8 + (element_count<<1);
716      }
717    }
718    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
719   
720    if (suffix_dnodes) {
721      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
722    }
723   
724    if (!nodeheader_tag_p(tag_n)) goto Climb;
725   
726    if (subtag == subtag_hash_vector) {
727      /* Splice onto weakvll, then climb */
728      LispObj flags = ((hash_table_vector_header *) base)->flags;
729     
730      if (flags & nhash_weak_mask) {
731        ((hash_table_vector_header *) base)->cache_key = undefined;
732        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
733        dws_mark_weak_htabv(this);
734        element_count = hash_table_vector_header_count;
735      }
736    }
737
738    if (subtag == subtag_pool) {
739      deref(this, 1) = lisp_nil;
740    }
741
742    if (subtag == subtag_weak) {
743      natural weak_type = (natural) base[2];
744      if (weak_type >> population_termination_bit)
745        element_count -= 2;
746      else
747        element_count -= 1;
748    }
749
750    this = (LispObj)(base) + (tag_of(this))  + ((element_count+1) << node_shift);
751    goto MarkVectorLoop;
752
753  ClimbVector:
754    prev = indirect_node(this);
755    indirect_node(this) = next;
756
757  MarkVectorLoop:
758    this -= node_size;
759    next = indirect_node(this);
760    if ((tag_of(this) == tag_function) &&
761        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
762    tag_n = fulltag_of(next);
763    if (nodeheader_tag_p(tag_n)) goto MarkVectorDone;
764    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
765    dnode = gc_area_dnode(next);
766    if (dnode >= GCndnodes_in_area) goto MarkVectorLoop;
767    set_bits_vars(markbits,dnode,bitsp,bits,mask);
768    if (bits & mask) goto MarkVectorLoop;
769    *bitsp = (bits | mask);
770    indirect_node(this) = prev;
771    if (tag_n == fulltag_cons) goto DescendCons;
772    goto DescendVector;
773
774  MarkVectorDone:
775    /* "next" is vector header; "this" tagged tag_misc or tag_symbol.
776       If  header subtag = subtag_weak_header, put it on weakvll */
777    this += node_size;          /* make it fulltag_misc/fulltag_symbol */
778
779    if (header_subtag(next) == subtag_weak) {
780      deref(this, 1) = GCweakvll;
781      GCweakvll = this;
782    }
783    goto Climb;
784
785  MarkFunctionDone:
786    boundary = (LispObj *)(node_aligned(this));
787    this = ((LispObj)boundary) + (((int *)boundary)[1]);
788    (((int *)boundary)[1]) = 0;
789    goto Climb;
790  }
791}
792
793LispObj *
794skip_over_ivector(natural start, LispObj header)
795{
796  natural
797    element_count = header_element_count(header),
798    subtag = header_subtag(header),
799    nbytes;
800
801
802
803  switch (fulltag_of(header)) {
804  case ivector_class_64_bit:
805    nbytes = element_count << 3;
806    break;
807  case ivector_class_32_bit:
808    nbytes = element_count << 2;
809    break;
810  case ivector_class_other_bit:
811  default:
812    if (subtag == subtag_bit_vector) {
813      nbytes = (element_count+7)>>3;
814    } else if (subtag >= min_8_bit_ivector_subtag) {
815      nbytes = element_count;
816    } else {
817      nbytes = element_count << 1;
818    }
819  }
820  return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15)));
821
822}
823
824
825void
826check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
827{
828  LispObj x1, *base = start, *prev = start;
829  int tag;
830  natural ref_dnode, node_dnode;
831  Boolean intergen_ref;
832
833  while (start < end) {
834    x1 = *start;
835    prev = start;
836    tag = fulltag_of(x1);
837    if (immheader_tag_p(tag)) {
838      start = skip_over_ivector(ptr_to_lispobj(start), x1);
839    } else {
840      if (header_subtag(x1) == subtag_function) {
841        int skip = (int) deref(start,1);
842        start += ((1+skip)&~1);
843        x1 = *start;
844        tag = fulltag_of(x1);
845      }
846      intergen_ref = false;
847      if (is_node_fulltag(tag)) {       
848        node_dnode = gc_area_dnode(x1);
849        if (node_dnode < GCndnodes_in_area) {
850          intergen_ref = true;
851        }
852      }
853      if (intergen_ref == false) {       
854        x1 = start[1];
855        tag = fulltag_of(x1);
856      if (is_node_fulltag(tag)) {       
857          node_dnode = gc_area_dnode(x1);
858          if (node_dnode < GCndnodes_in_area) {
859            intergen_ref = true;
860          }
861        }
862      }
863      if (intergen_ref) {
864        ref_dnode = area_dnode(start, base);
865        if (!ref_bit(refbits, ref_dnode)) {
866          Bug(NULL, "Missing memoization in doublenode at 0x%08X", start);
867          set_bit(refbits, ref_dnode);
868        }
869      }
870      start += 2;
871    }
872  }
873  if (start > end) {
874    Bug(NULL, "Overran end of range!");
875  }
876}
877
878
879
880void
881mark_memoized_area(area *a, natural num_memo_dnodes)
882{
883  bitvector refbits = a->refbits;
884  LispObj *p = (LispObj *) a->low, x1, x2;
885  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
886  Boolean keep_x1, keep_x2;
887
888  if (GCDebug) {
889    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
890  }
891
892  /* The distinction between "inbits" and "outbits" is supposed to help us
893     detect cases where "uninteresting" setfs have been memoized.  Storing
894     NIL, fixnums, immediates (characters, etc.) or node pointers to static
895     or readonly areas is definitely uninteresting, but other cases are
896     more complicated (and some of these cases are hard to detect.)
897
898     Some headers are "interesting", to the forwarder if not to us.
899
900     We -don't- give anything any weak treatment here.  Weak things have
901     to be seen by a full gc, for some value of 'full'.
902     */
903
904  /*
905    We need to ensure that there are no bits set at or beyond
906    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
907    tenures/untenures things.)  We find bits by grabbing a fullword at
908    a time and doing a cntlzw instruction; and don't want to have to
909    check for (< memo_dnode num_memo_dnodes) in the loop.
910    */
911
912  {
913    natural
914      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
915      index_of_last_word = (num_memo_dnodes >> bitmap_shift);
916
917    if (bits_in_last_word != 0) {
918      natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L);
919      refbits[index_of_last_word] &= mask;
920    }
921  }
922       
923  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
924  inbits = outbits = bits;
925  while (memo_dnode < num_memo_dnodes) {
926    if (bits == 0) {
927      int remain = nbits_in_word - bitidx;
928      memo_dnode += remain;
929      p += (remain+remain);
930      if (outbits != inbits) {
931        *bitsp = outbits;
932      }
933      bits = *++bitsp;
934      inbits = outbits = bits;
935      bitidx = 0;
936    } else {
937      nextbit = count_leading_zeros(bits);
938      if ((diff = (nextbit - bitidx)) != 0) {
939        memo_dnode += diff;
940        bitidx = nextbit;
941        p += (diff+diff);
942      }
943      x1 = *p++;
944      x2 = *p++;
945      bits &= ~(BIT0_MASK >> bitidx);
946      keep_x1 = mark_ephemeral_root(x1);
947      keep_x2 = mark_ephemeral_root(x2);
948      if ((keep_x1 == false) && 
949          (keep_x2 == false)) {
950        outbits &= ~(BIT0_MASK >> bitidx);
951      }
952      memo_dnode++;
953      bitidx++;
954    }
955  }
956  if (GCDebug) {
957    p = (LispObj *) a->low;
958    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
959  }
960}
961
962void
963mark_headerless_area_range(LispObj *start, LispObj *end)
964{
965  while (start < end) {
966    mark_root(*start++);
967  }
968}
969
970void
971mark_simple_area_range(LispObj *start, LispObj *end)
972{
973  LispObj x1, *base;
974  int tag;
975
976  while (start < end) {
977    x1 = *start;
978    tag = fulltag_of(x1);
979    if (immheader_tag_p(tag)) {
980      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
981    } else if (!nodeheader_tag_p(tag)) {
982      ++start;
983      mark_root(x1);
984      mark_root(*start++);
985    } else {
986      int subtag = header_subtag(x1);
987      natural element_count = header_element_count(x1);
988      natural size = (element_count+1 + 1) & ~1;
989
990      if (subtag == subtag_hash_vector) {
991        LispObj flags = ((hash_table_vector_header *) start)->flags;
992
993        if (flags & nhash_weak_mask) {
994          ((hash_table_vector_header *) start)->cache_key = undefined;
995          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
996          mark_weak_htabv((LispObj)start);
997          element_count = 0;
998        }
999      } 
1000      if (subtag == subtag_pool) {
1001        start[1] = lisp_nil;
1002      }
1003
1004      if (subtag == subtag_weak) {
1005        natural weak_type = (natural) start[2];
1006        if (weak_type >> population_termination_bit)
1007          element_count -= 2;
1008        else
1009          element_count -= 1; 
1010        start[1] = GCweakvll;
1011        GCweakvll = (LispObj) (((natural) start) + fulltag_misc);   
1012      }
1013
1014      base = start + element_count + 1;
1015      if (subtag == subtag_function) {
1016        element_count -= (int)start[1];
1017      }
1018      while(element_count--) {
1019        mark_root(*--base);
1020      }
1021      start += size;
1022    }
1023  }
1024}
1025
1026
1027/* Mark a tstack area */
1028void
1029mark_tstack_area(area *a)
1030{
1031  LispObj
1032    *current,
1033    *next,
1034    *start = (LispObj *) (a->active),
1035    *end = start,
1036    *limit = (LispObj *) (a->high);
1037
1038  for (current = start;
1039       end != limit;
1040       current = next) {
1041    next = (LispObj *) ptr_from_lispobj(*current);
1042    end = ((next >= start) && (next < limit)) ? next : limit;
1043    mark_simple_area_range(current+2, end);
1044  }
1045}
1046
1047/*
1048  It's really important that headers never wind up in tagged registers.
1049  Those registers would (possibly) get pushed on the vstack and confuse
1050  the hell out of this routine.
1051
1052  vstacks are just treated as a "simple area range", possibly with
1053  an extra word at the top (where the area's active pointer points.)
1054  */
1055
1056void
1057mark_vstack_area(area *a)
1058{
1059  LispObj
1060    *start = (LispObj *) a->active,
1061    *end = (LispObj *) a->high;
1062
1063#if 0
1064  fprintf(stderr, "mark VSP range: 0x%lx:0x%lx\n", start, end);
1065#endif
1066  mark_headerless_area_range(start, end);
1067}
1068
1069/* No lisp objects on cstack on x86, at least x86-64 */
1070void
1071mark_cstack_area(area *a)
1072{
1073}
1074
1075
1076/* Mark the lisp objects in an exception frame */
1077void
1078mark_xp(ExceptionInformation *xp)
1079{
1080  natural *regs = (natural *) xpGPRvector(xp), dnode;
1081  LispObj rip;
1082   
1083 
1084
1085  mark_root(regs[Iarg_z]);
1086  mark_root(regs[Iarg_y]);
1087  mark_root(regs[Iarg_x]);
1088  mark_root(regs[Isave3]);
1089  mark_root(regs[Isave2]);
1090  mark_root(regs[Isave1]);
1091  mark_root(regs[Isave0]);
1092  mark_root(regs[Ifn]);
1093  mark_root(regs[Itemp0]);
1094  mark_root(regs[Itemp1]);
1095  mark_root(regs[Itemp2]);
1096  /* If the RIP isn't pointing into a marked function,
1097     we can -maybe- recover from that if it's tagged as
1098     a TRA. */
1099  rip = regs[Iip];
1100  dnode = gc_area_dnode(rip);
1101  if ((dnode < GCndnodes_in_area) &&
1102      (! ref_bit(GCmarkbits,dnode))) {
1103    if (tag_of(rip) == tag_tra) {
1104      mark_root(rip);
1105    } else if ((fulltag_of(rip) == fulltag_function) &&
1106               (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) &&
1107               (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) &&
1108               ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) {
1109      mark_root(rip);
1110    } else {
1111      Bug(NULL, "Can't find function for rip 0x%16lx",rip);
1112    }
1113  }
1114}
1115
1116
1117     
1118
1119
1120
1121
1122
1123/* A "pagelet" contains 32 doublewords.  The relocation table contains
1124   a word for each pagelet which defines the lowest address to which
1125   dnodes on that pagelet will be relocated.
1126
1127   The relocation address of a given pagelet is the sum of the relocation
1128   address for the preceding pagelet and the number of bytes occupied by
1129   marked objects on the preceding pagelet.
1130*/
1131
1132LispObj
1133calculate_relocation()
1134{
1135  LispObj *relocptr = GCrelocptr;
1136  LispObj current = GCareadynamiclow;
1137  bitvector
1138    markbits = GCdynamic_markbits;
1139  qnode *q = (qnode *) markbits;
1140  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1141  natural thesebits;
1142  LispObj first = 0;
1143
1144  if (npagelets) {
1145    do {
1146      *relocptr++ = current;
1147      thesebits = *markbits++;
1148      if (thesebits == ALL_ONES) {
1149        current += nbits_in_word*dnode_size;
1150        q += 4; /* sic */
1151      } else {
1152        if (!first) {
1153          first = current;
1154          while (thesebits & BIT0_MASK) {
1155            first += dnode_size;
1156            thesebits += thesebits;
1157          }
1158        }
1159        /* We're counting bits in qnodes in the wrong order here, but
1160           that's OK.  I think ... */
1161        current += one_bits(*q++);
1162        current += one_bits(*q++);
1163        current += one_bits(*q++);
1164        current += one_bits(*q++);
1165      }
1166    } while(--npagelets);
1167  }
1168  *relocptr++ = current;
1169  return first ? first : current;
1170}
1171
1172
1173#if 0
1174LispObj
1175dnode_forwarding_address(natural dnode, int tag_n)
1176{
1177  natural pagelet, nbits;
1178  unsigned int near_bits;
1179  LispObj new;
1180
1181  if (GCDebug) {
1182    if (! ref_bit(GCdynamic_markbits, dnode)) {
1183      Bug(NULL, "unmarked object being forwarded!\n");
1184    }
1185  }
1186
1187  pagelet = dnode >> bitmap_shift;
1188  nbits = dnode & bitmap_shift_count_mask;
1189  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
1190
1191  if (nbits < 32) {
1192    new = GCrelocptr[pagelet] + tag_n;;
1193    /* Increment "new" by the count of 1 bits which precede the dnode */
1194    if (near_bits == 0xffffffff) {
1195      return (new + (nbits << 4));
1196    } else {
1197      near_bits &= (0xffffffff00000000 >> nbits);
1198      if (nbits > 15) {
1199        new += one_bits(near_bits & 0xffff);
1200      }
1201      return (new + (one_bits(near_bits >> 16)));
1202    }
1203  } else {
1204    new = GCrelocptr[pagelet+1] + tag_n;
1205    nbits = 64-nbits;
1206
1207    if (near_bits == 0xffffffff) {
1208      return (new - (nbits << 4));
1209    } else {
1210      near_bits &= (1<<nbits)-1;
1211      if (nbits > 15) {
1212        new -= one_bits(near_bits >> 16);
1213      }
1214      return (new -  one_bits(near_bits & 0xffff));
1215    }
1216  }
1217}
1218#else
1219
1220/* Quicker, dirtier */
1221LispObj
1222dnode_forwarding_address(natural dnode, int tag_n)
1223{
1224  natural pagelet, nbits, marked;
1225  LispObj new;
1226
1227  if (GCDebug) {
1228    if (! ref_bit(GCdynamic_markbits, dnode)) {
1229      Bug(NULL, "unmarked object being forwarded!\n");
1230    }
1231  }
1232
1233  pagelet = dnode >> bitmap_shift;
1234  nbits = dnode & bitmap_shift_count_mask;
1235  new = GCrelocptr[pagelet] + tag_n;;
1236  if (nbits) {
1237    marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits);
1238    while (marked) {
1239      new += one_bits((qnode)marked);
1240      marked >>=16;
1241    }
1242  }
1243  return new;
1244}
1245#endif
1246
1247LispObj
1248locative_forwarding_address(LispObj obj)
1249{
1250  int tag_n = fulltag_of(obj);
1251  natural dnode = gc_dynamic_area_dnode(obj);
1252
1253
1254  if ((dnode >= GCndynamic_dnodes_in_area) ||
1255      (obj < GCfirstunmarked)) {
1256    return obj;
1257  }
1258
1259  return dnode_forwarding_address(dnode, tag_n);
1260}
1261
1262
1263void
1264forward_headerless_range(LispObj *range_start, LispObj *range_end)
1265{
1266  LispObj *p = range_start;
1267
1268  while (p < range_end) {
1269    update_noderef(p);
1270    p++;
1271  }
1272}
1273
1274void
1275forward_range(LispObj *range_start, LispObj *range_end)
1276{
1277  LispObj *p = range_start, node, new;
1278  int tag_n;
1279  natural nwords;
1280  hash_table_vector_header *hashp;
1281
1282  while (p < range_end) {
1283    node = *p;
1284    tag_n = fulltag_of(node);
1285    if (immheader_tag_p(tag_n)) {
1286      p = (LispObj *) skip_over_ivector((natural) p, node);
1287    } else if (nodeheader_tag_p(tag_n)) {
1288      nwords = header_element_count(node);
1289      nwords += (1 - (nwords&1));
1290      if ((header_subtag(node) == subtag_hash_vector) &&
1291          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1292        natural skip = hash_table_vector_header_count-1;
1293        hashp = (hash_table_vector_header *) p;
1294        p++;
1295        nwords -= skip;
1296        while(skip--) {
1297          update_noderef(p);
1298          p++;
1299        }
1300        /* "nwords" is odd at this point: there are (floor nwords 2)
1301           key/value pairs to look at, and then an extra word for
1302           alignment.  Process them two at a time, then bump "p"
1303           past the alignment word. */
1304        nwords >>= 1;
1305        while(nwords--) {
1306          if (update_noderef(p) && hashp) {
1307            hashp->flags |= nhash_key_moved_mask;
1308            hashp = NULL;
1309          }
1310          p++;
1311          update_noderef(p);
1312          p++;
1313        }
1314        *p++ = 0;
1315      } else {
1316        if (header_subtag(node) == subtag_function) {
1317          int skip = (int)(p[1]);
1318          p += skip;
1319          nwords -= skip;
1320        }
1321        p++;
1322        while(nwords--) {
1323          update_noderef(p);
1324          p++;
1325        }
1326      }
1327    } else {
1328      new = node_forwarding_address(node);
1329      if (new != node) {
1330        *p = new;
1331      }
1332      p++;
1333      update_noderef(p);
1334      p++;
1335    }
1336  }
1337}
1338
1339
1340
1341
1342
1343
1344/* Forward a tstack area */
1345void
1346forward_tstack_area(area *a)
1347{
1348  LispObj
1349    *current,
1350    *next,
1351    *start = (LispObj *) a->active,
1352    *end = start,
1353    *limit = (LispObj *) (a->high);
1354
1355  for (current = start;
1356       end != limit;
1357       current = next) {
1358    next = ptr_from_lispobj(*current);
1359    end = ((next >= start) && (next < limit)) ? next : limit;
1360    forward_range(current+2, end);
1361  }
1362}
1363
1364/* Forward a vstack area */
1365void
1366forward_vstack_area(area *a)
1367{
1368  LispObj
1369    *p = (LispObj *) a->active,
1370    *q = (LispObj *) a->high;
1371
1372  forward_headerless_range(p, q);
1373}
1374
1375/* Nothing of interest on x86 cstack */
1376void
1377forward_cstack_area(area *a)
1378{
1379}
1380
1381
1382void
1383forward_xp(ExceptionInformation *xp)
1384{
1385  natural *regs = (natural *) xpGPRvector(xp);
1386
1387  update_noderef(&(regs[Iarg_z]));
1388  update_noderef(&(regs[Iarg_y]));
1389  update_noderef(&(regs[Iarg_x]));
1390  update_noderef(&(regs[Isave3]));
1391  update_noderef(&(regs[Isave2]));
1392  update_noderef(&(regs[Isave1]));
1393  update_noderef(&(regs[Isave0]));
1394  update_noderef(&(regs[Ifn]));
1395  update_noderef(&(regs[Itemp0]));
1396  update_noderef(&(regs[Itemp1]));
1397  update_noderef(&(regs[Itemp2]));
1398  update_locref(&(regs[Iip]));
1399}
1400
1401
1402void
1403forward_tcr_xframes(TCR *tcr)
1404{
1405  xframe_list *xframes;
1406  ExceptionInformation *xp;
1407
1408  xp = tcr->gc_context;
1409  if (xp) {
1410    forward_xp(xp);
1411  }
1412  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1413    forward_xp(xframes->curr);
1414  }
1415}
1416
1417
1418
1419
1420/*
1421  Compact the dynamic heap (from GCfirstunmarked through its end.)
1422  Return the doublenode address of the new freeptr.
1423  */
1424
1425LispObj
1426compact_dynamic_heap()
1427{
1428  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
1429  natural
1430    elements, 
1431    dnode = gc_area_dnode(GCfirstunmarked), 
1432    node_dnodes = 0, 
1433    imm_dnodes = 0, 
1434    bitidx, 
1435    *bitsp, 
1436    bits, 
1437    nextbit, 
1438    diff;
1439  int tag;
1440  bitvector markbits = GCmarkbits;
1441    /* keep track of whether or not we saw any
1442       code_vector headers, and only flush cache if so. */
1443  Boolean GCrelocated_code_vector = false;
1444
1445  if (dnode < GCndnodes_in_area) {
1446    lisp_global(FWDNUM) += (1<<fixnum_shift);
1447 
1448    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1449    while (dnode < GCndnodes_in_area) {
1450      if (bits == 0) {
1451        int remain = nbits_in_word - bitidx;
1452        dnode += remain;
1453        src += (remain+remain);
1454        bits = *++bitsp;
1455        bitidx = 0;
1456      } else {
1457        /* Have a non-zero markbits word; all bits more significant
1458           than "bitidx" are 0.  Count leading zeros in "bits"
1459           (there'll be at least "bitidx" of them.)  If there are more
1460           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1461           "src" by the difference. */
1462        nextbit = count_leading_zeros(bits);
1463        if ((diff = (nextbit - bitidx)) != 0) {
1464          dnode += diff;
1465          bitidx = nextbit;
1466          src += (diff+diff);
1467        }
1468        prev = current;
1469        current = src;
1470        if (GCDebug) {
1471          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1472            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1473                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1474          }
1475        }
1476
1477        node = *src++;
1478        tag = fulltag_of(node);
1479        if (nodeheader_tag_p(tag)) {
1480          elements = header_element_count(node);
1481          node_dnodes = (elements+2)>>1;
1482          dnode += node_dnodes;
1483          if (header_subtag(node) == subtag_function) {
1484            int skip = *((int *)src);
1485            *dest++ = node;
1486            elements -= skip;
1487            while(skip--) {
1488              *dest++ = *src++;
1489            }
1490            while(elements--) {
1491              *dest++ = node_forwarding_address(*src++);
1492            }
1493            if (((LispObj)src) & node_size) {
1494              src++;
1495              *dest++ = 0;
1496            }
1497          } else {
1498            if ((header_subtag(node) == subtag_hash_vector) &&
1499                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1500              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1501              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1502             
1503              *dest++ = node;
1504              elements -= skip;
1505              while(skip--) {
1506                *dest++ = node_forwarding_address(*src++);
1507              }
1508              /* There should be an even number of (key/value) pairs in elements;
1509                 an extra alignment word follows. */
1510              elements >>= 1;
1511              while (elements--) {
1512                if (hashp) {
1513                  node = *src++;
1514                  new = node_forwarding_address(node);
1515                  if (new != node) {
1516                    hashp->flags |= nhash_key_moved_mask;
1517                    hashp = NULL;
1518                    *dest++ = new;
1519                  } else {
1520                    *dest++ = node;
1521                  }
1522                } else {
1523                  *dest++ = node_forwarding_address(*src++);
1524                }
1525                *dest++ = node_forwarding_address(*src++);
1526              }
1527              *dest++ = 0;
1528              src++;
1529            } else {
1530              *dest++ = node;
1531              *dest++ = node_forwarding_address(*src++);
1532              while(--node_dnodes) {
1533                *dest++ = node_forwarding_address(*src++);
1534                *dest++ = node_forwarding_address(*src++);
1535              }
1536            }
1537          }
1538          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1539        } else if (immheader_tag_p(tag)) {
1540          *dest++ = node;
1541          *dest++ = *src++;
1542          elements = header_element_count(node);
1543          tag = header_subtag(node);
1544
1545
1546          switch(fulltag_of(tag)) {
1547          case ivector_class_64_bit:
1548            imm_dnodes = ((elements+1)+1)>>1;
1549            break;
1550          case ivector_class_32_bit:
1551            imm_dnodes = (((elements+2)+3)>>2);
1552            break;
1553          case ivector_class_other_bit:
1554            if (tag == subtag_bit_vector) {
1555              imm_dnodes = (((elements+64)+127)>>7);
1556            } else if (tag >= min_8_bit_ivector_subtag) {
1557              imm_dnodes = (((elements+8)+15)>>4);
1558            } else {
1559              imm_dnodes = (((elements+4)+7)>>3);
1560            }
1561          }
1562          dnode += imm_dnodes;
1563          while (--imm_dnodes) {
1564            *dest++ = *src++;
1565            *dest++ = *src++;
1566          }
1567          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1568        } else {
1569          *dest++ = node_forwarding_address(node);
1570          *dest++ = node_forwarding_address(*src++);
1571          bits &= ~(BIT0_MASK >> bitidx);
1572          dnode++;
1573          bitidx++;
1574        }
1575      }
1576 
1577    }
1578
1579  }
1580  return ptr_to_lispobj(dest);
1581}
1582
1583
1584
1585
1586
1587     
1588   
1589/*
1590  Total the (physical) byte sizes of all ivectors in the indicated memory range
1591*/
1592
1593natural
1594unboxed_bytes_in_range(LispObj *start, LispObj *end)
1595{
1596  natural total=0, elements, tag, subtag, bytes;
1597  LispObj header;
1598
1599  while (start < end) {
1600    header = *start;
1601    tag = fulltag_of(header);
1602   
1603    if ((nodeheader_tag_p(tag)) ||
1604        (immheader_tag_p(tag))) {
1605      elements = header_element_count(header);
1606      if (nodeheader_tag_p(tag)) {
1607        start += ((elements+2) & ~1);
1608      } else {
1609        subtag = header_subtag(header);
1610
1611        switch(fulltag_of(header)) {
1612        case ivector_class_64_bit:
1613          bytes = 8 + (elements<<3);
1614          break;
1615        case ivector_class_32_bit:
1616          bytes = 8 + (elements<<2);
1617          break;
1618        case ivector_class_other_bit:
1619        default:
1620          if (subtag == subtag_bit_vector) {
1621            bytes = 8 + ((elements+7)>>3);
1622          } else if (subtag >= min_8_bit_ivector_subtag) {
1623            bytes = 8 + elements;
1624          } else {
1625            bytes = 8 + (elements<<1);
1626          }
1627        }
1628        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1629        total += bytes;
1630        start += (bytes >> node_shift);
1631      }
1632    } else {
1633      start += 2;
1634    }
1635  }
1636  return total;
1637}
1638
1639
1640/*
1641  This assumes that it's getting called with a simple-{base,general}-string
1642  or code vector as an argument and that there's room for the object in the
1643  destination area.
1644*/
1645
1646
1647LispObj
1648purify_displaced_object(LispObj obj, area *dest, natural disp)
1649{
1650  BytePtr
1651    free = dest->active,
1652    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1653  LispObj
1654    header = header_of(obj), 
1655    new;
1656  natural
1657    start = (natural)old,
1658    physbytes;
1659
1660  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1661
1662  dest->active += physbytes;
1663
1664  new = ptr_to_lispobj(free)+disp;
1665
1666  memcpy(free, (BytePtr)old, physbytes);
1667  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1668  /* Actually, it's best to always leave a trail, for two reasons.
1669     a) We may be walking the same heap that we're leaving forwaring
1670     pointers in, so we don't want garbage that we leave behind to
1671     look like a header.
1672     b) We'd like to be able to forward code-vector locatives, and
1673     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1674     pair at every doubleword in the old vector.
1675     */
1676  while(physbytes) {
1677    *old++ = (BytePtr) forward_marker;
1678    *old++ = (BytePtr) free;
1679    free += dnode_size;
1680    physbytes -= dnode_size;
1681  }
1682  return new;
1683}
1684
1685LispObj
1686purify_object(LispObj obj, area *dest)
1687{
1688  return purify_displaced_object(obj, dest, fulltag_of(obj));
1689}
1690
1691
1692
1693
1694/*
1695  This may overestimate a bit, if the same symbol is accessible from multiple
1696  packages.
1697*/
1698natural
1699interned_pname_bytes_in_range(LispObj *start, LispObj *end)
1700{
1701  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
1702  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
1703  package *p;
1704  cons *c;
1705  natural elements, i, nbytes = 0;
1706
1707  while (fulltag_of(pkg_list) == fulltag_cons) {
1708    c = (cons *) ptr_from_lispobj(untag(pkg_list));
1709    p = (package *) ptr_from_lispobj(untag(c->car));
1710    pkg_list = c->cdr;
1711    c = (cons *) ptr_from_lispobj(untag(p->itab));
1712    htab = c->car;
1713    elements = header_element_count(header_of(htab));
1714    for (i = 1; i<= elements; i++) {
1715      obj = deref(htab,i);
1716      if (fulltag_of(obj) == fulltag_symbol) {
1717        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
1718        pname = rawsym->pname;
1719
1720        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
1721          pname_header = header_of(pname);
1722          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
1723        }
1724      }
1725    }
1726    c = (cons *) ptr_from_lispobj(untag(p->etab));
1727    htab = c->car;
1728    elements = header_element_count(header_of(htab));
1729    for (i = 1; i<= elements; i++) {
1730      obj = deref(htab,i);
1731      if (fulltag_of(obj) == fulltag_symbol) {
1732        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
1733        pname = rawsym->pname;
1734
1735        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
1736          pname_header = header_of(pname);
1737          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
1738        }
1739      }
1740    }
1741  }
1742  return nbytes;
1743}
1744
1745Boolean
1746copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1747{
1748  LispObj obj = *ref, header, new;
1749  natural tag = fulltag_of(obj), header_tag, header_subtag;
1750  Boolean changed = false;
1751
1752  if ((tag == fulltag_misc) &&
1753      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1754      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1755    header = deref(obj, 0);
1756    if (header == forward_marker) { /* already copied */
1757      *ref = (untag(deref(obj,1)) + tag);
1758      changed = true;
1759    } else {
1760      header_tag = fulltag_of(header);
1761      if (immheader_tag_p(header_tag)) {
1762        new = purify_object(obj, dest);
1763        *ref = new;
1764        changed = (new != obj);
1765      }
1766    }
1767  }
1768  return changed;
1769}
1770
1771
1772void
1773purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
1774{
1775  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
1776
1777  while ((*prev) != (LispObj)NULL) {
1778    copy_ivector_reference(prev, low, high, to);
1779    next = *prev;
1780    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1781  }
1782}
1783
1784void 
1785purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1786{
1787  while (start < end) { 
1788    copy_ivector_reference(start, low, high, to);
1789    start++;
1790  }
1791}
1792   
1793void
1794purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1795{
1796  LispObj header;
1797  unsigned tag;
1798  natural nwords;
1799  hash_table_vector_header *hashp;
1800
1801  while (start < end) {
1802    header = *start;
1803    if (header == forward_marker) {
1804      start += 2;
1805    } else {
1806      tag = fulltag_of(header);
1807      if (immheader_tag_p(tag)) {
1808        start = (LispObj *)skip_over_ivector((natural)start, header);
1809      } else if (nodeheader_tag_p(tag)) {
1810        nwords = header_element_count(header);
1811        nwords += (1 - (nwords&1));
1812        if ((header_subtag(header) == subtag_hash_vector) &&
1813          ((((hash_table_vector_header *)start)->flags) & 
1814           nhash_track_keys_mask)) {
1815          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1816
1817          hashp = (hash_table_vector_header *) start;
1818          start++;
1819          nwords -= skip;
1820          while(skip--) {
1821            copy_ivector_reference(start, low, high, to);
1822            start++;
1823          }
1824          /* "nwords" is odd at this point: there are (floor nwords 2)
1825             key/value pairs to look at, and then an extra word for
1826             alignment.  Process them two at a time, then bump "start"
1827             past the alignment word. */
1828          nwords >>= 1;
1829          while(nwords--) {
1830            if (copy_ivector_reference(start, low, high, to) && hashp) {
1831              hashp->flags |= nhash_key_moved_mask;
1832              hashp = NULL;
1833            }
1834            start++;
1835            copy_ivector_reference(start, low, high, to);
1836            start++;
1837          }
1838          *start++ = 0;
1839        } else {
1840          if (header_subtag(header) == subtag_function) {
1841            int skip = (int)(start[1]);
1842            start += skip;
1843            nwords -= skip;
1844          }
1845          start++;
1846          while(nwords--) {
1847            copy_ivector_reference(start, low, high, to);
1848            start++;
1849          }
1850        }
1851      } else {
1852        /* Not a header, just a cons cell */
1853        copy_ivector_reference(start, low, high, to);
1854        start++;
1855        copy_ivector_reference(start, low, high, to);
1856        start++;
1857      }
1858    }
1859  }
1860}
1861       
1862/* Purify references from tstack areas */
1863void
1864purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
1865{
1866  LispObj
1867    *current,
1868    *next,
1869    *start = (LispObj *) (a->active),
1870    *end = start,
1871    *limit = (LispObj *) (a->high);
1872
1873  for (current = start;
1874       end != limit;
1875       current = next) {
1876    next = (LispObj *) ptr_from_lispobj(*current);
1877    end = ((next >= start) && (next < limit)) ? next : limit;
1878    purify_range(current+2, end, low, high, to);
1879  }
1880}
1881
1882/* Purify a vstack area */
1883void
1884purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
1885{
1886  LispObj
1887    *p = (LispObj *) a->active,
1888    *q = (LispObj *) a->high;
1889 
1890  purify_headerless_range(p, q, low, high, to);
1891}
1892
1893
1894void
1895purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
1896{
1897  natural *regs = (natural *) xpGPRvector(xp);
1898
1899
1900#ifdef X8664
1901  copy_ivector_reference(&(regs[Iarg_z]), low, high, to);
1902  copy_ivector_reference(&(regs[Iarg_y]), low, high, to);
1903  copy_ivector_reference(&(regs[Iarg_x]), low, high, to);
1904  copy_ivector_reference(&(regs[Isave3]), low, high, to);
1905  copy_ivector_reference(&(regs[Isave2]), low, high, to);
1906  copy_ivector_reference(&(regs[Isave1]), low, high, to);
1907  copy_ivector_reference(&(regs[Isave0]), low, high, to);
1908  copy_ivector_reference(&(regs[Ifn]), low, high, to);
1909  copy_ivector_reference(&(regs[Itemp0]), low, high, to);
1910  copy_ivector_reference(&(regs[Itemp1]), low, high, to);
1911  copy_ivector_reference(&(regs[Itemp2]), low, high, to);
1912#if 0
1913  purify_locref(&(regs[Iip]), low, high, to);
1914#endif
1915#else
1916#endif
1917}
1918
1919void
1920purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
1921{
1922  natural n = tcr->tlb_limit;
1923  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
1924
1925  purify_range(start, end, low, high, to);
1926}
1927
1928void
1929purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
1930{
1931  xframe_list *xframes;
1932  ExceptionInformation *xp;
1933 
1934  xp = tcr->gc_context;
1935  if (xp) {
1936    purify_xp(xp, low, high, to);
1937  }
1938
1939  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1940    purify_xp(xframes->curr, low, high, to);
1941  }
1942}
1943
1944
1945void
1946purify_areas(BytePtr low, BytePtr high, area *target)
1947{
1948  area *next_area;
1949  area_code code;
1950     
1951  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1952    switch (code) {
1953    case AREA_TSTACK:
1954      purify_tstack_area(next_area, low, high, target);
1955      break;
1956     
1957    case AREA_VSTACK:
1958      purify_vstack_area(next_area, low, high, target);
1959      break;
1960     
1961    case AREA_CSTACK:
1962      break;
1963     
1964    case AREA_STATIC:
1965    case AREA_DYNAMIC:
1966      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
1967      break;
1968     
1969    default:
1970      break;
1971    }
1972  }
1973}
1974
1975/*
1976  So far, this is mostly for save_application's benefit.
1977  We -should- be able to return to lisp code after doing this,
1978  however.
1979
1980*/
1981
1982
1983int
1984purify(TCR *tcr, signed_natural param)
1985{
1986  extern area *extend_readonly_area(unsigned);
1987  area
1988    *a = active_dynamic_area,
1989    *new_pure_area;
1990
1991  TCR  *other_tcr;
1992  natural max_pure_size;
1993  OSErr err;
1994  BytePtr new_pure_start;
1995
1996
1997
1998  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
1999                                         (LispObj *) a->active);
2000  new_pure_area = extend_readonly_area(max_pure_size);
2001  if (new_pure_area) {
2002    new_pure_start = new_pure_area->active;
2003    lisp_global(IN_GC) = (1<<fixnumshift);
2004
2005    /*
2006
2007       
2008      Make the new_pure_area executable, just in case.
2009
2010      Caller will typically GC again (and that should recover quite a bit of
2011      the dynamic heap.)
2012      */
2013
2014
2015   
2016    purify_areas(a->low, a->active, new_pure_area);
2017   
2018    other_tcr = tcr;
2019    do {
2020      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
2021      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
2022      other_tcr = other_tcr->next;
2023    } while (other_tcr != tcr);
2024
2025    purify_gcable_ptrs(a->low, a->active, new_pure_area);
2026    {
2027      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2028      if (puresize != 0) {
2029        xMakeDataExecutable(new_pure_start, puresize);
2030 
2031      }
2032    }
2033    ProtectMemory(new_pure_area->low,
2034                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2035                                      log2_page_size));
2036    lisp_global(IN_GC) = 0;
2037    just_purified_p = true;
2038    return 0;
2039  }
2040  return -1;
2041}
2042
2043
2044 
2045Boolean
2046impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2047{
2048  LispObj q = *p;
2049 
2050  if (is_node_fulltag(fulltag_of(q)) &&
2051      (q >= low) && 
2052      (q < high)) {
2053    *p = (q+delta);
2054    return true;
2055  }
2056  return false;
2057}
2058 
2059
2060void
2061impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2062{
2063  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2064
2065  while ((*prev) != (LispObj)NULL) {
2066    impurify_noderef(prev, low, high, delta);
2067    next = *prev;
2068    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2069  }
2070}
2071
2072
2073void
2074impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2075{
2076  natural *regs = (natural *) xpGPRvector(xp);
2077
2078
2079#ifdef X8664
2080  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2081  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2082  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2083  impurify_noderef(&(regs[Isave3]), low, high, delta);
2084  impurify_noderef(&(regs[Isave2]), low, high, delta);
2085  impurify_noderef(&(regs[Isave1]), low, high, delta);
2086  impurify_noderef(&(regs[Isave0]), low, high, delta);
2087  impurify_noderef(&(regs[Ifn]), low, high, delta);
2088  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2089  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2090#if 0
2091  impurify_locref(&(regs[Iip]), low, high, delta);
2092#endif
2093#else
2094#endif
2095
2096}
2097
2098void
2099impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2100{
2101  while (start < end) {
2102    impurify_noderef(start, low, high, delta);
2103    start++;
2104  }
2105}
2106
2107
2108void
2109impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2110{
2111  LispObj header;
2112  unsigned tag;
2113  natural nwords;
2114  hash_table_vector_header *hashp;
2115
2116  while (start < end) {
2117    header = *start;
2118    if (header == forward_marker) {
2119      start += 2;
2120    } else {
2121      tag = fulltag_of(header);
2122      if (immheader_tag_p(tag)) {
2123        start = (LispObj *)skip_over_ivector((natural)start, header);
2124      } else if (nodeheader_tag_p(tag)) {
2125        nwords = header_element_count(header);
2126        nwords += (1 - (nwords&1));
2127        if ((header_subtag(header) == subtag_hash_vector) &&
2128          ((((hash_table_vector_header *)start)->flags) & 
2129           nhash_track_keys_mask)) {
2130          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2131
2132          hashp = (hash_table_vector_header *) start;
2133          start++;
2134          nwords -= skip;
2135          while(skip--) {
2136            impurify_noderef(start, low, high, delta);
2137            start++;
2138          }
2139          /* "nwords" is odd at this point: there are (floor nwords 2)
2140             key/value pairs to look at, and then an extra word for
2141             alignment.  Process them two at a time, then bump "start"
2142             past the alignment word. */
2143          nwords >>= 1;
2144          while(nwords--) {
2145            if (impurify_noderef(start, low, high, delta) && hashp) {
2146              hashp->flags |= nhash_key_moved_mask;
2147              hashp = NULL;
2148            }
2149            start++;
2150            impurify_noderef(start, low, high, delta);
2151            start++;
2152          }
2153          *start++ = 0;
2154        } else {
2155          if (header_subtag(header) == subtag_function) {
2156            int skip = (int)(start[1]);
2157            start += skip;
2158            nwords -= skip;
2159          }
2160          start++;
2161          while(nwords--) {
2162            impurify_noderef(start, low, high, delta);
2163            start++;
2164          }
2165        }
2166      } else {
2167        /* Not a header, just a cons cell */
2168        impurify_noderef(start, low, high, delta);
2169        start++;
2170        impurify_noderef(start, low, high, delta);
2171        start++;
2172      }
2173    }
2174  }
2175}
2176
2177
2178
2179
2180void
2181impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2182{
2183  unsigned n = tcr->tlb_limit;
2184  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2185 
2186  impurify_range(start, end, low, high, delta);
2187}
2188
2189void
2190impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2191{
2192  xframe_list *xframes;
2193  ExceptionInformation *xp;
2194 
2195  xp = tcr->gc_context;
2196  if (xp) {
2197    impurify_xp(xp, low, high, delta);
2198  }
2199
2200  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2201    impurify_xp(xframes->curr, low, high, delta);
2202  }
2203}
2204
2205void
2206impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2207{
2208  LispObj
2209    *current,
2210    *next,
2211    *start = (LispObj *) (a->active),
2212    *end = start,
2213    *limit = (LispObj *) (a->high);
2214
2215  for (current = start;
2216       end != limit;
2217       current = next) {
2218    next = (LispObj *) ptr_from_lispobj(*current);
2219    end = ((next >= start) && (next < limit)) ? next : limit;
2220    if (current[1] == 0) {
2221      impurify_range(current+2, end, low, high, delta);
2222    }
2223  }
2224}
2225void
2226impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2227{
2228  LispObj
2229    *p = (LispObj *) a->active,
2230    *q = (LispObj *) a->high;
2231
2232  impurify_headerless_range(p, q, low, high, delta);
2233}
2234
2235
2236void
2237impurify_areas(LispObj low, LispObj high, signed_natural delta)
2238{
2239  area *next_area;
2240  area_code code;
2241     
2242  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2243    switch (code) {
2244    case AREA_TSTACK:
2245      impurify_tstack_area(next_area, low, high, delta);
2246      break;
2247     
2248    case AREA_VSTACK:
2249      impurify_vstack_area(next_area, low, high, delta);
2250      break;
2251     
2252    case AREA_CSTACK:
2253      break;
2254     
2255    case AREA_STATIC:
2256    case AREA_DYNAMIC:
2257      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2258      break;
2259     
2260    default:
2261      break;
2262    }
2263  }
2264}
2265
2266int
2267impurify(TCR *tcr, signed_natural param)
2268{
2269  area *r = find_readonly_area();
2270
2271  if (r) {
2272    area *a = active_dynamic_area;
2273    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2274      oldhigh = a->high, newhigh; 
2275    unsigned n = ro_limit - ro_base;
2276    signed_natural delta = oldfree-ro_base;
2277    TCR *other_tcr;
2278
2279    if (n) {
2280      lisp_global(IN_GC) = 1;
2281      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2282                                               log2_heap_segment_size));
2283      if (newhigh > oldhigh) {
2284        grow_dynamic_area(newhigh-oldhigh);
2285      }
2286      a->active += n;
2287      memmove(oldfree, ro_base, n);
2288      munmap((void *)ro_base, n);
2289      a->ndnodes = area_dnode(a, a->active);
2290      pure_space_active = r->active = r->low;
2291      r->ndnodes = 0;
2292
2293      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2294
2295      other_tcr = tcr;
2296      do {
2297        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2298        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2299        other_tcr = other_tcr->next;
2300      } while (other_tcr != tcr);
2301
2302      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2303      lisp_global(IN_GC) = 0;
2304    }
2305    return 0;
2306  }
2307  return -1;
2308}
Note: See TracBrowser for help on using the repository browser.