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

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

arm-asm.lisp, arm-lap.lisp: drain-constant-pool. At least slightly
better than nothing. Check to make sure that :mem12 pc-relative label
references are within 12 bits of their target.

arm-backend: uncomment code to require arm-vinsns

arm-disassemble: hook up to DISASSEMBLE.

arm-vinsns: in REQUIRE-U32, get subtag from the right place.

arm2.lisp: assume that .SPprogvsave sets up an unwind-protect.

arm-bignum.lisp: %ADD-THE-CARRRY is indeed silly.

arm-misc.lisp: unscramble %UNLOCK-GC-LOCK, don't clobber address
in %PTR-STORE-FIXNUM-CONDITIONAL.

arm-utils.lisp: GC.

l1-boot-1.lisp: add ARM to PLATFORM-CPU-NAMES.

l1-boot-2.lisp: require disassembler, lapmacros files on ARM.

l1-boot-3.lisp: comment out error-callback activation on ARM.

l1-init.lisp: set *SAVE-SOURCE-LOCATIONS* to NIL on ARM for now. (More code
to step through/debug, and not short of that.)

version.lisp: don't say "arm-cross" if #+arm-target.

arm-gc.c: get a lot of this working, seemingly.

arm-macros.s: fix skip_stack_vector.

arm-spentry.s: get PROGV support working.

gc-common.c: check static-cons freelist only if GCDebug.

linuxarm/Makefile: enable GC integrity checks.

lisp-debug.c: start to support 'describe exception" for ARM.

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