source: release/1.9/source/lisp-kernel/ppc-gc.c @ 16083

Last change on this file since 16083 was 15504, checked in by gz, 7 years ago

Fix lock-free hash table handling of the partially-inserted state, and took out gc handling of the partially-deleted state. Bumped image version because kernel and runtime changes need to match. This fixes ticket #993, hopefully without breaking much of anything else.

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