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

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

Merge ARM FFI fixes from trunk.

File size: 55.9 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  LispObj lr_value;
1008
1009  int r;
1010  /* registers between arg_z and Rfn should be tagged and marked as
1011     roots.  the PC, and LR should be treated as "pc_locatives".
1012
1013     In general, marking a locative is more expensive than marking
1014     a node is, since it may be neccessary to back up and find the
1015     containing object's header.  Since exception frames contain
1016     many locatives, it'd be wise to mark them *after* marking the
1017     stacks, nilreg-relative globals, etc.
1018     */
1019
1020  for (r = arg_z; r <= Rfn; r++) {
1021    mark_root((regs[r]));
1022  }
1023
1024
1025
1026  mark_pc_root(ptr_to_lispobj(xpPC(xp)));
1027  lr_value = ptr_to_lispobj(xpLR(xp));
1028  if (*((LispObj *)lr_value) == 0) { /* pointing into a double-float */
1029    mark_root(untag(lr_value)+fulltag_misc);
1030  } else {
1031    mark_pc_root(lr_value);
1032  }
1033}
1034
1035/* A "pagelet" contains 32 doublewords.  The relocation table contains
1036   a word for each pagelet which defines the lowest address to which
1037   dnodes on that pagelet will be relocated.
1038
1039   The relocation address of a given pagelet is the sum of the relocation
1040   address for the preceding pagelet and the number of bytes occupied by
1041   marked objects on the preceding pagelet.
1042*/
1043
1044LispObj
1045calculate_relocation()
1046{
1047  LispObj *relocptr = GCrelocptr;
1048  LispObj current = GCareadynamiclow;
1049  bitvector
1050    markbits = GCdynamic_markbits;
1051  qnode *q = (qnode *) markbits;
1052  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1053  natural thesebits;
1054  LispObj first = 0;
1055
1056  do {
1057    *relocptr++ = current;
1058    thesebits = *markbits++;
1059    if (thesebits == ALL_ONES) {
1060      current += nbits_in_word*dnode_size;
1061      q += 4; /* sic */
1062    } else {
1063      if (!first) {
1064        first = current;
1065        while (thesebits & BIT0_MASK) {
1066          first += dnode_size;
1067          thesebits += thesebits;
1068        }
1069      }
1070      current += one_bits(*q++);
1071      current += one_bits(*q++);
1072      current += one_bits(*q++);
1073      current += one_bits(*q++);
1074    }
1075  } while(--npagelets);
1076  *relocptr++ = current;
1077  return first ? first : current;
1078}
1079
1080LispObj
1081dnode_forwarding_address(natural dnode, int tag_n)
1082{
1083  natural pagelet, nbits;
1084  unsigned short near_bits;
1085  LispObj new;
1086
1087  if (GCDebug) {
1088    if (! ref_bit(GCdynamic_markbits, dnode)) {
1089      Bug(NULL, "unmarked object being forwarded!\n");
1090    }
1091  }
1092
1093  pagelet = dnode >> 5;
1094  nbits = dnode & 0x1f;
1095  /* On little-endian ARM, we have to flip the low bit of dnode>>4 to
1096     get the near_bits from the appropriate half-word. */
1097  near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1];
1098
1099  if (nbits < 16) {
1100    new = GCrelocptr[pagelet] + tag_n;;
1101    /* Increment "new" by the count of 1 bits which precede the dnode */
1102    if (near_bits == 0xffff) {
1103      return (new + (nbits << 3));
1104    } else {
1105      near_bits &= (0xffff0000 >> nbits);
1106      if (nbits > 7) {
1107        new += one_bits(near_bits & 0xff);
1108      }
1109      return (new + (one_bits(near_bits >> 8))); 
1110    }
1111  } else {
1112    new = GCrelocptr[pagelet+1] + tag_n;
1113    nbits = 32-nbits;
1114
1115    if (near_bits == 0xffff) {
1116      return (new - (nbits << 3));
1117    } else {
1118      near_bits &= (1<<nbits)-1;
1119      if (nbits > 7) {
1120        new -= one_bits(near_bits >> 8);
1121      }
1122      return (new - one_bits(near_bits & 0xff));
1123    }
1124  }
1125}
1126
1127
1128LispObj
1129locative_forwarding_address(LispObj obj)
1130{
1131  int tag_n = fulltag_of(obj);
1132  natural dnode;
1133
1134
1135
1136  /* Locatives can be tagged as conses, "fulltag_misc"
1137     objects, or as fixnums.  Immediates, headers, and nil
1138     shouldn't be "forwarded".  Nil never will be, but it
1139     doesn't hurt to check ... */
1140  if ((1<<tag_n) & ((1<<fulltag_immheader) |
1141                    (1<<fulltag_nodeheader) |
1142                    (1<<fulltag_imm) |
1143                    (1<<fulltag_nil))) {
1144    return obj;
1145  }
1146
1147  dnode = gc_dynamic_area_dnode(obj);
1148
1149  if ((dnode >= GCndynamic_dnodes_in_area) ||
1150      (obj < GCfirstunmarked)) {
1151    return obj;
1152  }
1153
1154  return dnode_forwarding_address(dnode, tag_n);
1155}
1156
1157
1158
1159
1160void
1161forward_range(LispObj *range_start, LispObj *range_end)
1162{
1163  LispObj *p = range_start, node, new;
1164  int tag_n;
1165  natural nwords;
1166  hash_table_vector_header *hashp;
1167
1168  while (p < range_end) {
1169    node = *p;
1170    tag_n = fulltag_of(node);
1171    if (immheader_tag_p(tag_n)) {
1172      p = (LispObj *) skip_over_ivector((natural) p, node);
1173    } else if (nodeheader_tag_p(tag_n)) {
1174      nwords = header_element_count(node);
1175      nwords += (1 - (nwords&1));
1176      if ((header_subtag(node) == subtag_hash_vector) &&
1177          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1178        natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1179        hashp = (hash_table_vector_header *) p;
1180        p++;
1181        nwords -= skip;
1182        while(skip--) {
1183          update_noderef(p);
1184          p++;
1185        }
1186        /* "nwords" is odd at this point: there are (floor nwords 2)
1187           key/value pairs to look at, and then an extra word for
1188           alignment.  Process them two at a time, then bump "p"
1189           past the alignment word. */
1190        nwords >>= 1;
1191        while(nwords--) {
1192          if (update_noderef(p) && hashp) {
1193            hashp->flags |= nhash_key_moved_mask;
1194            hashp = NULL;
1195          }
1196          p++;
1197          update_noderef(p);
1198          p++;
1199        }
1200        *p++ = 0;
1201      } else {
1202        p++;
1203        if (header_subtag(node) == subtag_function) {
1204          update_locref(p);
1205          p++;
1206          nwords--;
1207        }
1208        while(nwords--) {
1209          update_noderef(p);
1210          p++;
1211        }
1212      }
1213    } else {
1214      new = node_forwarding_address(node);
1215      if (new != node) {
1216        *p = new;
1217      }
1218      p++;
1219      update_noderef(p);
1220      p++;
1221    }
1222  }
1223}
1224
1225
1226void
1227forward_tstack_area(area *a)
1228{
1229}
1230
1231
1232/* Forward a vstack area */
1233void
1234forward_vstack_area(area *a)
1235{
1236  LispObj
1237    *p = (LispObj *) a->active,
1238    *q = (LispObj *) a->high;
1239
1240#ifdef DEBUG
1241  fprintf(dbgout,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner);
1242#endif
1243  if (((natural)p) & sizeof(natural)) {
1244    update_noderef(p);
1245    p++;
1246  }
1247  forward_range(p, q);
1248}
1249
1250void
1251forward_cstack_area(area *a)
1252{
1253  LispObj *current = (LispObj *)(a->active)
1254    , *limit = (LispObj*)(a->high), header;
1255  lisp_frame *frame;
1256
1257  while (current < limit) {
1258    header = *current;
1259
1260    if (header == lisp_frame_marker) {
1261      frame = (lisp_frame *)current;
1262
1263      update_noderef(&(frame->savefn));
1264      update_locref(&(frame->savelr));
1265      current += sizeof(lisp_frame)/sizeof(LispObj);
1266    } else if ((header == stack_alloc_marker) || (header == 0)) {
1267      current += 2;
1268    } else if (nodeheader_tag_p(fulltag_of(header))) {
1269      natural elements = header_element_count(header);
1270
1271      current++;
1272      if (header_subtag(header) == subtag_function) {
1273        update_locref(current);
1274        current++;
1275        elements--;
1276      }
1277      while(elements--) {
1278        update_noderef(current);
1279        current++;
1280      }
1281      if (((natural)current) & sizeof(natural)) {
1282        current++;
1283      }
1284    } else if (immheader_tag_p(fulltag_of(header))) {
1285      current=(LispObj *)skip_over_ivector((natural)current,header);
1286    } else {
1287      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
1288    }
1289  }
1290}
1291
1292
1293
1294void
1295forward_xp(ExceptionInformation *xp)
1296{
1297  natural *regs = (natural *) xpGPRvector(xp);
1298
1299  int r;
1300
1301  /* registers between arg_z and Rfn should be tagged and forwarded as roots.
1302     the PC and LR should be treated as "locatives".
1303     */
1304
1305  for (r = arg_z; r <= Rfn;  r++) {
1306    update_noderef((LispObj*) (&(regs[r])));
1307  }
1308
1309
1310  update_locref((LispObj*) (&(xpPC(xp))));
1311  update_locref((LispObj*) (&(xpLR(xp))));
1312
1313}
1314
1315
1316void
1317forward_tcr_xframes(TCR *tcr)
1318{
1319  xframe_list *xframes;
1320  ExceptionInformation *xp;
1321
1322  xp = tcr->gc_context;
1323  if (xp) {
1324    forward_xp(xp);
1325  }
1326  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1327    if (xframes->curr == xp) {
1328      Bug(NULL, "forward xframe twice ???");
1329    }
1330    forward_xp(xframes->curr);
1331  }
1332}
1333
1334
1335
1336/*
1337  Compact the dynamic heap (from GCfirstunmarked through its end.)
1338  Return the doublenode address of the new freeptr.
1339  */
1340
1341LispObj
1342compact_dynamic_heap()
1343{
1344  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new;
1345  natural
1346    elements, 
1347    dnode = gc_area_dnode(GCfirstunmarked), 
1348    node_dnodes = 0, 
1349    imm_dnodes = 0, 
1350    bitidx, 
1351    *bitsp, 
1352    bits, 
1353    nextbit, 
1354    diff;
1355  int tag;
1356  bitvector markbits = GCmarkbits;
1357    /* keep track of whether or not we saw any
1358       code_vector headers, and only flush cache if so. */
1359  Boolean GCrelocated_code_vector = false;
1360
1361  if (dnode < GCndnodes_in_area) {
1362    lisp_global(FWDNUM) += (1<<fixnum_shift);
1363 
1364    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1365    while (dnode < GCndnodes_in_area) {
1366      if (bits == 0) {
1367        int remain = nbits_in_word - bitidx;
1368        dnode += remain;
1369        src += (remain+remain);
1370        bits = *++bitsp;
1371        bitidx = 0;
1372      } else {
1373        /* Have a non-zero markbits word; all bits more significant
1374           than "bitidx" are 0.  Count leading zeros in "bits"
1375           (there'll be at least "bitidx" of them.)  If there are more
1376           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1377           "src" by the difference. */
1378        nextbit = count_leading_zeros(bits);
1379        if ((diff = (nextbit - bitidx)) != 0) {
1380          dnode += diff;
1381          bitidx = nextbit;
1382          src += (diff+diff);
1383        }
1384
1385        if (GCDebug) {
1386          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1387            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
1388                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1389          }
1390        }
1391
1392        node = *src++;
1393        tag = fulltag_of(node);
1394        if (nodeheader_tag_p(tag)) {
1395          elements = header_element_count(node);
1396          node_dnodes = (elements+2)>>1;
1397          dnode += node_dnodes;
1398          if ((header_subtag(node) == subtag_hash_vector) &&
1399              (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1400            hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1401            int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1402         
1403            *dest++ = node;
1404            elements -= skip;
1405            while(skip--) {
1406              *dest++ = node_forwarding_address(*src++);
1407            }
1408            /* There should be an even number of (key/value) pairs in elements;
1409               an extra alignment word follows. */
1410            elements >>= 1;
1411            while (elements--) {
1412              if (hashp) {
1413                node = *src++;
1414                new = node_forwarding_address(node);
1415                if (new != node) {
1416                  hashp->flags |= nhash_key_moved_mask;
1417                  hashp = NULL;
1418                  *dest++ = new;
1419                } else {
1420                  *dest++ = node;
1421                }
1422              } else {
1423                *dest++ = node_forwarding_address(*src++);
1424              }
1425              *dest++ = node_forwarding_address(*src++);
1426            }
1427            *dest++ = 0;
1428            src++;
1429          } else {
1430            *dest++ = node;
1431            if (header_subtag(node) == subtag_function) {
1432              *dest++ = locative_forwarding_address(*src++);
1433            } else {
1434              *dest++ = node_forwarding_address(*src++);
1435            }
1436            while(--node_dnodes) {
1437              *dest++ = node_forwarding_address(*src++);
1438              *dest++ = node_forwarding_address(*src++);
1439            }
1440          }
1441          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1442        } else if (immheader_tag_p(tag)) {
1443          *dest++ = node;
1444          *dest++ = *src++;
1445          elements = header_element_count(node);
1446          tag = header_subtag(node);
1447
1448          if (tag <= max_32_bit_ivector_subtag) {
1449            if (tag == subtag_code_vector) {
1450              GCrelocated_code_vector = true;
1451            }
1452            imm_dnodes = (((elements+1)+1)>>1);
1453          } else if (tag <= max_8_bit_ivector_subtag) {
1454            imm_dnodes = (((elements+4)+7)>>3);
1455          } else if (tag <= max_16_bit_ivector_subtag) {
1456            imm_dnodes = (((elements+2)+3)>>2);
1457          } else if (tag == subtag_bit_vector) {
1458            imm_dnodes = (((elements+32)+63)>>6);
1459          } else {
1460            imm_dnodes = elements+1;
1461          }
1462          dnode += imm_dnodes;
1463          while (--imm_dnodes) {
1464            *dest++ = *src++;
1465            *dest++ = *src++;
1466          }
1467          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1468        } else {
1469          *dest++ = node_forwarding_address(node);
1470          *dest++ = node_forwarding_address(*src++);
1471          bits &= ~(BIT0_MASK >> bitidx);
1472          dnode++;
1473          bitidx++;
1474        }
1475      }
1476 
1477    }
1478
1479    {
1480      natural nbytes = (natural)ptr_to_lispobj(dest) - (natural)GCfirstunmarked;
1481      if ((nbytes != 0) && GCrelocated_code_vector) {
1482        xMakeDataExecutable((LogicalAddress)ptr_from_lispobj(GCfirstunmarked), nbytes);
1483      }
1484    }
1485  }
1486  return ptr_to_lispobj(dest);
1487}
1488
1489
1490 
1491
1492     
1493   
1494/*
1495  Total the (physical) byte sizes of all ivectors in the indicated memory range
1496*/
1497
1498natural
1499unboxed_bytes_in_range(LispObj *start, LispObj *end)
1500{
1501    natural total=0, elements, tag, subtag, bytes;
1502    LispObj header;
1503
1504    while (start < end) {
1505      header = *start;
1506      tag = fulltag_of(header);
1507   
1508      if ((nodeheader_tag_p(tag)) ||
1509          (immheader_tag_p(tag))) {
1510        elements = header_element_count(header);
1511        if (nodeheader_tag_p(tag)) {
1512          start += ((elements+2) & ~1);
1513        } else {
1514          subtag = header_subtag(header);
1515
1516          if (subtag <= max_32_bit_ivector_subtag) {
1517            bytes = 4 + (elements<<2);
1518          } else if (subtag <= max_8_bit_ivector_subtag) {
1519            bytes = 4 + elements;
1520          } else if (subtag <= max_16_bit_ivector_subtag) {
1521            bytes = 4 + (elements<<1);
1522          } else if (subtag == subtag_double_float_vector) {
1523            bytes = 8 + (elements<<3);
1524          } else {
1525            bytes = 4 + ((elements+7)>>3);
1526          }
1527
1528
1529          bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
1530          total += bytes;
1531          start += (bytes >> node_shift);
1532        }
1533      } else {
1534        start += 2;
1535      }
1536    }
1537    return total;
1538  }
1539
1540
1541  /*
1542     This assumes that it's getting called with an ivector
1543     argument and that there's room for the object in the
1544     destination area.
1545  */
1546
1547
1548LispObj
1549purify_displaced_object(LispObj obj, area *dest, natural disp)
1550{
1551  BytePtr
1552    free = dest->active,
1553    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
1554  LispObj
1555    header = header_of(obj), 
1556    new;
1557  natural
1558    start = (natural)old,
1559    physbytes;
1560
1561  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
1562  dest->active += physbytes;
1563
1564  new = ptr_to_lispobj(free)+disp;
1565
1566  memcpy(free, (BytePtr)old, physbytes);
1567  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
1568  /* Actually, it's best to always leave a trail, for two reasons.
1569     a) We may be walking the same heap that we're leaving forwaring
1570     pointers in, so we don't want garbage that we leave behind to
1571     look like a header.
1572     b) We'd like to be able to forward code-vector locatives, and
1573     it's easiest to do so if we leave a {forward_marker, dnode_locative}
1574     pair at every doubleword in the old vector.
1575  */
1576  while(physbytes) {
1577    *old++ = (BytePtr) forward_marker;
1578    *old++ = (BytePtr) free;
1579    free += dnode_size;
1580    physbytes -= dnode_size;
1581  }
1582  return new;
1583}
1584
1585LispObj
1586purify_object(LispObj obj, area *dest)
1587{
1588  return purify_displaced_object(obj, dest, fulltag_of(obj));
1589}
1590
1591
1592
1593void
1594copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
1595{
1596  LispObj obj = *ref, header;
1597  natural tag = fulltag_of(obj), header_tag;
1598
1599  if ((tag == fulltag_misc) &&
1600      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
1601      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
1602    header = deref(obj, 0);
1603    if (header == forward_marker) { /* already copied */
1604      *ref = (untag(deref(obj,1)) + tag);
1605    } else {
1606      header_tag = fulltag_of(header);
1607      if (immheader_tag_p(header_tag)) {
1608        if (header_subtag(header) != subtag_macptr) {
1609          *ref = purify_object(obj, dest);
1610        }
1611      }
1612    }
1613  }
1614}
1615
1616void
1617purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to)
1618{
1619  LispObj
1620    loc = *locaddr,
1621    *headerP;
1622  natural
1623    tag = fulltag_of(loc);
1624
1625  if (((BytePtr)ptr_from_lispobj(loc) > low) &&
1626      ((BytePtr)ptr_from_lispobj(loc) < high)) {
1627
1628    headerP = (LispObj *)ptr_from_lispobj(untag(loc));
1629    switch (tag) {
1630    case fulltag_even_fixnum:
1631    case fulltag_odd_fixnum:
1632      if (*headerP != forward_marker) {
1633        LispObj code_vector = code_vector_from_pc(headerP);
1634       
1635        copy_ivector_reference(&code_vector, low, high, to);
1636      }
1637      *locaddr = (headerP[1]+tag);
1638      break;
1639    }
1640  }
1641}
1642
1643void
1644purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
1645{
1646  LispObj header;
1647  unsigned tag;
1648
1649  while (start < end) {
1650    header = *start;
1651    if (header == forward_marker) {
1652      start += 2;
1653    } else {
1654      tag = fulltag_of(header);
1655      if (immheader_tag_p(tag)) {
1656        start = (LispObj *)skip_over_ivector((natural)start, header);
1657      } else {
1658        if (!nodeheader_tag_p(tag)) {
1659          copy_ivector_reference(start, low, high, to);
1660        }
1661        start++;
1662        if (header_subtag(header) == subtag_function) {
1663          LispObj entrypt = *start;
1664          if ((entrypt > (LispObj)low) && 
1665              (entrypt < (LispObj)high) &&
1666              (fulltag_of(entrypt) == fulltag_odd_fixnum)) {
1667            *start = untag(entrypt) + fulltag_misc;
1668            copy_ivector_reference(start, low, high, to);
1669            *start = untag(*start)+fulltag_odd_fixnum;
1670          } else {
1671            copy_ivector_reference(start, low, high, to);
1672          }
1673        } else {
1674          copy_ivector_reference(start, low, high, to);
1675        }
1676        start++;
1677      }
1678    }
1679  }
1680}
1681       
1682
1683/* Purify a vstack area */
1684void
1685purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
1686{
1687  LispObj
1688    *p = (LispObj *) a->active,
1689    *q = (LispObj *) a->high;
1690
1691  if (((natural)p) & sizeof(natural)) {
1692    copy_ivector_reference(p, low, high, to);
1693    p++;
1694  }
1695  purify_range(p, q, low, high, to);
1696}
1697
1698
1699void
1700purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to)
1701{
1702  LispObj *current = (LispObj *)(a->active)
1703    , *limit = (LispObj*)(a->high), header;
1704  lisp_frame *frame;
1705
1706
1707  while(current < limit) {
1708    header = *current;
1709
1710    if (header == lisp_frame_marker) {
1711      frame = (lisp_frame *)current;
1712     
1713      copy_ivector_reference(&(frame->savevsp), low, high, to); /* likely a fixnum */
1714      copy_ivector_reference(&(frame->savefn), low, high, to);
1715      purify_locref(&(frame->savelr), low, high, to);
1716      current += sizeof(lisp_frame)/sizeof(LispObj);
1717    } else if ((header == stack_alloc_marker) || (header == 0)) {
1718      current += 2;
1719    } else if (nodeheader_tag_p(fulltag_of(header))) {
1720      natural elements = header_element_count(header);
1721
1722      current++;
1723      if (header_subtag(header) == subtag_function) {
1724        purify_locref(current, low, high, to);
1725        current++;
1726        elements--;
1727      }
1728      while(elements--) {
1729        copy_ivector_reference(current, low, high, to);
1730        current++;
1731      }
1732      if (((natural)current) & sizeof(natural)) {
1733        current++;
1734      }
1735    } else if (immheader_tag_p(fulltag_of(header))) {
1736      current=(LispObj *)skip_over_ivector((natural)current,header);
1737    } else {
1738      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
1739    }
1740  }
1741}
1742
1743void
1744purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
1745{
1746  unsigned long *regs = (unsigned long *) xpGPRvector(xp);
1747
1748  int r;
1749
1750  /* Node registers should be treated as roots.
1751     The PC and LR should be treated as "locatives".
1752   */
1753
1754  for (r = arg_z; r <= Rfn; r++) {
1755    copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to);
1756  };
1757
1758  purify_locref((LispObj*) (&(xpPC(xp))), low, high, to);
1759  purify_locref((LispObj*) (&(xpLR(xp))), low, high, to);
1760}
1761
1762void
1763purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
1764{
1765  natural n = tcr->tlb_limit;
1766  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
1767
1768  purify_range(start, end, low, high, to);
1769}
1770
1771void
1772purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
1773{
1774  xframe_list *xframes;
1775  ExceptionInformation *xp;
1776 
1777  xp = tcr->gc_context;
1778  if (xp) {
1779    purify_xp(xp, low, high, to);
1780  }
1781
1782  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1783    purify_xp(xframes->curr, low, high, to);
1784  }
1785}
1786
1787void
1788purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
1789{
1790  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
1791
1792  while ((*prev) != (LispObj)NULL) {
1793    copy_ivector_reference(prev, low, high, to);
1794    next = *prev;
1795    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1796  }
1797}
1798
1799
1800void
1801purify_areas(BytePtr low, BytePtr high, area *target)
1802{
1803  area *next_area;
1804  area_code code;
1805     
1806  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1807    switch (code) {
1808    case AREA_VSTACK:
1809      purify_vstack_area(next_area, low, high, target);
1810      break;
1811     
1812    case AREA_CSTACK:
1813      purify_cstack_area(next_area, low, high, target);
1814      break;
1815     
1816    case AREA_STATIC:
1817    case AREA_DYNAMIC:
1818      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
1819      break;
1820     
1821    default:
1822      break;
1823    }
1824  }
1825}
1826
1827/*
1828  So far, this is mostly for save_application's benefit.
1829  We -should- be able to return to lisp code after doing this,
1830  however.
1831
1832*/
1833
1834
1835signed_natural
1836purify(TCR *tcr, signed_natural param)
1837{
1838  extern area *extend_readonly_area(unsigned);
1839  area
1840    *a = active_dynamic_area,
1841    *new_pure_area;
1842
1843  TCR  *other_tcr;
1844  natural max_pure_size;
1845  BytePtr new_pure_start;
1846
1847
1848  max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
1849                                         (LispObj *) a->active);
1850  new_pure_area = extend_readonly_area(max_pure_size);
1851  if (new_pure_area) {
1852    new_pure_start = new_pure_area->active;
1853    lisp_global(IN_GC) = (1<<fixnumshift);
1854
1855   
1856    purify_areas(a->low, a->active, new_pure_area);
1857   
1858    other_tcr = tcr;
1859    do {
1860      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area);
1861      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area);
1862      other_tcr = other_tcr->next;
1863    } while (other_tcr != tcr);
1864
1865    purify_gcable_ptrs(a->low, a->active, new_pure_area);
1866
1867    {
1868      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
1869      if (puresize != 0) {
1870        xMakeDataExecutable(new_pure_start, puresize);
1871 
1872      }
1873    }
1874    ProtectMemory(new_pure_area->low,
1875                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
1876                                      log2_page_size));
1877    lisp_global(IN_GC) = 0;
1878    just_purified_p = true;
1879    return 0;
1880  }
1881  return -1;
1882}
1883
1884void
1885impurify_locref(LispObj *p, LispObj low, LispObj high, int delta)
1886{
1887  LispObj q = *p;
1888 
1889  switch (fulltag_of(q)) {
1890  case fulltag_misc:
1891  case fulltag_even_fixnum:
1892  case fulltag_odd_fixnum:
1893    if ((q >= low) && (q < high)) {
1894      *p = (q+delta);
1895    }
1896  }
1897}
1898
1899 
1900void
1901impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
1902{
1903  LispObj q = *p;
1904 
1905  if ((fulltag_of(q) == fulltag_misc) &&
1906      (q >= low) && 
1907      (q < high)) {
1908    *p = (q+delta);
1909  }
1910}
1911 
1912
1913void
1914impurify_cstack_area(area *a, LispObj low, LispObj high, int delta)
1915{
1916  LispObj *current = (LispObj *)(a->active)
1917    , *limit = (LispObj*)(a->high), header;
1918  lisp_frame *frame;
1919  while(current < limit) {
1920    header = *current;
1921
1922    if (header == lisp_frame_marker) {
1923      frame = (lisp_frame *)current;
1924     
1925      impurify_noderef(&(frame->savevsp), low, high,delta); /* likely a fixnum */
1926      impurify_noderef(&(frame->savefn), low, high, delta);
1927      impurify_locref(&(frame->savelr), low, high, delta);
1928      current += sizeof(lisp_frame)/sizeof(LispObj);
1929    } else if ((header == stack_alloc_marker) || (header == 0)) {
1930      current += 2;
1931    } else if (nodeheader_tag_p(fulltag_of(header))) {
1932      natural elements = header_element_count(header);
1933
1934      current++;
1935      if (header_subtag(header) == subtag_function) {
1936        impurify_locref(current, low, high, delta);
1937        current++;
1938        elements--;
1939      }
1940      while(elements--) {
1941        impurify_noderef(current, low, high, delta);
1942        current++;
1943      }
1944      if (((natural)current) & sizeof(natural)) {
1945        current++;
1946      }
1947    } else if (immheader_tag_p(fulltag_of(header))) {
1948      current=(LispObj *)skip_over_ivector((natural)current,header);
1949    } else {
1950      Bug(NULL, "Unknown stack word at 0x" LISP ":\n", current);
1951    }
1952  }
1953}
1954
1955
1956void
1957impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
1958{
1959  natural *regs = (natural *) xpGPRvector(xp);
1960  int r;
1961
1962  /* node registers should be treated as roots.
1963     The PC and LR should be treated as "locatives".
1964   */
1965
1966  for (r = arg_z; r <= Rfn; r++) {
1967    impurify_noderef((LispObj*) (&(regs[r])), low, high, delta);
1968  };
1969
1970
1971  impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta);
1972  impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta);
1973
1974}
1975
1976
1977void
1978impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
1979{
1980  LispObj header;
1981  unsigned tag;
1982
1983  while (start < end) {
1984    header = *start;
1985    tag = fulltag_of(header);
1986    if (immheader_tag_p(tag)) {
1987      start = (LispObj *)skip_over_ivector((natural)start, header);
1988    } else {
1989      if (!nodeheader_tag_p(tag)) {
1990        impurify_noderef(start, low, high, delta);
1991      }
1992      start++;
1993      if (header_subtag(header) == subtag_function) {
1994        LispObj entrypt = *start;
1995        if ((entrypt > (LispObj)low) && 
1996            (entrypt < (LispObj)high) &&
1997            (fulltag_of(entrypt) == fulltag_odd_fixnum)) {
1998          *start = untag(entrypt) + fulltag_misc;
1999          impurify_noderef(start, low, high, delta);
2000          *start = untag(*start)+fulltag_odd_fixnum;
2001        } else {
2002          impurify_noderef(start, low, high, delta);
2003        }
2004        start++;
2005      }
2006    }
2007  }
2008}
2009
2010
2011
2012
2013void
2014impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
2015{
2016  unsigned n = tcr->tlb_limit;
2017  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2018 
2019  impurify_range(start, end, low, high, delta);
2020}
2021
2022void
2023impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
2024{
2025  xframe_list *xframes;
2026  ExceptionInformation *xp;
2027 
2028  xp = tcr->gc_context;
2029  if (xp) {
2030    impurify_xp(xp, low, high, delta);
2031  }
2032
2033  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2034    impurify_xp(xframes->curr, low, high, delta);
2035  }
2036}
2037
2038void
2039impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
2040{
2041  LispObj
2042    *p = (LispObj *) a->active,
2043    *q = (LispObj *) a->high;
2044
2045  if (((natural)p) & sizeof(natural)) {
2046    impurify_noderef(p, low, high, delta);
2047    p++;
2048  }
2049  impurify_range(p, q, low, high, delta);
2050}
2051
2052
2053void
2054impurify_areas(LispObj low, LispObj high, int delta)
2055{
2056  area *next_area;
2057  area_code code;
2058     
2059  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2060    switch (code) {
2061     
2062    case AREA_VSTACK:
2063      impurify_vstack_area(next_area, low, high, delta);
2064      break;
2065     
2066    case AREA_CSTACK:
2067      impurify_cstack_area(next_area, low, high, delta);
2068      break;
2069     
2070    case AREA_STATIC:
2071    case AREA_DYNAMIC:
2072      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2073      break;
2074     
2075    default:
2076      break;
2077    }
2078  }
2079}
2080
2081void
2082impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2083{
2084  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2085
2086  while ((*prev) != (LispObj)NULL) {
2087    impurify_noderef(prev, low, high, delta);
2088    next = *prev;
2089    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2090  }
2091}
2092
2093signed_natural
2094impurify(TCR *tcr, signed_natural param)
2095{
2096  area *r = readonly_area;
2097
2098  if (r) {
2099    area *a = active_dynamic_area;
2100    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2101      oldhigh = a->high, newhigh; 
2102    natural n = ro_limit - ro_base;
2103    signed_natural delta = oldfree-ro_base;
2104    TCR *other_tcr;
2105
2106    if (n) {
2107      lisp_global(IN_GC) = 1;
2108      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2109                                               log2_heap_segment_size));
2110      if (newhigh > oldhigh) {
2111        grow_dynamic_area(newhigh-oldhigh);
2112      }
2113      a->active += n;
2114      memmove(oldfree, ro_base, n);
2115      UnCommitMemory(ro_base, n);
2116      a->ndnodes = area_dnode(a, a->active);
2117      pure_space_active = r->active = r->low;
2118      r->ndnodes = 0;
2119
2120      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2121
2122      other_tcr = tcr;
2123      do {
2124        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2125        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2126        other_tcr = other_tcr->next;
2127      } while (other_tcr != tcr);
2128
2129      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2130      lisp_global(IN_GC) = 0;
2131    }
2132    return 0;
2133  }
2134  return -1;
2135}
2136
Note: See TracBrowser for help on using the repository browser.