source: release/1.6/source/lisp-kernel/arm-gc.c @ 14499

Last change on this file since 14499 was 14499, checked in by rme, 9 years ago

From trunk: GC integrity check more places; fix to progvsave.
(ARM only)

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