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

Last change on this file since 14347 was 14269, checked in by gb, 9 years ago

Some Android conditionalization.

Check for ARM function's codevector/entrypoint consistency in
integrity-check code.

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