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

Last change on this file since 10010 was 10010, checked in by gb, 12 years ago

Mostly cosmetic changes (to avoid some gcc warnings at -Wall).
gc-common.c : initialize the fields in a timeval struct, to avoid spurious

warning.

lisp-debug.c : fix typo when printing %rsi value, use %l for nargs.

lisp.h prototype for print_lisp_object()

macros.h : kinder, gentler ptr_to_lispobj(), ptr_from_lispobj(), deref()

macros. (GC seems to miscompile at -low- optimization settings, may
have to do with these macros.)

pmcl-kernel.c : make implicit comparison operands explicit in a few

cases. Use %l when printing paging info.

ppc-constants32.h, ppc-constants64.h, x86-constants64.h: define new

hash-table-vector-header fields, now that we're using them in the
trunk.

thread_manager.c : use signed_natural for futex pointers

x86-gc.c : in mark_root(), use a simpler construct to set a pool's

data to NIL. (This may have been losing under -low- optimization.)

  • 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 = NULL;
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(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
1442  if (dnode < GCndnodes_in_area) {
1443    lisp_global(FWDNUM) += (1<<fixnum_shift);
1444 
1445    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1446    while (dnode < GCndnodes_in_area) {
1447      if (bits == 0) {
1448        int remain = nbits_in_word - bitidx;
1449        dnode += remain;
1450        src += (remain+remain);
1451        bits = *++bitsp;
1452        bitidx = 0;
1453      } else {
1454        /* Have a non-zero markbits word; all bits more significant
1455           than "bitidx" are 0.  Count leading zeros in "bits"
1456           (there'll be at least "bitidx" of them.)  If there are more
1457           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1458           "src" by the difference. */
1459        nextbit = count_leading_zeros(bits);
1460        if ((diff = (nextbit - bitidx)) != 0) {
1461          dnode += diff;
1462          bitidx = nextbit;
1463          src += (diff+diff);
1464        }
1465        prev = current;
1466        current = src;
1467        if (GCDebug) {
1468          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1469            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1470                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1471          }
1472        }
1473
1474        node = *src++;
1475        tag = fulltag_of(node);
1476        if (nodeheader_tag_p(tag)) {
1477          elements = header_element_count(node);
1478          node_dnodes = (elements+2)>>1;
1479          dnode += node_dnodes;
1480          if (header_subtag(node) == subtag_function) {
1481            int skip = *((int *)src);
1482            *dest++ = node;
1483            elements -= skip;
1484            while(skip--) {
1485              *dest++ = *src++;
1486            }
1487            while(elements--) {
1488              *dest++ = node_forwarding_address(*src++);
1489            }
1490            if (((LispObj)src) & node_size) {
1491              src++;
1492              *dest++ = 0;
1493            }
1494          } else {
1495            if ((header_subtag(node) == subtag_hash_vector) &&
1496                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1497              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1498              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1499             
1500              *dest++ = node;
1501              elements -= skip;
1502              while(skip--) {
1503                *dest++ = node_forwarding_address(*src++);
1504              }
1505              /* There should be an even number of (key/value) pairs in elements;
1506                 an extra alignment word follows. */
1507              elements >>= 1;
1508              while (elements--) {
1509                if (hashp) {
1510                  node = *src++;
1511                  new = node_forwarding_address(node);
1512                  if (new != node) {
1513                    hashp->flags |= nhash_key_moved_mask;
1514                    hashp = NULL;
1515                    *dest++ = new;
1516                  } else {
1517                    *dest++ = node;
1518                  }
1519                } else {
1520                  *dest++ = node_forwarding_address(*src++);
1521                }
1522                *dest++ = node_forwarding_address(*src++);
1523              }
1524              *dest++ = 0;
1525              src++;
1526            } else {
1527              *dest++ = node;
1528              *dest++ = node_forwarding_address(*src++);
1529              while(--node_dnodes) {
1530                *dest++ = node_forwarding_address(*src++);
1531                *dest++ = node_forwarding_address(*src++);
1532              }
1533            }
1534          }
1535          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1536        } else if (immheader_tag_p(tag)) {
1537          *dest++ = node;
1538          *dest++ = *src++;
1539          elements = header_element_count(node);
1540          tag = header_subtag(node);
1541
1542
1543          switch(fulltag_of(tag)) {
1544          case ivector_class_64_bit:
1545            imm_dnodes = ((elements+1)+1)>>1;
1546            break;
1547          case ivector_class_32_bit:
1548            imm_dnodes = (((elements+2)+3)>>2);
1549            break;
1550          case ivector_class_other_bit:
1551            if (tag == subtag_bit_vector) {
1552              imm_dnodes = (((elements+64)+127)>>7);
1553            } else if (tag >= min_8_bit_ivector_subtag) {
1554              imm_dnodes = (((elements+8)+15)>>4);
1555            } else {
1556              imm_dnodes = (((elements+4)+7)>>3);
1557            }
1558          }
1559          dnode += imm_dnodes;
1560          while (--imm_dnodes) {
1561            *dest++ = *src++;
1562            *dest++ = *src++;
1563          }
1564          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1565        } else {
1566          *dest++ = node_forwarding_address(node);
1567          *dest++ = node_forwarding_address(*src++);
1568          bits &= ~(BIT0_MASK >> bitidx);
1569          dnode++;
1570          bitidx++;
1571        }
1572      }
1573 
1574    }
1575
1576  }
1577  return ptr_to_lispobj(dest);
1578}
1579
1580
1581
1582
1583
1584     
1585   
1586/*
1587  Total the (physical) byte sizes of all ivectors in the indicated memory range
1588*/
1589
1590natural
1591unboxed_bytes_in_range(LispObj *start, LispObj *end)
1592{
1593  natural total=0, elements, tag, subtag, bytes;
1594  LispObj header;
1595
1596  while (start < end) {
1597    header = *start;
1598    tag = fulltag_of(header);
1599   
1600    if ((nodeheader_tag_p(tag)) ||
1601        (immheader_tag_p(tag))) {
1602      elements = header_element_count(header);
1603      if (nodeheader_tag_p(tag)) {
1604        start += ((elements+2) & ~1);
1605      } else {
1606        subtag = header_subtag(header);
1607
1608        switch(fulltag_of(header)) {
1609        case ivector_class_64_bit:
1610          bytes = 8 + (elements<<3);
1611          break;
1612        case ivector_class_32_bit:
1613          bytes = 8 + (elements<<2);
1614          break;
1615        case ivector_class_other_bit:
1616        default:
1617          if (subtag == subtag_bit_vector) {
1618            bytes = 8 + ((elements+7)>>3);
1619          } else if (subtag >= min_8_bit_ivector_subtag) {
1620            bytes = 8 + elements;
1621          } else {
1622            bytes = 8 + (elements<<1);
1623          }
1624        }
1625        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1626        total += bytes;
1627        start += (bytes >> node_shift);
1628      }
1629    } else {
1630      start += 2;
1631    }
1632  }
1633  return total;
1634}
1635
1636
1637/*
1638  This assumes that it's getting called with a simple-{base,general}-string
1639  or code vector as an argument and that there's room for the object in the
1640  destination area.
1641*/
1642
1643
1644LispObj
1645purify_displaced_object(LispObj obj, area *dest, natural disp)
1646{
1647  BytePtr
1648    free = dest->active,
1649    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1650  LispObj
1651    header = header_of(obj), 
1652    new;
1653  natural
1654    start = (natural)old,
1655    physbytes;
1656
1657  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1658
1659  dest->active += physbytes;
1660
1661  new = ptr_to_lispobj(free)+disp;
1662
1663  memcpy(free, (BytePtr)old, physbytes);
1664  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1665  /* Actually, it's best to always leave a trail, for two reasons.
1666     a) We may be walking the same heap that we're leaving forwaring
1667     pointers in, so we don't want garbage that we leave behind to
1668     look like a header.
1669     b) We'd like to be able to forward code-vector locatives, and
1670     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1671     pair at every doubleword in the old vector.
1672     */
1673  while(physbytes) {
1674    *old++ = (BytePtr) forward_marker;
1675    *old++ = (BytePtr) free;
1676    free += dnode_size;
1677    physbytes -= dnode_size;
1678  }
1679  return new;
1680}
1681
1682LispObj
1683purify_object(LispObj obj, area *dest)
1684{
1685  return purify_displaced_object(obj, dest, fulltag_of(obj));
1686}
1687
1688
1689
1690
1691/*
1692  This may overestimate a bit, if the same symbol is accessible from multiple
1693  packages.
1694*/
1695natural
1696interned_pname_bytes_in_range(LispObj *start, LispObj *end)
1697{
1698  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
1699  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
1700  package *p;
1701  cons *c;
1702  natural elements, i, nbytes = 0;
1703
1704  while (fulltag_of(pkg_list) == fulltag_cons) {
1705    c = (cons *) ptr_from_lispobj(untag(pkg_list));
1706    p = (package *) ptr_from_lispobj(untag(c->car));
1707    pkg_list = c->cdr;
1708    c = (cons *) ptr_from_lispobj(untag(p->itab));
1709    htab = c->car;
1710    elements = header_element_count(header_of(htab));
1711    for (i = 1; i<= elements; i++) {
1712      obj = deref(htab,i);
1713      if (fulltag_of(obj) == fulltag_symbol) {
1714        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
1715        pname = rawsym->pname;
1716
1717        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
1718          pname_header = header_of(pname);
1719          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
1720        }
1721      }
1722    }
1723    c = (cons *) ptr_from_lispobj(untag(p->etab));
1724    htab = c->car;
1725    elements = header_element_count(header_of(htab));
1726    for (i = 1; i<= elements; i++) {
1727      obj = deref(htab,i);
1728      if (fulltag_of(obj) == fulltag_symbol) {
1729        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
1730        pname = rawsym->pname;
1731
1732        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
1733          pname_header = header_of(pname);
1734          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
1735        }
1736      }
1737    }
1738  }
1739  return nbytes;
1740}
1741
1742Boolean
1743copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1744{
1745  LispObj obj = *ref, header, new;
1746  natural tag = fulltag_of(obj), header_tag;
1747  Boolean changed = false;
1748
1749  if ((tag == fulltag_misc) &&
1750      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1751      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1752    header = deref(obj, 0);
1753    if (header == forward_marker) { /* already copied */
1754      *ref = (untag(deref(obj,1)) + tag);
1755      changed = true;
1756    } else {
1757      header_tag = fulltag_of(header);
1758      if (immheader_tag_p(header_tag)) {
1759        if (header_subtag(header) != subtag_macptr) {
1760          new = purify_object(obj, dest);
1761          *ref = new;
1762          changed = (new != obj);
1763        }
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  BytePtr new_pure_start;
1993
1994
1995
1996  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
1997                                         (LispObj *) a->active);
1998  new_pure_area = extend_readonly_area(max_pure_size);
1999  if (new_pure_area) {
2000    new_pure_start = new_pure_area->active;
2001    lisp_global(IN_GC) = (1<<fixnumshift);
2002
2003    /*
2004
2005       
2006      Make the new_pure_area executable, just in case.
2007
2008      Caller will typically GC again (and that should recover quite a bit of
2009      the dynamic heap.)
2010      */
2011
2012
2013   
2014    purify_areas(a->low, a->active, new_pure_area);
2015   
2016    other_tcr = tcr;
2017    do {
2018      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
2019      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
2020      other_tcr = other_tcr->next;
2021    } while (other_tcr != tcr);
2022
2023    purify_gcable_ptrs(a->low, a->active, new_pure_area);
2024    {
2025      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2026      if (puresize != 0) {
2027        xMakeDataExecutable(new_pure_start, puresize);
2028 
2029      }
2030    }
2031    ProtectMemory(new_pure_area->low,
2032                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2033                                      log2_page_size));
2034    lisp_global(IN_GC) = 0;
2035    just_purified_p = true;
2036    return 0;
2037  }
2038  return -1;
2039}
2040
2041
2042 
2043Boolean
2044impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2045{
2046  LispObj q = *p;
2047 
2048  if (is_node_fulltag(fulltag_of(q)) &&
2049      (q >= low) && 
2050      (q < high)) {
2051    *p = (q+delta);
2052    return true;
2053  }
2054  return false;
2055}
2056 
2057
2058void
2059impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2060{
2061  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2062
2063  while ((*prev) != (LispObj)NULL) {
2064    impurify_noderef(prev, low, high, delta);
2065    next = *prev;
2066    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2067  }
2068}
2069
2070
2071void
2072impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2073{
2074  natural *regs = (natural *) xpGPRvector(xp);
2075
2076
2077#ifdef X8664
2078  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2079  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2080  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2081  impurify_noderef(&(regs[Isave3]), low, high, delta);
2082  impurify_noderef(&(regs[Isave2]), low, high, delta);
2083  impurify_noderef(&(regs[Isave1]), low, high, delta);
2084  impurify_noderef(&(regs[Isave0]), low, high, delta);
2085  impurify_noderef(&(regs[Ifn]), low, high, delta);
2086  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2087  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2088#if 0
2089  impurify_locref(&(regs[Iip]), low, high, delta);
2090#endif
2091#else
2092#endif
2093
2094}
2095
2096void
2097impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2098{
2099  while (start < end) {
2100    impurify_noderef(start, low, high, delta);
2101    start++;
2102  }
2103}
2104
2105
2106void
2107impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2108{
2109  LispObj header;
2110  unsigned tag;
2111  natural nwords;
2112  hash_table_vector_header *hashp;
2113
2114  while (start < end) {
2115    header = *start;
2116    if (header == forward_marker) {
2117      start += 2;
2118    } else {
2119      tag = fulltag_of(header);
2120      if (immheader_tag_p(tag)) {
2121        start = (LispObj *)skip_over_ivector((natural)start, header);
2122      } else if (nodeheader_tag_p(tag)) {
2123        nwords = header_element_count(header);
2124        nwords += (1 - (nwords&1));
2125        if ((header_subtag(header) == subtag_hash_vector) &&
2126          ((((hash_table_vector_header *)start)->flags) & 
2127           nhash_track_keys_mask)) {
2128          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2129
2130          hashp = (hash_table_vector_header *) start;
2131          start++;
2132          nwords -= skip;
2133          while(skip--) {
2134            impurify_noderef(start, low, high, delta);
2135            start++;
2136          }
2137          /* "nwords" is odd at this point: there are (floor nwords 2)
2138             key/value pairs to look at, and then an extra word for
2139             alignment.  Process them two at a time, then bump "start"
2140             past the alignment word. */
2141          nwords >>= 1;
2142          while(nwords--) {
2143            if (impurify_noderef(start, low, high, delta) && hashp) {
2144              hashp->flags |= nhash_key_moved_mask;
2145              hashp = NULL;
2146            }
2147            start++;
2148            impurify_noderef(start, low, high, delta);
2149            start++;
2150          }
2151          *start++ = 0;
2152        } else {
2153          if (header_subtag(header) == subtag_function) {
2154            int skip = (int)(start[1]);
2155            start += skip;
2156            nwords -= skip;
2157          }
2158          start++;
2159          while(nwords--) {
2160            impurify_noderef(start, low, high, delta);
2161            start++;
2162          }
2163        }
2164      } else {
2165        /* Not a header, just a cons cell */
2166        impurify_noderef(start, low, high, delta);
2167        start++;
2168        impurify_noderef(start, low, high, delta);
2169        start++;
2170      }
2171    }
2172  }
2173}
2174
2175
2176
2177
2178void
2179impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2180{
2181  unsigned n = tcr->tlb_limit;
2182  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2183 
2184  impurify_range(start, end, low, high, delta);
2185}
2186
2187void
2188impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2189{
2190  xframe_list *xframes;
2191  ExceptionInformation *xp;
2192 
2193  xp = tcr->gc_context;
2194  if (xp) {
2195    impurify_xp(xp, low, high, delta);
2196  }
2197
2198  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2199    impurify_xp(xframes->curr, low, high, delta);
2200  }
2201}
2202
2203void
2204impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2205{
2206  LispObj
2207    *current,
2208    *next,
2209    *start = (LispObj *) (a->active),
2210    *end = start,
2211    *limit = (LispObj *) (a->high);
2212
2213  for (current = start;
2214       end != limit;
2215       current = next) {
2216    next = (LispObj *) ptr_from_lispobj(*current);
2217    end = ((next >= start) && (next < limit)) ? next : limit;
2218    if (current[1] == 0) {
2219      impurify_range(current+2, end, low, high, delta);
2220    }
2221  }
2222}
2223void
2224impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2225{
2226  LispObj
2227    *p = (LispObj *) a->active,
2228    *q = (LispObj *) a->high;
2229
2230  impurify_headerless_range(p, q, low, high, delta);
2231}
2232
2233
2234void
2235impurify_areas(LispObj low, LispObj high, signed_natural delta)
2236{
2237  area *next_area;
2238  area_code code;
2239     
2240  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2241    switch (code) {
2242    case AREA_TSTACK:
2243      impurify_tstack_area(next_area, low, high, delta);
2244      break;
2245     
2246    case AREA_VSTACK:
2247      impurify_vstack_area(next_area, low, high, delta);
2248      break;
2249     
2250    case AREA_CSTACK:
2251      break;
2252     
2253    case AREA_STATIC:
2254    case AREA_DYNAMIC:
2255      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2256      break;
2257     
2258    default:
2259      break;
2260    }
2261  }
2262}
2263
2264#ifdef WINDOWS
2265int
2266impurify(TCR *tcr, signed_natural param)
2267{
2268}
2269#else
2270int
2271impurify(TCR *tcr, signed_natural param)
2272{
2273  area *r = find_readonly_area();
2274
2275  if (r) {
2276    area *a = active_dynamic_area;
2277    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2278      oldhigh = a->high, newhigh; 
2279    unsigned n = ro_limit - ro_base;
2280    signed_natural delta = oldfree-ro_base;
2281    TCR *other_tcr;
2282
2283    if (n) {
2284      lisp_global(IN_GC) = 1;
2285      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2286                                               log2_heap_segment_size));
2287      if (newhigh > oldhigh) {
2288        grow_dynamic_area(newhigh-oldhigh);
2289      }
2290      a->active += n;
2291      memmove(oldfree, ro_base, n);
2292      munmap((void *)ro_base, n);
2293      a->ndnodes = area_dnode(a, a->active);
2294      pure_space_active = r->active = r->low;
2295      r->ndnodes = 0;
2296
2297      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2298
2299      other_tcr = tcr;
2300      do {
2301        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2302        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2303        other_tcr = other_tcr->next;
2304      } while (other_tcr != tcr);
2305
2306      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2307      lisp_global(IN_GC) = 0;
2308    }
2309    return 0;
2310  }
2311  return -1;
2312}
2313#endif
Note: See TracBrowser for help on using the repository browser.