source: branches/win64/lisp-kernel/x86-gc.c @ 9554

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

Try to suppress compiler warnings, but it may be a losing battle.

  • 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%Ix has bogus header : 0x%Ix", 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;
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
1444  if (dnode < GCndnodes_in_area) {
1445    lisp_global(FWDNUM) += (1<<fixnum_shift);
1446 
1447    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1448    while (dnode < GCndnodes_in_area) {
1449      if (bits == 0) {
1450        int remain = nbits_in_word - bitidx;
1451        dnode += remain;
1452        src += (remain+remain);
1453        bits = *++bitsp;
1454        bitidx = 0;
1455      } else {
1456        /* Have a non-zero markbits word; all bits more significant
1457           than "bitidx" are 0.  Count leading zeros in "bits"
1458           (there'll be at least "bitidx" of them.)  If there are more
1459           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1460           "src" by the difference. */
1461        nextbit = count_leading_zeros(bits);
1462        if ((diff = (nextbit - bitidx)) != 0) {
1463          dnode += diff;
1464          bitidx = nextbit;
1465          src += (diff+diff);
1466        }
1467        prev = current;
1468        current = src;
1469        if (GCDebug) {
1470          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1471            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1472                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1473          }
1474        }
1475
1476        node = *src++;
1477        tag = fulltag_of(node);
1478        if (nodeheader_tag_p(tag)) {
1479          elements = header_element_count(node);
1480          node_dnodes = (elements+2)>>1;
1481          dnode += node_dnodes;
1482          if (header_subtag(node) == subtag_function) {
1483            int skip = *((int *)src);
1484            *dest++ = node;
1485            elements -= skip;
1486            while(skip--) {
1487              *dest++ = *src++;
1488            }
1489            while(elements--) {
1490              *dest++ = node_forwarding_address(*src++);
1491            }
1492            if (((LispObj)src) & node_size) {
1493              src++;
1494              *dest++ = 0;
1495            }
1496          } else {
1497            if ((header_subtag(node) == subtag_hash_vector) &&
1498                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1499              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1500              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1501             
1502              *dest++ = node;
1503              elements -= skip;
1504              while(skip--) {
1505                *dest++ = node_forwarding_address(*src++);
1506              }
1507              /* There should be an even number of (key/value) pairs in elements;
1508                 an extra alignment word follows. */
1509              elements >>= 1;
1510              while (elements--) {
1511                if (hashp) {
1512                  node = *src++;
1513                  new = node_forwarding_address(node);
1514                  if (new != node) {
1515                    hashp->flags |= nhash_key_moved_mask;
1516                    hashp = NULL;
1517                    *dest++ = new;
1518                  } else {
1519                    *dest++ = node;
1520                  }
1521                } else {
1522                  *dest++ = node_forwarding_address(*src++);
1523                }
1524                *dest++ = node_forwarding_address(*src++);
1525              }
1526              *dest++ = 0;
1527              src++;
1528            } else {
1529              *dest++ = node;
1530              *dest++ = node_forwarding_address(*src++);
1531              while(--node_dnodes) {
1532                *dest++ = node_forwarding_address(*src++);
1533                *dest++ = node_forwarding_address(*src++);
1534              }
1535            }
1536          }
1537          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1538        } else if (immheader_tag_p(tag)) {
1539          *dest++ = node;
1540          *dest++ = *src++;
1541          elements = header_element_count(node);
1542          tag = header_subtag(node);
1543
1544
1545          switch(fulltag_of(tag)) {
1546          case ivector_class_64_bit:
1547            imm_dnodes = ((elements+1)+1)>>1;
1548            break;
1549          case ivector_class_32_bit:
1550            imm_dnodes = (((elements+2)+3)>>2);
1551            break;
1552          case ivector_class_other_bit:
1553            if (tag == subtag_bit_vector) {
1554              imm_dnodes = (((elements+64)+127)>>7);
1555            } else if (tag >= min_8_bit_ivector_subtag) {
1556              imm_dnodes = (((elements+8)+15)>>4);
1557            } else {
1558              imm_dnodes = (((elements+4)+7)>>3);
1559            }
1560          }
1561          dnode += imm_dnodes;
1562          while (--imm_dnodes) {
1563            *dest++ = *src++;
1564            *dest++ = *src++;
1565          }
1566          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1567        } else {
1568          *dest++ = node_forwarding_address(node);
1569          *dest++ = node_forwarding_address(*src++);
1570          bits &= ~(BIT0_MASK >> bitidx);
1571          dnode++;
1572          bitidx++;
1573        }
1574      }
1575 
1576    }
1577
1578  }
1579  return ptr_to_lispobj(dest);
1580}
1581
1582
1583
1584
1585
1586     
1587   
1588/*
1589  Total the (physical) byte sizes of all ivectors in the indicated memory range
1590*/
1591
1592natural
1593unboxed_bytes_in_range(LispObj *start, LispObj *end)
1594{
1595  natural total=0, elements, tag, subtag, bytes;
1596  LispObj header;
1597
1598  while (start < end) {
1599    header = *start;
1600    tag = fulltag_of(header);
1601   
1602    if ((nodeheader_tag_p(tag)) ||
1603        (immheader_tag_p(tag))) {
1604      elements = header_element_count(header);
1605      if (nodeheader_tag_p(tag)) {
1606        start += ((elements+2) & ~1);
1607      } else {
1608        subtag = header_subtag(header);
1609
1610        switch(fulltag_of(header)) {
1611        case ivector_class_64_bit:
1612          bytes = 8 + (elements<<3);
1613          break;
1614        case ivector_class_32_bit:
1615          bytes = 8 + (elements<<2);
1616          break;
1617        case ivector_class_other_bit:
1618        default:
1619          if (subtag == subtag_bit_vector) {
1620            bytes = 8 + ((elements+7)>>3);
1621          } else if (subtag >= min_8_bit_ivector_subtag) {
1622            bytes = 8 + elements;
1623          } else {
1624            bytes = 8 + (elements<<1);
1625          }
1626        }
1627        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1628        total += bytes;
1629        start += (bytes >> node_shift);
1630      }
1631    } else {
1632      start += 2;
1633    }
1634  }
1635  return total;
1636}
1637
1638
1639/*
1640  This assumes that it's getting called with a simple-{base,general}-string
1641  or code vector as an argument and that there's room for the object in the
1642  destination area.
1643*/
1644
1645
1646LispObj
1647purify_displaced_object(LispObj obj, area *dest, natural disp)
1648{
1649  BytePtr
1650    free = dest->active,
1651    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1652  LispObj
1653    header = header_of(obj), 
1654    new;
1655  natural
1656    start = (natural)old,
1657    physbytes;
1658
1659  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1660
1661  dest->active += physbytes;
1662
1663  new = ptr_to_lispobj(free)+disp;
1664
1665  memcpy(free, (BytePtr)old, physbytes);
1666  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1667  /* Actually, it's best to always leave a trail, for two reasons.
1668     a) We may be walking the same heap that we're leaving forwaring
1669     pointers in, so we don't want garbage that we leave behind to
1670     look like a header.
1671     b) We'd like to be able to forward code-vector locatives, and
1672     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1673     pair at every doubleword in the old vector.
1674     */
1675  while(physbytes) {
1676    *old++ = (BytePtr) forward_marker;
1677    *old++ = (BytePtr) free;
1678    free += dnode_size;
1679    physbytes -= dnode_size;
1680  }
1681  return new;
1682}
1683
1684LispObj
1685purify_object(LispObj obj, area *dest)
1686{
1687  return purify_displaced_object(obj, dest, fulltag_of(obj));
1688}
1689
1690
1691
1692
1693/*
1694  This may overestimate a bit, if the same symbol is accessible from multiple
1695  packages.
1696*/
1697natural
1698interned_pname_bytes_in_range(LispObj *start, LispObj *end)
1699{
1700  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
1701  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
1702  package *p;
1703  cons *c;
1704  natural elements, i, nbytes = 0;
1705
1706  while (fulltag_of(pkg_list) == fulltag_cons) {
1707    c = (cons *) ptr_from_lispobj(untag(pkg_list));
1708    p = (package *) ptr_from_lispobj(untag(c->car));
1709    pkg_list = c->cdr;
1710    c = (cons *) ptr_from_lispobj(untag(p->itab));
1711    htab = c->car;
1712    elements = header_element_count(header_of(htab));
1713    for (i = 1; i<= elements; i++) {
1714      obj = deref(htab,i);
1715      if (fulltag_of(obj) == fulltag_symbol) {
1716        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
1717        pname = rawsym->pname;
1718
1719        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
1720          pname_header = header_of(pname);
1721          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
1722        }
1723      }
1724    }
1725    c = (cons *) ptr_from_lispobj(untag(p->etab));
1726    htab = c->car;
1727    elements = header_element_count(header_of(htab));
1728    for (i = 1; i<= elements; i++) {
1729      obj = deref(htab,i);
1730      if (fulltag_of(obj) == fulltag_symbol) {
1731        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
1732        pname = rawsym->pname;
1733
1734        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
1735          pname_header = header_of(pname);
1736          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
1737        }
1738      }
1739    }
1740  }
1741  return nbytes;
1742}
1743
1744Boolean
1745copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1746{
1747  LispObj obj = *ref, header, new;
1748  natural tag = fulltag_of(obj), header_tag;
1749  Boolean changed = false;
1750
1751  if ((tag == fulltag_misc) &&
1752      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1753      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1754    header = deref(obj, 0);
1755    if (header == forward_marker) { /* already copied */
1756      *ref = (untag(deref(obj,1)) + tag);
1757      changed = true;
1758    } else {
1759      header_tag = fulltag_of(header);
1760      if (immheader_tag_p(header_tag)) {
1761        new = purify_object(obj, dest);
1762        *ref = new;
1763        changed = (new != obj);
1764      }
1765    }
1766  }
1767  return changed;
1768}
1769
1770
1771void
1772purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
1773{
1774  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
1775
1776  while ((*prev) != (LispObj)NULL) {
1777    copy_ivector_reference(prev, low, high, to);
1778    next = *prev;
1779    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1780  }
1781}
1782
1783void 
1784purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1785{
1786  while (start < end) { 
1787    copy_ivector_reference(start, low, high, to);
1788    start++;
1789  }
1790}
1791   
1792void
1793purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1794{
1795  LispObj header;
1796  unsigned tag;
1797  natural nwords;
1798  hash_table_vector_header *hashp;
1799
1800  while (start < end) {
1801    header = *start;
1802    if (header == forward_marker) {
1803      start += 2;
1804    } else {
1805      tag = fulltag_of(header);
1806      if (immheader_tag_p(tag)) {
1807        start = (LispObj *)skip_over_ivector((natural)start, header);
1808      } else if (nodeheader_tag_p(tag)) {
1809        nwords = header_element_count(header);
1810        nwords += (1 - (nwords&1));
1811        if ((header_subtag(header) == subtag_hash_vector) &&
1812          ((((hash_table_vector_header *)start)->flags) & 
1813           nhash_track_keys_mask)) {
1814          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1815
1816          hashp = (hash_table_vector_header *) start;
1817          start++;
1818          nwords -= skip;
1819          while(skip--) {
1820            copy_ivector_reference(start, low, high, to);
1821            start++;
1822          }
1823          /* "nwords" is odd at this point: there are (floor nwords 2)
1824             key/value pairs to look at, and then an extra word for
1825             alignment.  Process them two at a time, then bump "start"
1826             past the alignment word. */
1827          nwords >>= 1;
1828          while(nwords--) {
1829            if (copy_ivector_reference(start, low, high, to) && hashp) {
1830              hashp->flags |= nhash_key_moved_mask;
1831              hashp = NULL;
1832            }
1833            start++;
1834            copy_ivector_reference(start, low, high, to);
1835            start++;
1836          }
1837          *start++ = 0;
1838        } else {
1839          if (header_subtag(header) == subtag_function) {
1840            int skip = (int)(start[1]);
1841            start += skip;
1842            nwords -= skip;
1843          }
1844          start++;
1845          while(nwords--) {
1846            copy_ivector_reference(start, low, high, to);
1847            start++;
1848          }
1849        }
1850      } else {
1851        /* Not a header, just a cons cell */
1852        copy_ivector_reference(start, low, high, to);
1853        start++;
1854        copy_ivector_reference(start, low, high, to);
1855        start++;
1856      }
1857    }
1858  }
1859}
1860       
1861/* Purify references from tstack areas */
1862void
1863purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
1864{
1865  LispObj
1866    *current,
1867    *next,
1868    *start = (LispObj *) (a->active),
1869    *end = start,
1870    *limit = (LispObj *) (a->high);
1871
1872  for (current = start;
1873       end != limit;
1874       current = next) {
1875    next = (LispObj *) ptr_from_lispobj(*current);
1876    end = ((next >= start) && (next < limit)) ? next : limit;
1877    purify_range(current+2, end, low, high, to);
1878  }
1879}
1880
1881/* Purify a vstack area */
1882void
1883purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
1884{
1885  LispObj
1886    *p = (LispObj *) a->active,
1887    *q = (LispObj *) a->high;
1888 
1889  purify_headerless_range(p, q, low, high, to);
1890}
1891
1892
1893void
1894purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
1895{
1896  natural *regs = (natural *) xpGPRvector(xp);
1897
1898
1899#ifdef X8664
1900  copy_ivector_reference(&(regs[Iarg_z]), low, high, to);
1901  copy_ivector_reference(&(regs[Iarg_y]), low, high, to);
1902  copy_ivector_reference(&(regs[Iarg_x]), low, high, to);
1903  copy_ivector_reference(&(regs[Isave3]), low, high, to);
1904  copy_ivector_reference(&(regs[Isave2]), low, high, to);
1905  copy_ivector_reference(&(regs[Isave1]), low, high, to);
1906  copy_ivector_reference(&(regs[Isave0]), low, high, to);
1907  copy_ivector_reference(&(regs[Ifn]), low, high, to);
1908  copy_ivector_reference(&(regs[Itemp0]), low, high, to);
1909  copy_ivector_reference(&(regs[Itemp1]), low, high, to);
1910  copy_ivector_reference(&(regs[Itemp2]), low, high, to);
1911#if 0
1912  purify_locref(&(regs[Iip]), low, high, to);
1913#endif
1914#else
1915#endif
1916}
1917
1918void
1919purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
1920{
1921  natural n = tcr->tlb_limit;
1922  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
1923
1924  purify_range(start, end, low, high, to);
1925}
1926
1927void
1928purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
1929{
1930  xframe_list *xframes;
1931  ExceptionInformation *xp;
1932 
1933  xp = tcr->gc_context;
1934  if (xp) {
1935    purify_xp(xp, low, high, to);
1936  }
1937
1938  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1939    purify_xp(xframes->curr, low, high, to);
1940  }
1941}
1942
1943
1944void
1945purify_areas(BytePtr low, BytePtr high, area *target)
1946{
1947  area *next_area;
1948  area_code code;
1949     
1950  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1951    switch (code) {
1952    case AREA_TSTACK:
1953      purify_tstack_area(next_area, low, high, target);
1954      break;
1955     
1956    case AREA_VSTACK:
1957      purify_vstack_area(next_area, low, high, target);
1958      break;
1959     
1960    case AREA_CSTACK:
1961      break;
1962     
1963    case AREA_STATIC:
1964    case AREA_DYNAMIC:
1965      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
1966      break;
1967     
1968    default:
1969      break;
1970    }
1971  }
1972}
1973
1974/*
1975  So far, this is mostly for save_application's benefit.
1976  We -should- be able to return to lisp code after doing this,
1977  however.
1978
1979*/
1980
1981
1982int
1983purify(TCR *tcr, signed_natural param)
1984{
1985  extern area *extend_readonly_area(unsigned);
1986  area
1987    *a = active_dynamic_area,
1988    *new_pure_area;
1989
1990  TCR  *other_tcr;
1991  natural max_pure_size;
1992  OSErr err;
1993  BytePtr new_pure_start;
1994
1995
1996
1997  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
1998                                         (LispObj *) a->active);
1999  new_pure_area = extend_readonly_area(max_pure_size);
2000  if (new_pure_area) {
2001    new_pure_start = new_pure_area->active;
2002    lisp_global(IN_GC) = (1<<fixnumshift);
2003
2004    /*
2005
2006       
2007      Make the new_pure_area executable, just in case.
2008
2009      Caller will typically GC again (and that should recover quite a bit of
2010      the dynamic heap.)
2011      */
2012
2013
2014   
2015    purify_areas(a->low, a->active, new_pure_area);
2016   
2017    other_tcr = tcr;
2018    do {
2019      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
2020      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
2021      other_tcr = other_tcr->next;
2022    } while (other_tcr != tcr);
2023
2024    purify_gcable_ptrs(a->low, a->active, new_pure_area);
2025    {
2026      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2027      if (puresize != 0) {
2028        xMakeDataExecutable(new_pure_start, puresize);
2029 
2030      }
2031    }
2032    ProtectMemory(new_pure_area->low,
2033                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2034                                      log2_page_size));
2035    lisp_global(IN_GC) = 0;
2036    just_purified_p = true;
2037    return 0;
2038  }
2039  return -1;
2040}
2041
2042
2043 
2044Boolean
2045impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2046{
2047  LispObj q = *p;
2048 
2049  if (is_node_fulltag(fulltag_of(q)) &&
2050      (q >= low) && 
2051      (q < high)) {
2052    *p = (q+delta);
2053    return true;
2054  }
2055  return false;
2056}
2057 
2058
2059void
2060impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2061{
2062  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2063
2064  while ((*prev) != (LispObj)NULL) {
2065    impurify_noderef(prev, low, high, delta);
2066    next = *prev;
2067    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2068  }
2069}
2070
2071
2072void
2073impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2074{
2075  natural *regs = (natural *) xpGPRvector(xp);
2076
2077
2078#ifdef X8664
2079  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2080  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2081  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2082#ifndef WINDOWS
2083  impurify_noderef(&(regs[Isave3]), low, high, delta);
2084#endif
2085  impurify_noderef(&(regs[Isave2]), low, high, delta);
2086  impurify_noderef(&(regs[Isave1]), low, high, delta);
2087  impurify_noderef(&(regs[Isave0]), low, high, delta);
2088  impurify_noderef(&(regs[Ifn]), low, high, delta);
2089  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2090  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2091#if 0
2092  impurify_locref(&(regs[Iip]), low, high, delta);
2093#endif
2094#else
2095#endif
2096
2097}
2098
2099void
2100impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2101{
2102  while (start < end) {
2103    impurify_noderef(start, low, high, delta);
2104    start++;
2105  }
2106}
2107
2108
2109void
2110impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2111{
2112  LispObj header;
2113  unsigned tag;
2114  natural nwords;
2115  hash_table_vector_header *hashp;
2116
2117  while (start < end) {
2118    header = *start;
2119    if (header == forward_marker) {
2120      start += 2;
2121    } else {
2122      tag = fulltag_of(header);
2123      if (immheader_tag_p(tag)) {
2124        start = (LispObj *)skip_over_ivector((natural)start, header);
2125      } else if (nodeheader_tag_p(tag)) {
2126        nwords = header_element_count(header);
2127        nwords += (1 - (nwords&1));
2128        if ((header_subtag(header) == subtag_hash_vector) &&
2129          ((((hash_table_vector_header *)start)->flags) & 
2130           nhash_track_keys_mask)) {
2131          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2132
2133          hashp = (hash_table_vector_header *) start;
2134          start++;
2135          nwords -= skip;
2136          while(skip--) {
2137            impurify_noderef(start, low, high, delta);
2138            start++;
2139          }
2140          /* "nwords" is odd at this point: there are (floor nwords 2)
2141             key/value pairs to look at, and then an extra word for
2142             alignment.  Process them two at a time, then bump "start"
2143             past the alignment word. */
2144          nwords >>= 1;
2145          while(nwords--) {
2146            if (impurify_noderef(start, low, high, delta) && hashp) {
2147              hashp->flags |= nhash_key_moved_mask;
2148              hashp = NULL;
2149            }
2150            start++;
2151            impurify_noderef(start, low, high, delta);
2152            start++;
2153          }
2154          *start++ = 0;
2155        } else {
2156          if (header_subtag(header) == subtag_function) {
2157            int skip = (int)(start[1]);
2158            start += skip;
2159            nwords -= skip;
2160          }
2161          start++;
2162          while(nwords--) {
2163            impurify_noderef(start, low, high, delta);
2164            start++;
2165          }
2166        }
2167      } else {
2168        /* Not a header, just a cons cell */
2169        impurify_noderef(start, low, high, delta);
2170        start++;
2171        impurify_noderef(start, low, high, delta);
2172        start++;
2173      }
2174    }
2175  }
2176}
2177
2178
2179
2180
2181void
2182impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2183{
2184  unsigned n = tcr->tlb_limit;
2185  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2186 
2187  impurify_range(start, end, low, high, delta);
2188}
2189
2190void
2191impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2192{
2193  xframe_list *xframes;
2194  ExceptionInformation *xp;
2195 
2196  xp = tcr->gc_context;
2197  if (xp) {
2198    impurify_xp(xp, low, high, delta);
2199  }
2200
2201  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2202    impurify_xp(xframes->curr, low, high, delta);
2203  }
2204}
2205
2206void
2207impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2208{
2209  LispObj
2210    *current,
2211    *next,
2212    *start = (LispObj *) (a->active),
2213    *end = start,
2214    *limit = (LispObj *) (a->high);
2215
2216  for (current = start;
2217       end != limit;
2218       current = next) {
2219    next = (LispObj *) ptr_from_lispobj(*current);
2220    end = ((next >= start) && (next < limit)) ? next : limit;
2221    if (current[1] == 0) {
2222      impurify_range(current+2, end, low, high, delta);
2223    }
2224  }
2225}
2226void
2227impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2228{
2229  LispObj
2230    *p = (LispObj *) a->active,
2231    *q = (LispObj *) a->high;
2232
2233  impurify_headerless_range(p, q, low, high, delta);
2234}
2235
2236
2237void
2238impurify_areas(LispObj low, LispObj high, signed_natural delta)
2239{
2240  area *next_area;
2241  area_code code;
2242     
2243  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2244    switch (code) {
2245    case AREA_TSTACK:
2246      impurify_tstack_area(next_area, low, high, delta);
2247      break;
2248     
2249    case AREA_VSTACK:
2250      impurify_vstack_area(next_area, low, high, delta);
2251      break;
2252     
2253    case AREA_CSTACK:
2254      break;
2255     
2256    case AREA_STATIC:
2257    case AREA_DYNAMIC:
2258      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2259      break;
2260     
2261    default:
2262      break;
2263    }
2264  }
2265}
2266
2267int
2268impurify(TCR *tcr, signed_natural param)
2269{
2270  area *r = find_readonly_area();
2271
2272  if (r) {
2273    area *a = active_dynamic_area;
2274    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2275      oldhigh = a->high, newhigh; 
2276    unsigned n = ro_limit - ro_base;
2277    signed_natural delta = oldfree-ro_base;
2278    TCR *other_tcr;
2279
2280    if (n) {
2281      lisp_global(IN_GC) = 1;
2282      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2283                                               log2_heap_segment_size));
2284      if (newhigh > oldhigh) {
2285        grow_dynamic_area(newhigh-oldhigh);
2286      }
2287      a->active += n;
2288      memmove(oldfree, ro_base, n);
2289      UnMapMemory((void *)ro_base, n);
2290      a->ndnodes = area_dnode(a, a->active);
2291      pure_space_active = r->active = r->low;
2292      r->ndnodes = 0;
2293
2294      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2295
2296      other_tcr = tcr;
2297      do {
2298        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2299        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2300        other_tcr = other_tcr->next;
2301      } while (other_tcr != tcr);
2302
2303      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2304      lisp_global(IN_GC) = 0;
2305    }
2306    return 0;
2307  }
2308  return -1;
2309}
Note: See TracBrowser for help on using the repository browser.