source: branches/arm/lisp-kernel/arm-gc.c @ 13925

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

arm-asmutils.s: don't use magic Linux kernel function for store_condtional,
just use ldrex/strex.
arm-constants.s: byte order in definitions of bytes_consed_[high,low] slots
in TCR.
arm-exceptions.s: in normalize_tcr(), if other_tcr is in ff-call, need to
update the cs_area based on tcr->last_lisp_frame.
arm-gc.c: check for running off end of cstack in mark_cstack_area().

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