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

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

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

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