source: trunk/source/lisp-kernel/arm-gc.c @ 14261

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

Rename Threads.h to threads.h (with no capital letter).

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