source: release/1.7/source/lisp-kernel/arm-gc.c @ 15267

Last change on this file since 15267 was 14770, checked in by gb, 8 years ago

Change a comment, to clarify that the LR can point to the "pad" (alignment)
word before the contents of a double-float vector, too.

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