source: branches/working-0711/ccl/lisp-kernel/x86-gc.c @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 70.4 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp_globals.h"
19#include "bits.h"
20#include "gc.h"
21#include "area.h"
22#include "Threads.h"
23#include <stddef.h>
24#include <stdlib.h>
25#include <string.h>
26#include <sys/time.h>
27
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  if (n == (n & 0xff)) {
39    return;
40  }
41
42  switch (tag) {
43  case fulltag_even_fixnum:
44  case fulltag_odd_fixnum:
45#ifdef X8632
46  case fulltag_imm:
47#endif
48#ifdef X8664
49  case fulltag_imm_0:
50  case fulltag_imm_1:
51#endif
52    return;
53
54#ifdef X8664
55  case fulltag_nil:
56    if (n != lisp_nil) {
57      Bug(NULL,"Object tagged as nil, not nil : " LISP, n);
58    }
59    return;
60#endif
61
62#ifdef X8632
63  case fulltag_nodeheader:
64  case fulltag_immheader:
65#endif
66#ifdef X8664
67  case fulltag_nodeheader_0: 
68  case fulltag_nodeheader_1: 
69  case fulltag_immheader_0: 
70  case fulltag_immheader_1: 
71  case fulltag_immheader_2: 
72#endif
73    Bug(NULL, "Header not expected : 0x" LISP, n);
74    return;
75
76#ifdef X8632
77  case fulltag_tra:
78#endif
79#ifdef X8664
80  case fulltag_tra_0:
81  case fulltag_tra_1:
82#endif
83    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
84    if (a == NULL) {
85      a = active_dynamic_area;
86      if ((n > (ptr_to_lispobj(a->active))) &&
87          (n < (ptr_to_lispobj(a->high)))) {
88        Bug(NULL, "TRA points to heap free space: 0x" LISP, n);
89      }
90      return;
91    }
92    /* tra points into the heap.  Check displacement, then
93       check the function it (should) identify.
94    */
95#ifdef X8632
96    {
97      LispObj fun = 0;
98
99      if (*(unsigned char *)n == RECOVER_FN_OPCODE)
100        fun = *(LispObj *)(n + 1);
101      if (fun == 0 ||
102         (header_subtag(header_of(fun)) != subtag_function) ||
103         (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) {
104        Bug(NULL, "TRA at 0x" LISP " has bad function address 0x" LISP "\n", n, fun);
105      }
106      n = fun;
107    }
108#endif
109#ifdef X8664
110    {
111      int disp = 0;
112      LispObj m = n;
113
114      if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
115          (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
116        disp = (*(int *) (n+3));
117        n = RECOVER_FN_FROM_RIP_LENGTH+m+disp;
118      }
119      if ((disp == 0) ||
120          (fulltag_of(n) != fulltag_function) ||
121          (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) {
122        Bug(NULL, "TRA at 0x" LISP " has bad displacement %d\n", n, disp);
123      }
124    }
125#endif
126    /* Otherwise, fall through and check the header on the function
127       that the tra references */
128
129  case fulltag_misc:
130  case fulltag_cons:
131#ifdef X8664
132  case fulltag_symbol:
133  case fulltag_function:
134#endif
135    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
136   
137    if (a == NULL) {
138      /* Can't do as much sanity checking as we'd like to
139         if object is a defunct stack-consed object.
140         If a dangling reference to the heap, that's
141         bad .. */
142      a = active_dynamic_area;
143      if ((n > (ptr_to_lispobj(a->active))) &&
144          (n < (ptr_to_lispobj(a->high)))) {
145        Bug(NULL, "Node points to heap free space: 0x" LISP, n);
146      }
147      return;
148    }
149    break;
150  }
151  /* Node points to heap area, so check header/lack thereof. */
152  header = header_of(n);
153  header_tag = fulltag_of(header);
154  if (tag == fulltag_cons) {
155    if ((nodeheader_tag_p(header_tag)) ||
156        (immheader_tag_p(header_tag))) {
157      Bug(NULL, "Cons cell at 0x" LISP " has bogus header : 0x" LISP, n, header);
158    }
159    return;
160  }
161
162  if ((!nodeheader_tag_p(header_tag)) &&
163      (!immheader_tag_p(header_tag))) {
164    Bug(NULL,"Vector at 0x" LISP " has bogus header : 0x" LISP, n, header);
165  }
166  return;
167}
168
169void
170check_all_mark_bits(LispObj *nodepointer) 
171{
172}
173
174
175
176
177
178void
179check_range(LispObj *start, LispObj *end, Boolean header_allowed)
180{
181  LispObj node, *current = start, *prev = NULL;
182  int tag;
183  natural elements;
184
185  while (current < end) {
186    prev = current;
187    node = *current++;
188    tag = fulltag_of(node);
189    if (immheader_tag_p(tag)) {
190      if (! header_allowed) {
191        Bug(NULL, "Header not expected at 0x" LISP "\n", prev);
192      }
193      current = (LispObj *)skip_over_ivector((natural)prev, node);
194    } else if (nodeheader_tag_p(tag)) {
195      if (! header_allowed) {
196        Bug(NULL, "Header not expected at 0x" LISP "\n", prev);
197      }
198      elements = header_element_count(node) | 1;
199      if (header_subtag(node) == subtag_function) {
200#ifdef X8632
201        int skip = *(unsigned short *)current;
202#else
203        int skip = *(int *)current;
204#endif
205        current += skip;
206        elements -= skip;
207      }
208      while (elements--) {
209        check_node(*current++);
210      }
211    } else {
212      check_node(node);
213      check_node(*current++);
214    }
215  }
216
217  if (current != end) {
218    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
219        start, end, prev, current);
220  }
221}
222
223void
224check_all_areas()
225{
226  area *a = active_dynamic_area;
227  area_code code = a->code;
228
229  while (code != AREA_VOID) {
230    switch (code) {
231    case AREA_DYNAMIC:
232    case AREA_STATIC:
233    case AREA_MANAGED_STATIC:
234      check_range((LispObj *)a->low, (LispObj *)a->active, true);
235      break;
236
237    case AREA_VSTACK:
238      {
239        LispObj* low = (LispObj *)a->active;
240        LispObj* high = (LispObj *)a->high;
241       
242        if (((natural)low) & node_size) {
243          check_node(*low++);
244        }
245        check_range(low, high, false);
246      }
247      break;
248
249    case AREA_TSTACK:
250      {
251        LispObj *current, *next,
252                *start = (LispObj *) a->active,
253                *end = start,
254                *limit = (LispObj *) a->high;
255                 
256        for (current = start;
257             end != limit;
258             current = next) {
259          next = ptr_from_lispobj(*current);
260          end = ((next >= start) && (next < limit)) ? next : limit;
261          check_range(current+2, end, true);
262        }
263      }
264      break;
265    }
266    a = a->succ;
267    code = (a->code);
268  }
269}
270
271
272
273
274
275
276
277/* Sooner or later, this probably wants to be in assembler */
278/* Return false if n is definitely not an ephemeral node, true if
279   it might be */
280void
281mark_root(LispObj n)
282{
283  int tag_n = fulltag_of(n);
284  natural dnode, bits, *bitsp, mask;
285
286  if (!is_node_fulltag(tag_n)) {
287    return;
288  }
289
290#ifdef X8632
291  if (tag_n == fulltag_tra) {
292    if (*(unsigned char *)n == RECOVER_FN_OPCODE) {
293      n = *(LispObj *)(n + 1);
294      tag_n = fulltag_misc;
295    } else
296      return;
297  }
298#endif
299#ifdef X8664
300  if (tag_of(n) == tag_tra) {
301    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
302        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
303      int sdisp = (*(int *) (n+3));
304      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
305      tag_n = fulltag_function;
306    }
307    else {
308      return;
309    }
310  }
311#endif
312
313
314  dnode = gc_area_dnode(n);
315  if (dnode >= GCndnodes_in_area) {
316    return;
317  }
318  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
319  if (bits & mask) {
320    return;
321  }
322  *bitsp = (bits | mask);
323
324  if (tag_n == fulltag_cons) {
325    cons *c = (cons *) ptr_from_lispobj(untag(n));
326
327    rmark(c->car);
328    rmark(c->cdr);
329    return;
330  }
331  {
332    LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
333    natural
334      header = *((natural *) base),
335      subtag = header_subtag(header),
336      element_count = header_element_count(header),
337      total_size_in_bytes,      /* including 4/8-byte header */
338      suffix_dnodes;
339    natural prefix_nodes = 0;
340
341    tag_n = fulltag_of(header);
342
343#ifdef X8664
344    if ((nodeheader_tag_p(tag_n)) ||
345        (tag_n == ivector_class_64_bit)) {
346      total_size_in_bytes = 8 + (element_count<<3);
347    } else if (tag_n == ivector_class_32_bit) {
348      total_size_in_bytes = 8 + (element_count<<2);
349    } else {
350      /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */
351      if (subtag == subtag_bit_vector) {
352        total_size_in_bytes = 8 + ((element_count+7)>>3);
353      } else if (subtag >= min_8_bit_ivector_subtag) {
354        total_size_in_bytes = 8 + element_count;
355      } else {
356        total_size_in_bytes = 8 + (element_count<<1);
357      }
358    }
359#endif
360#ifdef X8632
361    if ((tag_n == fulltag_nodeheader) ||
362        (subtag <= max_32_bit_ivector_subtag)) {
363      total_size_in_bytes = 4 + (element_count<<2);
364    } else if (subtag <= max_8_bit_ivector_subtag) {
365      total_size_in_bytes = 4 + element_count;
366    } else if (subtag <= max_16_bit_ivector_subtag) {
367      total_size_in_bytes = 4 + (element_count<<1);
368    } else if (subtag == subtag_double_float_vector) {
369      total_size_in_bytes = 8 + (element_count<<3);
370    } else {
371      total_size_in_bytes = 4 + ((element_count+7)>>3);
372    }
373#endif
374
375
376    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1;
377
378    if (suffix_dnodes) {
379      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
380    }
381
382    if (nodeheader_tag_p(tag_n)) {
383      if (subtag == subtag_hash_vector) {
384        /* Don't invalidate the cache here.  It should get
385           invalidated on the lisp side, if/when we know
386           that rehashing is necessary. */
387        LispObj flags = ((hash_table_vector_header *) base)->flags;
388
389        if ((flags & nhash_keys_frozen_mask) &&
390            (((hash_table_vector_header *) base)->deleted_count > 0)) {
391          /* We're responsible for clearing out any deleted keys, since
392             lisp side can't do it without breaking the state machine
393          */
394          LispObj *pairp = base + hash_table_vector_header_count;
395          natural
396            npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1;
397
398          while (npairs--) {
399            if ((pairp[1] == unbound) && (pairp[0] != unbound)) {
400              pairp[0] = slot_unbound;
401            }
402            pairp +=2;
403          }
404          ((hash_table_vector_header *) base)->deleted_count = 0;
405        }
406
407        if (flags & nhash_weak_mask) {
408          ((hash_table_vector_header *) base)->cache_key = undefined;
409          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
410          mark_weak_htabv(n);
411          return;
412        }
413      }
414
415      if (subtag == subtag_pool) {
416        deref(base, 1) = lisp_nil;
417      }
418     
419      if (subtag == subtag_weak) {
420        natural weak_type = (natural) base[2];
421        if (weak_type >> population_termination_bit) {
422          element_count -= 2;
423        } else {
424          element_count -= 1;
425        }
426      }
427
428      if (subtag == subtag_function) {
429#ifdef X8632
430        prefix_nodes = (natural) ((unsigned short) deref(base,1));
431#else
432        prefix_nodes = (natural) ((int) deref(base,1));
433#endif
434        if (prefix_nodes > element_count) {
435          Bug(NULL, "Function 0x" LISP " trashed",n);
436        }
437      }
438      base += (1+element_count);
439
440      element_count -= prefix_nodes;
441
442      while(element_count--) {
443        rmark(*--base);
444      }
445      if (subtag == subtag_weak) {
446        deref(ptr_to_lispobj(base),1) = GCweakvll;
447        GCweakvll = n;
448      }
449    }
450  }
451}
452
453
454/*
455  This marks the node if it needs to; it returns true if the node
456  is either a hash table vector header or a cons/misc-tagged pointer
457  to ephemeral space.
458  Note that it  might be a pointer to ephemeral space even if it's
459  not pointing to the current generation.
460*/
461
462Boolean
463mark_ephemeral_root(LispObj n)
464{
465  int tag_n = fulltag_of(n);
466  natural eph_dnode;
467
468  if (nodeheader_tag_p(tag_n)) {
469    return (header_subtag(n) == subtag_hash_vector);
470  }
471 
472  if (is_node_fulltag (tag_n)) {
473    eph_dnode = area_dnode(n, GCephemeral_low);
474    if (eph_dnode < GCn_ephemeral_dnodes) {
475      mark_root(n);             /* May or may not mark it */
476      return true;              /* but return true 'cause it's an ephemeral node */
477    }
478  }
479  return false;                 /* Not a heap pointer or not ephemeral */
480}
481 
482
483
484#ifdef X8664
485#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */
486#define RMARK_PREV_CAR fulltag_nil /* fulltag_cons + node_size. Coincidence ? I think not. */
487#else
488#define RMARK_PREV_ROOT fulltag_imm /* fulltag of 'undefined' value */
489#define RMARK_PREV_CAR fulltag_odd_fixnum
490#endif
491
492
493/*
494  This wants to be in assembler even more than "mark_root" does.
495  For now, it does link-inversion: hard as that is to express in C,
496  reliable stack-overflow detection may be even harder ...
497*/
498void
499rmark(LispObj n)
500{
501  int tag_n = fulltag_of(n);
502  bitvector markbits = GCmarkbits;
503  natural dnode, bits, *bitsp, mask;
504
505  if (!is_node_fulltag(tag_n)) {
506    return;
507  }
508
509#ifdef X8632
510  if (tag_n == fulltag_tra) {
511    if (*(unsigned char *)n == RECOVER_FN_OPCODE) {
512      n = *(LispObj *)(n + 1);
513      tag_n = fulltag_misc;
514    } else {
515      return;
516    }
517  }
518#endif
519#ifdef X8664
520  if (tag_of(n) == tag_tra) {
521    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
522        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
523      int sdisp = (*(int *) (n+3));
524      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
525      tag_n = fulltag_function;
526    } else {
527      return;
528    }
529  }
530#endif
531
532  dnode = gc_area_dnode(n);
533  if (dnode >= GCndnodes_in_area) {
534    return;
535  }
536  set_bits_vars(markbits,dnode,bitsp,bits,mask);
537  if (bits & mask) {
538    return;
539  }
540  *bitsp = (bits | mask);
541
542  if (current_stack_pointer() > GCstack_limit) {
543    if (tag_n == fulltag_cons) {
544      rmark(deref(n,1));
545      rmark(deref(n,0));
546    } else {
547      LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
548      natural
549        header = *((natural *) base),
550        subtag = header_subtag(header),
551        element_count = header_element_count(header),
552        total_size_in_bytes,
553        suffix_dnodes,
554        nmark;
555
556      tag_n = fulltag_of(header);
557
558#ifdef X8664
559      if ((nodeheader_tag_p(tag_n)) ||
560          (tag_n == ivector_class_64_bit)) {
561        total_size_in_bytes = 8 + (element_count<<3);
562      } else if (tag_n == ivector_class_32_bit) {
563        total_size_in_bytes = 8 + (element_count<<2);
564      } else {
565        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
566        if (subtag == subtag_bit_vector) {
567          total_size_in_bytes = 8 + ((element_count+7)>>3);
568        } else if (subtag >= min_8_bit_ivector_subtag) {
569          total_size_in_bytes = 8 + element_count;
570        } else {
571          total_size_in_bytes = 8 + (element_count<<1);
572        }
573      }
574#else
575      if ((tag_n == fulltag_nodeheader) ||
576          (subtag <= max_32_bit_ivector_subtag)) {
577        total_size_in_bytes = 4 + (element_count<<2);
578      } else if (subtag <= max_8_bit_ivector_subtag) {
579        total_size_in_bytes = 4 + element_count;
580      } else if (subtag <= max_16_bit_ivector_subtag) {
581        total_size_in_bytes = 4 + (element_count<<1);
582      } else if (subtag == subtag_double_float_vector) {
583        total_size_in_bytes = 8 + (element_count<<3);
584      } else {
585        total_size_in_bytes = 4 + ((element_count+7)>>3);
586      }
587#endif
588
589      suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
590
591      if (suffix_dnodes) {
592        set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
593      }
594
595      if (!nodeheader_tag_p(tag_n)) return;
596
597      if (subtag == subtag_hash_vector) {
598        /* Splice onto weakvll, then return */
599        /* In general, there's no reason to invalidate the cached
600           key/value pair here.  However, if the hash table's weak,
601           we don't want to retain an otherwise unreferenced key
602           or value simply because they're referenced from the
603           cache.  Clear the cached entries iff the hash table's
604           weak in some sense.
605        */
606        LispObj flags = ((hash_table_vector_header *) base)->flags;
607
608        if (flags & nhash_weak_mask) {
609          ((hash_table_vector_header *) base)->cache_key = undefined;
610          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
611          mark_weak_htabv(n);
612          return;
613        }
614      }
615
616      if (subtag == subtag_pool) {
617        deref(n, 1) = lisp_nil;
618      }
619
620      if (subtag == subtag_weak) {
621        natural weak_type = (natural) base[2];
622        if (weak_type >> population_termination_bit)
623          element_count -= 2;
624        else
625          element_count -= 1;
626      }
627
628      nmark = element_count;
629
630      if (subtag == subtag_function) {
631#ifdef X8664
632        int code_words = (int)base[1];
633#else
634        int code_words = (unsigned short)base[1];
635#endif
636        if (code_words >= nmark) {
637          Bug(NULL,"Bad function at 0x" LISP,n);
638        }
639        nmark -= code_words;
640      }
641
642      while (nmark--) {
643        rmark(deref(n,element_count));
644        element_count--;
645      }
646
647      if (subtag == subtag_weak) {
648        deref(n, 1) = GCweakvll;
649        GCweakvll = n;
650      }
651
652    }
653  } else {
654    /* This is all a bit more complicated than the PPC version:
655
656       - a symbol-vector can be referenced via either a FULLTAG-MISC
657       pointer or a FULLTAG-SYMBOL pointer.  When we've finished
658       marking the symbol-vector's elements, we need to know which tag
659       the object that pointed to the symbol-vector had originally.
660
661       - a function-vector can be referenced via either a FULLTAG-MISC
662       pointer or a FULLTAG-FUNCTION pointer.  That introduces pretty
663       much the same set of issues, but ...
664
665       - a function-vector can also be referenced via a TRA; the
666       offset from the TRA to the function header is arbitrary (though
667       we can probably put an upper bound on it, and it's certainly
668       not going to be more than 32 bits.)
669
670       - function-vectors contain a mixture of code and constants,
671       with a "boundary" word (that doesn't look like a valid
672       constant) in between them.  There are 56 unused bits in the
673       boundary word; the low 8 bits must be = to the constant
674       'function_boundary_marker'.  We can store the byte displacement
675       from the address of the object which references the function
676       (tagged fulltag_misc, fulltag_function, or tra) to the address
677       of the boundary marker when the function vector is first marked
678       and recover that offset when we've finished marking the
679       function vector.  (Note that the offset is signed; it's
680       probably simplest to keep it in the high 32 bits of the
681       boundary word.)
682
683 So:
684
685       - while marking a CONS, the 'this' pointer as a 3-bit tag of
686       tag_list; the 4-bit fulltag indicates which cell is being
687       marked.
688
689       - while marking a gvector (other than a symbol-vector or
690       function-vector), the 'this' pointer is tagged tag_misc.
691       (Obviously, it alternates between fulltag_misc and
692       fulltag_nodeheader_0, arbitrarily.)  When we encounter the
693       gvector header when the 'this' pointer has been tagged as
694       fulltag_misc, we can restore 'this' to the header's address +
695       fulltag_misc and enter the 'climb' state.  (Note that this
696       value happens to be exactly what's in 'this' when the header's
697       encountered.)
698
699       - if we encounter a symbol-vector via the FULLTAG-MISC pointer
700       to the symbol (not very likely, but legal and possible), it's
701       treated exactly like the gvector case above.
702
703       - in the more likely case where a symbol-vector is referenced
704       via a FULLTAG-SYMBOL, we do the same loop as in the general
705       gvector case, backing up through the vector with 'this' tagged
706       as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter
707       the symbol header, 'this' gets fulltag_symbol added to the
708       dnode-aligned address of the header, and we climb.
709
710       - if anything (fulltag_misc, fulltag_function, tra) references
711       an unmarked function function vector, we store the byte offfset
712       from the tagged reference to the address of the boundary word
713       in the high 32 bits of the boundary word, then we back up
714       through the function-vector's constants, with 'this' tagged
715       tag_function/ fulltag_immheader_0, until the (specially-tagged)
716       boundary word is encountered.  The displacement stored in the boundary
717       word is added to the aligned address of the  boundary word (restoring
718       the original 'this' pointer, and we climb.
719
720       Not that bad.
721    */
722       
723    LispObj prev = undefined, this = n, next, *base;
724    natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary;
725
726    if (tag_n == fulltag_cons) goto MarkCons;
727    goto MarkVector;
728
729  ClimbCdr:
730    prev = deref(this,0);
731    deref(this,0) = next;
732
733  Climb:
734    next = this;
735    this = prev;
736    tag_n = fulltag_of(prev);
737    switch(tag_n) {
738    case tag_misc:
739    case fulltag_misc:
740#ifdef X8664
741    case tag_symbol:
742    case fulltag_symbol:
743    case tag_function:
744    case fulltag_function:
745#endif
746      goto ClimbVector;
747
748    case RMARK_PREV_ROOT:
749      return;
750
751    case fulltag_cons:
752      goto ClimbCdr;
753
754    case RMARK_PREV_CAR:
755      goto ClimbCar;
756
757    default: abort();
758    }
759
760  DescendCons:
761    prev = this;
762    this = next;
763
764  MarkCons:
765    next = deref(this,1);
766#ifdef X8632
767    this += (RMARK_PREV_CAR-fulltag_cons);
768#else
769    this += node_size;
770#endif
771    tag_n = fulltag_of(next);
772    if (!is_node_fulltag(tag_n)) goto MarkCdr;
773    dnode = gc_area_dnode(next);
774    if (dnode >= GCndnodes_in_area) goto MarkCdr;
775    set_bits_vars(markbits,dnode,bitsp,bits,mask);
776    if (bits & mask) goto MarkCdr;
777    *bitsp = (bits | mask);
778    deref(this,1) = prev;
779    if (tag_n == fulltag_cons) goto DescendCons;
780    goto DescendVector;
781
782  ClimbCar:
783    prev = deref(this,1);
784    deref(this,1) = next;
785
786  MarkCdr:
787    next = deref(this, 0);
788#ifdef X8632
789    this -= (RMARK_PREV_CAR-fulltag_cons);
790#else
791    this -= node_size;
792#endif
793    tag_n = fulltag_of(next);
794    if (!is_node_fulltag(tag_n)) goto Climb;
795    dnode = gc_area_dnode(next);
796    if (dnode >= GCndnodes_in_area) goto Climb;
797    set_bits_vars(markbits,dnode,bitsp,bits,mask);
798    if (bits & mask) goto Climb;
799    *bitsp = (bits | mask);
800    deref(this, 0) = prev;
801    if (tag_n == fulltag_cons) goto DescendCons;
802    /* goto DescendVector; */
803
804  DescendVector:
805    prev = this;
806    this = next;
807
808  MarkVector:
809#ifdef X8664
810    if ((tag_n == fulltag_tra_0) ||
811        (tag_n == fulltag_tra_1)) {
812      int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH;
813
814      base = (LispObj *) (untag(n-disp));
815      header = *((natural *) base);
816      subtag = header_subtag(header);
817      boundary = base + (int)(base[1]);
818      (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
819      this = (LispObj)(base)+fulltag_function;
820      /* Need to set the initial markbit here */
821      dnode = gc_area_dnode(this);
822      set_bit(markbits,dnode);
823    } else {
824      base = (LispObj *) ptr_from_lispobj(untag(this));
825      header = *((natural *) base);
826      subtag = header_subtag(header);
827      if (subtag == subtag_function) {
828        boundary = base + (int)(base[1]);
829        (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
830      }
831    }
832    element_count = header_element_count(header);
833    tag_n = fulltag_of(header);
834
835    if ((nodeheader_tag_p(tag_n)) ||
836        (tag_n == ivector_class_64_bit)) {
837      total_size_in_bytes = 8 + (element_count<<3);
838    } else if (tag_n == ivector_class_32_bit) {
839      total_size_in_bytes = 8 + (element_count<<2);
840    } else {
841      /* ivector_class_other_bit contains 16-bit arrays & bitvector */
842      if (subtag == subtag_bit_vector) {
843        total_size_in_bytes = 8 + ((element_count+7)>>3);
844      } else if (subtag >= min_8_bit_ivector_subtag) {
845        total_size_in_bytes = 8 + element_count;
846      } else {
847        total_size_in_bytes = 8 + (element_count<<1);
848      }
849    }
850#else
851    if (tag_n == fulltag_tra) {
852      LispObj fn = *(LispObj *)(n + 1);
853
854      base = (LispObj *)untag(fn);
855      header = *(natural *)base;
856      subtag = header_subtag(header);
857      boundary = base + (unsigned short)base[1];
858      /*
859       * On x8632, the upper 24 bits of the boundary word are zero.
860       * Functions on x8632 can be no more than 2^16 words (or 2^24
861       * bytes) long (including the self-reference table but excluding
862       * any constants).  Therefore, we can do the same basic thing
863       * that the x8664 port does: namely, we keep the byte
864       * displacement from the address of the object (tagged tra or
865       * fulltag_misc) that references the function to the address of
866       * the boundary marker in those 24 bits, recovering it when
867       * we've finished marking the function vector.
868       */
869      *((int *)boundary) &= 0xff;
870      *((int *)boundary) |= ((this-(LispObj)boundary) << 8);
871      this = (LispObj)(base)+fulltag_misc;
872      dnode = gc_area_dnode(this);
873      set_bit(markbits,dnode);
874    } else {
875      base = (LispObj *) ptr_from_lispobj(untag(this));
876      header = *((natural *) base);
877      subtag = header_subtag(header);
878      if (subtag == subtag_function) {
879        boundary = base + (unsigned short)base[1];
880        *((int *)boundary) &= 0xff;
881        *((int *)boundary) |= ((this-((LispObj)boundary)) << 8);
882      }
883    }
884    element_count = header_element_count(header);
885    tag_n = fulltag_of(header);
886
887    if ((tag_n == fulltag_nodeheader) ||
888        (subtag <= max_32_bit_ivector_subtag)) {
889      total_size_in_bytes = 4 + (element_count<<2);
890    } else if (subtag <= max_8_bit_ivector_subtag) {
891      total_size_in_bytes = 4 + element_count;
892    } else if (subtag <= max_16_bit_ivector_subtag) {
893      total_size_in_bytes = 4 + (element_count<<1);
894    } else if (subtag == subtag_double_float_vector) {
895      total_size_in_bytes = 8 + (element_count<<3);
896    } else {
897      total_size_in_bytes = 4 + ((element_count+7)>>3);
898    }
899#endif
900
901    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
902   
903    if (suffix_dnodes) {
904      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
905    }
906   
907    if (!nodeheader_tag_p(tag_n)) goto Climb;
908   
909    if (subtag == subtag_hash_vector) {
910      /* Splice onto weakvll, then climb */
911      LispObj flags = ((hash_table_vector_header *) base)->flags;
912     
913      if (flags & nhash_weak_mask) {
914        ((hash_table_vector_header *) base)->cache_key = undefined;
915        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
916        dws_mark_weak_htabv(this);
917        element_count = hash_table_vector_header_count;
918      }
919    }
920
921    if (subtag == subtag_pool) {
922      deref(this, 1) = lisp_nil;
923    }
924
925    if (subtag == subtag_weak) {
926      natural weak_type = (natural) base[2];
927      if (weak_type >> population_termination_bit)
928        element_count -= 2;
929      else
930        element_count -= 1;
931    }
932
933    this = (LispObj)(base) + (tag_of(this))  + ((element_count+1) << node_shift);
934    goto MarkVectorLoop;
935
936  ClimbVector:
937    prev = indirect_node(this);
938    indirect_node(this) = next;
939
940  MarkVectorLoop:
941    this -= node_size;
942    next = indirect_node(this);
943#ifdef X8664
944    if ((tag_of(this) == tag_function) &&
945        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
946#else
947    if ((tag_of(this) == tag_misc) &&
948        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
949#endif
950
951    tag_n = fulltag_of(next);
952    if (nodeheader_tag_p(tag_n)) goto MarkVectorDone;
953    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
954    dnode = gc_area_dnode(next);
955    if (dnode >= GCndnodes_in_area) goto MarkVectorLoop;
956    set_bits_vars(markbits,dnode,bitsp,bits,mask);
957    if (bits & mask) goto MarkVectorLoop;
958    *bitsp = (bits | mask);
959    indirect_node(this) = prev;
960    if (tag_n == fulltag_cons) goto DescendCons;
961    goto DescendVector;
962
963  MarkVectorDone:
964    /* "next" is vector header; "this" tagged tag_misc or tag_symbol.
965       If  header subtag = subtag_weak_header, put it on weakvll */
966    this += node_size;          /* make it fulltag_misc/fulltag_symbol */
967
968    if (header_subtag(next) == subtag_weak) {
969      deref(this, 1) = GCweakvll;
970      GCweakvll = this;
971    }
972    goto Climb;
973
974  MarkFunctionDone:
975    boundary = (LispObj *)(node_aligned(this));
976#ifdef X8664
977    this = ((LispObj)boundary) + (((int *)boundary)[1]);
978    (((int *)boundary)[1]) = 0;
979#else
980    this = ((LispObj)boundary) + ((*((int *)boundary)) >> 8);
981    ((int *)boundary)[0] &= 0xff;
982#endif
983    goto Climb;
984  }
985}
986
987LispObj *
988skip_over_ivector(natural start, LispObj header)
989{
990  natural
991    element_count = header_element_count(header),
992    subtag = header_subtag(header),
993    nbytes;
994
995
996#ifdef X8664
997  switch (fulltag_of(header)) {
998  case ivector_class_64_bit:
999    nbytes = element_count << 3;
1000    break;
1001  case ivector_class_32_bit:
1002    nbytes = element_count << 2;
1003    break;
1004  case ivector_class_other_bit:
1005  default:
1006    if (subtag == subtag_bit_vector) {
1007      nbytes = (element_count+7)>>3;
1008    } else if (subtag >= min_8_bit_ivector_subtag) {
1009      nbytes = element_count;
1010    } else {
1011      nbytes = element_count << 1;
1012    }
1013  }
1014  return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15)));
1015#else
1016  if (subtag <= max_32_bit_ivector_subtag) {
1017    nbytes = element_count << 2;
1018  } else if (subtag <= max_8_bit_ivector_subtag) {
1019    nbytes = element_count;
1020  } else if (subtag <= max_16_bit_ivector_subtag) {
1021    nbytes = element_count << 1;
1022  } else if (subtag == subtag_double_float_vector) {
1023    nbytes = 4 + (element_count << 3);
1024  } else {
1025    nbytes = (element_count+7) >> 3;
1026  }
1027  return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7)));
1028#endif
1029}
1030
1031
1032void
1033check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
1034{
1035  LispObj x1, *base = start, *prev = start;
1036  int tag;
1037  natural ref_dnode, node_dnode;
1038  Boolean intergen_ref;
1039
1040  while (start < end) {
1041    x1 = *start;
1042    prev = start;
1043    tag = fulltag_of(x1);
1044    if (immheader_tag_p(tag)) {
1045      start = skip_over_ivector(ptr_to_lispobj(start), x1);
1046    } else {
1047      if (header_subtag(x1) == subtag_function) {
1048#ifdef X8632
1049        int skip = (unsigned short)deref(start,1);
1050#else
1051        int skip = (int) deref(start,1);
1052#endif
1053        start += ((1+skip)&~1);
1054        x1 = *start;
1055        tag = fulltag_of(x1);
1056      }
1057      intergen_ref = false;
1058      if (is_node_fulltag(tag)) {       
1059        node_dnode = gc_area_dnode(x1);
1060        if (node_dnode < GCndnodes_in_area) {
1061          intergen_ref = true;
1062        }
1063      }
1064      if (intergen_ref == false) {       
1065        x1 = start[1];
1066        tag = fulltag_of(x1);
1067      if (is_node_fulltag(tag)) {       
1068          node_dnode = gc_area_dnode(x1);
1069          if (node_dnode < GCndnodes_in_area) {
1070            intergen_ref = true;
1071          }
1072        }
1073      }
1074      if (intergen_ref) {
1075        ref_dnode = area_dnode(start, base);
1076        if (!ref_bit(refbits, ref_dnode)) {
1077          Bug(NULL, "Missing memoization in doublenode at 0x%08X", start);
1078          set_bit(refbits, ref_dnode);
1079        }
1080      }
1081      start += 2;
1082    }
1083  }
1084  if (start > end) {
1085    Bug(NULL, "Overran end of range!");
1086  }
1087}
1088
1089
1090
1091void
1092mark_memoized_area(area *a, natural num_memo_dnodes)
1093{
1094  bitvector refbits = a->refbits;
1095  LispObj *p = (LispObj *) a->low, x1, x2;
1096  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
1097  Boolean keep_x1, keep_x2;
1098
1099  if (GCDebug) {
1100    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1101  }
1102
1103  /* The distinction between "inbits" and "outbits" is supposed to help us
1104     detect cases where "uninteresting" setfs have been memoized.  Storing
1105     NIL, fixnums, immediates (characters, etc.) or node pointers to static
1106     or readonly areas is definitely uninteresting, but other cases are
1107     more complicated (and some of these cases are hard to detect.)
1108
1109     Some headers are "interesting", to the forwarder if not to us.
1110
1111     We -don't- give anything any weak treatment here.  Weak things have
1112     to be seen by a full gc, for some value of 'full'.
1113     */
1114
1115  /*
1116    We need to ensure that there are no bits set at or beyond
1117    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
1118    tenures/untenures things.)  We find bits by grabbing a fullword at
1119    a time and doing a cntlzw instruction; and don't want to have to
1120    check for (< memo_dnode num_memo_dnodes) in the loop.
1121    */
1122
1123  {
1124    natural
1125      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
1126      index_of_last_word = (num_memo_dnodes >> bitmap_shift);
1127
1128    if (bits_in_last_word != 0) {
1129      natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1);
1130      refbits[index_of_last_word] &= mask;
1131    }
1132  }
1133       
1134  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1135  inbits = outbits = bits;
1136  while (memo_dnode < num_memo_dnodes) {
1137    if (bits == 0) {
1138      int remain = nbits_in_word - bitidx;
1139      memo_dnode += remain;
1140      p += (remain+remain);
1141      if (outbits != inbits) {
1142        *bitsp = outbits;
1143      }
1144      bits = *++bitsp;
1145      inbits = outbits = bits;
1146      bitidx = 0;
1147    } else {
1148      nextbit = count_leading_zeros(bits);
1149      if ((diff = (nextbit - bitidx)) != 0) {
1150        memo_dnode += diff;
1151        bitidx = nextbit;
1152        p += (diff+diff);
1153      }
1154      x1 = *p++;
1155      x2 = *p++;
1156      bits &= ~(BIT0_MASK >> bitidx);
1157      keep_x1 = mark_ephemeral_root(x1);
1158      keep_x2 = mark_ephemeral_root(x2);
1159      if ((keep_x1 == false) && 
1160          (keep_x2 == false)) {
1161        outbits &= ~(BIT0_MASK >> bitidx);
1162      }
1163      memo_dnode++;
1164      bitidx++;
1165    }
1166  }
1167  if (GCDebug) {
1168    p = (LispObj *) a->low;
1169    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1170  }
1171}
1172
1173void
1174mark_headerless_area_range(LispObj *start, LispObj *end)
1175{
1176  while (start < end) {
1177    mark_root(*start++);
1178  }
1179}
1180
1181void
1182mark_simple_area_range(LispObj *start, LispObj *end)
1183{
1184  LispObj x1, *base;
1185  int tag;
1186
1187  while (start < end) {
1188    x1 = *start;
1189    tag = fulltag_of(x1);
1190    if (immheader_tag_p(tag)) {
1191      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
1192    } else if (!nodeheader_tag_p(tag)) {
1193      ++start;
1194      mark_root(x1);
1195      mark_root(*start++);
1196    } else {
1197      int subtag = header_subtag(x1);
1198      natural element_count = header_element_count(x1);
1199      natural size = (element_count+1 + 1) & ~1;
1200
1201      if (subtag == subtag_hash_vector) {
1202        LispObj flags = ((hash_table_vector_header *) start)->flags;
1203
1204        if (flags & nhash_weak_mask) {
1205          ((hash_table_vector_header *) start)->cache_key = undefined;
1206          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
1207          mark_weak_htabv((LispObj)start);
1208          element_count = 0;
1209        }
1210      } 
1211      if (subtag == subtag_pool) {
1212        start[1] = lisp_nil;
1213      }
1214
1215      if (subtag == subtag_weak) {
1216        natural weak_type = (natural) start[2];
1217        if (weak_type >> population_termination_bit)
1218          element_count -= 2;
1219        else
1220          element_count -= 1; 
1221        start[1] = GCweakvll;
1222        GCweakvll = (LispObj) (((natural) start) + fulltag_misc);   
1223      }
1224
1225      base = start + element_count + 1;
1226      if (subtag == subtag_function) {
1227#ifdef X8632
1228        element_count -= (unsigned short)start[1];
1229#else
1230        element_count -= (int)start[1];
1231#endif
1232      }
1233      while(element_count--) {
1234        mark_root(*--base);
1235      }
1236      start += size;
1237    }
1238  }
1239}
1240
1241
1242/* Mark a tstack area */
1243void
1244mark_tstack_area(area *a)
1245{
1246  LispObj
1247    *current,
1248    *next,
1249    *start = (LispObj *) (a->active),
1250    *end = start,
1251    *limit = (LispObj *) (a->high);
1252
1253  for (current = start;
1254       end != limit;
1255       current = next) {
1256    next = (LispObj *) ptr_from_lispobj(*current);
1257    end = ((next >= start) && (next < limit)) ? next : limit;
1258    mark_simple_area_range(current+2, end);
1259  }
1260}
1261
1262/*
1263  It's really important that headers never wind up in tagged registers.
1264  Those registers would (possibly) get pushed on the vstack and confuse
1265  the hell out of this routine.
1266
1267  vstacks are just treated as a "simple area range", possibly with
1268  an extra word at the top (where the area's active pointer points.)
1269  */
1270
1271void
1272mark_vstack_area(area *a)
1273{
1274  LispObj
1275    *start = (LispObj *) a->active,
1276    *end = (LispObj *) a->high;
1277
1278#if 0
1279  fprintf(stderr, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end);
1280#endif
1281  mark_headerless_area_range(start, end);
1282}
1283
1284/* No lisp objects on cstack on x86, at least x86-64 */
1285void
1286mark_cstack_area(area *a)
1287{
1288}
1289
1290
1291/* Mark the lisp objects in an exception frame */
1292#ifdef X8664
1293void
1294mark_xp(ExceptionInformation *xp)
1295{
1296  natural *regs = (natural *) xpGPRvector(xp), dnode;
1297  LispObj rip;
1298   
1299 
1300
1301  mark_root(regs[Iarg_z]);
1302  mark_root(regs[Iarg_y]);
1303  mark_root(regs[Iarg_x]);
1304  mark_root(regs[Isave3]);
1305  mark_root(regs[Isave2]);
1306  mark_root(regs[Isave1]);
1307  mark_root(regs[Isave0]);
1308  mark_root(regs[Ifn]);
1309  mark_root(regs[Itemp0]);
1310  mark_root(regs[Itemp1]);
1311  mark_root(regs[Itemp2]);
1312  /* If the RIP isn't pointing into a marked function,
1313     we can -maybe- recover from that if it's tagged as
1314     a TRA. */
1315  rip = regs[Iip];
1316  dnode = gc_area_dnode(rip);
1317  if ((dnode < GCndnodes_in_area) &&
1318      (! ref_bit(GCmarkbits,dnode))) {
1319    if (tag_of(rip) == tag_tra) {
1320      mark_root(rip);
1321    } else if ((fulltag_of(rip) == fulltag_function) &&
1322               (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) &&
1323               (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) &&
1324               ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) {
1325      mark_root(rip);
1326    } else {
1327      Bug(NULL, "Can't find function for rip 0x%16lx",rip);
1328    }
1329  }
1330}
1331#else
1332void
1333mark_xp(ExceptionInformation *xp, natural node_regs_mask)
1334{
1335  natural *regs = (natural *) xpGPRvector(xp), dnode;
1336  LispObj eip;
1337  int i;
1338
1339  if (node_regs_mask & (1<<0)) mark_root(regs[REG_EAX]);
1340  if (node_regs_mask & (1<<1)) mark_root(regs[REG_ECX]);
1341  if (regs[REG_EFL] & EFL_DF) {
1342    /* DF set means EDX should be treated as an imm reg */
1343    ;
1344  } else
1345    if (node_regs_mask & (1<<2)) mark_root(regs[REG_EDX]);
1346
1347  if (node_regs_mask & (1<<3)) mark_root(regs[REG_EBX]);
1348  if (node_regs_mask & (1<<4)) mark_root(regs[REG_ESP]);
1349  if (node_regs_mask & (1<<5)) mark_root(regs[REG_EBP]);
1350  if (node_regs_mask & (1<<6)) mark_root(regs[REG_ESI]);
1351  if (node_regs_mask & (1<<7)) mark_root(regs[REG_EDI]);
1352
1353  /* If the EIP isn't pointing into a marked function, we're probably
1354     in trouble.  We can -maybe- recover from that if it's tagged as a
1355     TRA. */
1356  eip = regs[Ieip];
1357  dnode = gc_area_dnode(eip);
1358  if ((dnode < GCndnodes_in_area) &&
1359      (! ref_bit(GCmarkbits,dnode))) {
1360    if (fulltag_of(eip) == fulltag_tra) {
1361      mark_root(eip);
1362    } else if ((fulltag_of(eip) == fulltag_misc) &&
1363               (header_subtag(header_of(eip)) == subtag_function) &&
1364               (*(unsigned char *)eip == RECOVER_FN_OPCODE) &&
1365               (*(LispObj *)(eip + 1)) == eip) {
1366      mark_root(eip);
1367    } else {
1368      Bug(NULL, "Can't find function for eip 0x%4x", eip);
1369    }
1370  }
1371}
1372#endif
1373
1374/* A "pagelet" contains 32 doublewords.  The relocation table contains
1375   a word for each pagelet which defines the lowest address to which
1376   dnodes on that pagelet will be relocated.
1377
1378   The relocation address of a given pagelet is the sum of the relocation
1379   address for the preceding pagelet and the number of bytes occupied by
1380   marked objects on the preceding pagelet.
1381*/
1382
1383LispObj
1384calculate_relocation()
1385{
1386  LispObj *relocptr = GCrelocptr;
1387  LispObj current = GCareadynamiclow;
1388  bitvector
1389    markbits = GCdynamic_markbits;
1390  qnode *q = (qnode *) markbits;
1391  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
1392  natural thesebits;
1393  LispObj first = 0;
1394
1395  if (npagelets) {
1396    do {
1397      *relocptr++ = current;
1398      thesebits = *markbits++;
1399      if (thesebits == ALL_ONES) {
1400        current += nbits_in_word*dnode_size;
1401        q += 4; /* sic */
1402      } else {
1403        if (!first) {
1404          first = current;
1405          while (thesebits & BIT0_MASK) {
1406            first += dnode_size;
1407            thesebits += thesebits;
1408          }
1409        }
1410        /* We're counting bits in qnodes in the wrong order here, but
1411           that's OK.  I think ... */
1412        current += one_bits(*q++);
1413        current += one_bits(*q++);
1414        current += one_bits(*q++);
1415        current += one_bits(*q++);
1416      }
1417    } while(--npagelets);
1418  }
1419  *relocptr++ = current;
1420  return first ? first : current;
1421}
1422
1423
1424#if 0
1425LispObj
1426dnode_forwarding_address(natural dnode, int tag_n)
1427{
1428  natural pagelet, nbits;
1429  unsigned int near_bits;
1430  LispObj new;
1431
1432  if (GCDebug) {
1433    if (! ref_bit(GCdynamic_markbits, dnode)) {
1434      Bug(NULL, "unmarked object being forwarded!\n");
1435    }
1436  }
1437
1438  pagelet = dnode >> bitmap_shift;
1439  nbits = dnode & bitmap_shift_count_mask;
1440  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];
1441
1442  if (nbits < 32) {
1443    new = GCrelocptr[pagelet] + tag_n;;
1444    /* Increment "new" by the count of 1 bits which precede the dnode */
1445    if (near_bits == 0xffffffff) {
1446      return (new + (nbits << 4));
1447    } else {
1448      near_bits &= (0xffffffff00000000 >> nbits);
1449      if (nbits > 15) {
1450        new += one_bits(near_bits & 0xffff);
1451      }
1452      return (new + (one_bits(near_bits >> 16)));
1453    }
1454  } else {
1455    new = GCrelocptr[pagelet+1] + tag_n;
1456    nbits = 64-nbits;
1457
1458    if (near_bits == 0xffffffff) {
1459      return (new - (nbits << 4));
1460    } else {
1461      near_bits &= (1<<nbits)-1;
1462      if (nbits > 15) {
1463        new -= one_bits(near_bits >> 16);
1464      }
1465      return (new -  one_bits(near_bits & 0xffff));
1466    }
1467  }
1468}
1469#else
1470#ifdef X8664
1471/* Quicker, dirtier */
1472LispObj
1473dnode_forwarding_address(natural dnode, int tag_n)
1474{
1475  natural pagelet, nbits, marked;
1476  LispObj new;
1477
1478  if (GCDebug) {
1479    if (! ref_bit(GCdynamic_markbits, dnode)) {
1480      Bug(NULL, "unmarked object being forwarded!\n");
1481    }
1482  }
1483
1484  pagelet = dnode >> bitmap_shift;
1485  nbits = dnode & bitmap_shift_count_mask;
1486  new = GCrelocptr[pagelet] + tag_n;;
1487  if (nbits) {
1488    marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits);
1489    while (marked) {
1490      new += one_bits((qnode)marked);
1491      marked >>=16;
1492    }
1493  }
1494  return new;
1495}
1496#endif
1497#ifdef X8632
1498LispObj
1499dnode_forwarding_address(natural dnode, int tag_n)
1500{
1501  natural pagelet, nbits;
1502  unsigned short near_bits;
1503  LispObj new;
1504
1505  if (GCDebug) {
1506    if (! ref_bit(GCdynamic_markbits, dnode)) {
1507      Bug(NULL, "unmarked object being forwarded!\n");
1508    }
1509  }
1510
1511  pagelet = dnode >> 5;
1512  nbits = dnode & 0x1f;
1513  /* On little-endian x86, we have to flip the low bit of dnode>>4 to
1514     get the near_bits from the appropriate half-word. */
1515  near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1];
1516
1517  if (nbits < 16) {
1518    new = GCrelocptr[pagelet] + tag_n;;
1519    /* Increment "new" by the count of 1 bits which precede the dnode */
1520    if (near_bits == 0xffff) {
1521      return (new + (nbits << 3));
1522    } else {
1523      near_bits &= (0xffff0000 >> nbits);
1524      if (nbits > 7) {
1525        new += one_bits(near_bits & 0xff);
1526      }
1527      return (new + (one_bits(near_bits >> 8))); 
1528    }
1529  } else {
1530    new = GCrelocptr[pagelet+1] + tag_n;
1531    nbits = 32-nbits;
1532
1533    if (near_bits == 0xffff) {
1534      return (new - (nbits << 3));
1535    } else {
1536      near_bits &= (1<<nbits)-1;
1537      if (nbits > 7) {
1538        new -= one_bits(near_bits >> 8);
1539      }
1540      return (new - one_bits(near_bits & 0xff));
1541    }
1542  }
1543}
1544#endif
1545#endif
1546
1547LispObj
1548locative_forwarding_address(LispObj obj)
1549{
1550  int tag_n = fulltag_of(obj);
1551  natural dnode = gc_dynamic_area_dnode(obj);
1552
1553
1554  if ((dnode >= GCndynamic_dnodes_in_area) ||
1555      (obj < GCfirstunmarked)) {
1556    return obj;
1557  }
1558
1559  return dnode_forwarding_address(dnode, tag_n);
1560}
1561
1562
1563void
1564forward_headerless_range(LispObj *range_start, LispObj *range_end)
1565{
1566  LispObj *p = range_start;
1567
1568  while (p < range_end) {
1569    update_noderef(p);
1570    p++;
1571  }
1572}
1573
1574void
1575forward_range(LispObj *range_start, LispObj *range_end)
1576{
1577  LispObj *p = range_start, node, new;
1578  int tag_n;
1579  natural nwords;
1580  hash_table_vector_header *hashp;
1581
1582  while (p < range_end) {
1583    node = *p;
1584    tag_n = fulltag_of(node);
1585    if (immheader_tag_p(tag_n)) {
1586      p = (LispObj *) skip_over_ivector((natural) p, node);
1587    } else if (nodeheader_tag_p(tag_n)) {
1588      nwords = header_element_count(node);
1589      nwords += (1 - (nwords&1));
1590      if ((header_subtag(node) == subtag_hash_vector) &&
1591          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
1592        natural skip = hash_table_vector_header_count-1;
1593        hashp = (hash_table_vector_header *) p;
1594        p++;
1595        nwords -= skip;
1596        while(skip--) {
1597          update_noderef(p);
1598          p++;
1599        }
1600        /* "nwords" is odd at this point: there are (floor nwords 2)
1601           key/value pairs to look at, and then an extra word for
1602           alignment.  Process them two at a time, then bump "p"
1603           past the alignment word. */
1604        nwords >>= 1;
1605        while(nwords--) {
1606          if (update_noderef(p) && hashp) {
1607            hashp->flags |= nhash_key_moved_mask;
1608            hashp = NULL;
1609          }
1610          p++;
1611          update_noderef(p);
1612          p++;
1613        }
1614        *p++ = 0;
1615      } else {
1616        if (header_subtag(node) == subtag_function) {
1617#ifdef X8632
1618          int skip = (unsigned short)(p[1]);
1619#else
1620          int skip = (int)(p[1]);
1621#endif
1622          p += skip;
1623          nwords -= skip;
1624        }
1625        p++;
1626        while(nwords--) {
1627          update_noderef(p);
1628          p++;
1629        }
1630      }
1631    } else {
1632      new = node_forwarding_address(node);
1633      if (new != node) {
1634        *p = new;
1635      }
1636      p++;
1637      update_noderef(p);
1638      p++;
1639    }
1640  }
1641}
1642
1643
1644
1645
1646
1647
1648/* Forward a tstack area */
1649void
1650forward_tstack_area(area *a)
1651{
1652  LispObj
1653    *current,
1654    *next,
1655    *start = (LispObj *) a->active,
1656    *end = start,
1657    *limit = (LispObj *) (a->high);
1658
1659  for (current = start;
1660       end != limit;
1661       current = next) {
1662    next = ptr_from_lispobj(*current);
1663    end = ((next >= start) && (next < limit)) ? next : limit;
1664    forward_range(current+2, end);
1665  }
1666}
1667
1668/* Forward a vstack area */
1669void
1670forward_vstack_area(area *a)
1671{
1672  LispObj
1673    *p = (LispObj *) a->active,
1674    *q = (LispObj *) a->high;
1675
1676  forward_headerless_range(p, q);
1677}
1678
1679/* Nothing of interest on x86 cstack */
1680void
1681forward_cstack_area(area *a)
1682{
1683}
1684
1685#ifdef X8664
1686void
1687forward_xp(ExceptionInformation *xp)
1688{
1689  natural *regs = (natural *) xpGPRvector(xp);
1690
1691  update_noderef(&(regs[Iarg_z]));
1692  update_noderef(&(regs[Iarg_y]));
1693  update_noderef(&(regs[Iarg_x]));
1694  update_noderef(&(regs[Isave3]));
1695  update_noderef(&(regs[Isave2]));
1696  update_noderef(&(regs[Isave1]));
1697  update_noderef(&(regs[Isave0]));
1698  update_noderef(&(regs[Ifn]));
1699  update_noderef(&(regs[Itemp0]));
1700  update_noderef(&(regs[Itemp1]));
1701  update_noderef(&(regs[Itemp2]));
1702  update_locref(&(regs[Iip]));
1703}
1704#else
1705void
1706forward_xp(ExceptionInformation *xp, natural node_regs_mask)
1707{
1708  natural *regs = (natural *) xpGPRvector(xp);
1709
1710  if (node_regs_mask & (1<<0)) update_noderef(&regs[REG_EAX]);
1711  if (node_regs_mask & (1<<1)) update_noderef(&regs[REG_ECX]);
1712
1713  if (regs[REG_EFL] & EFL_DF) {
1714    /* then EDX is an imm reg */
1715    ;
1716  } else
1717    if (node_regs_mask & (1<<2)) update_noderef(&regs[REG_EDX]);
1718
1719  if (node_regs_mask & (1<<3)) update_noderef(&regs[REG_EBX]);
1720  if (node_regs_mask & (1<<4)) update_noderef(&regs[REG_ESP]);
1721  if (node_regs_mask & (1<<5)) update_noderef(&regs[REG_EBP]);
1722  if (node_regs_mask & (1<<6)) update_noderef(&regs[REG_ESI]);
1723  if (node_regs_mask & (1<<7)) update_noderef(&regs[REG_EDI]);
1724
1725  update_locref(&(regs[Iip]));
1726}
1727#endif
1728
1729
1730void
1731forward_tcr_xframes(TCR *tcr)
1732{
1733  xframe_list *xframes;
1734  ExceptionInformation *xp;
1735
1736  xp = tcr->gc_context;
1737  if (xp) {
1738#ifdef X8664
1739    forward_xp(xp);
1740#else
1741    forward_xp(xp, tcr->node_regs_mask);
1742
1743    update_noderef(&tcr->save0);
1744    update_noderef(&tcr->save1);
1745    update_noderef(&tcr->save2);
1746    update_noderef(&tcr->save3);
1747    update_noderef(&tcr->next_method_context);
1748#endif
1749  }
1750  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
1751#ifdef X8664
1752    forward_xp(xframes->curr);
1753#else
1754    forward_xp(xframes->curr, xframes->node_regs_mask);
1755#endif
1756  }
1757}
1758
1759
1760#ifdef X8632
1761void
1762update_self_references(LispObj *node)
1763{
1764  LispObj fn = fulltag_misc + (LispObj)node;
1765  unsigned char *p = (unsigned char *)node;
1766  natural i, offset;
1767
1768  i = ((unsigned short *)node)[2];
1769  offset = node[--i];
1770  while (offset) {
1771    *(LispObj *)(p + offset) = fn;
1772    offset = node[--i];
1773  }   
1774}
1775#endif
1776
1777/*
1778  Compact the dynamic heap (from GCfirstunmarked through its end.)
1779  Return the doublenode address of the new freeptr.
1780  */
1781
1782LispObj
1783compact_dynamic_heap()
1784{
1785  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
1786  natural
1787    elements, 
1788    dnode = gc_area_dnode(GCfirstunmarked), 
1789    node_dnodes = 0, 
1790    imm_dnodes = 0, 
1791    bitidx, 
1792    *bitsp, 
1793    bits, 
1794    nextbit, 
1795    diff;
1796  int tag;
1797  bitvector markbits = GCmarkbits;
1798
1799  if (dnode < GCndnodes_in_area) {
1800    lisp_global(FWDNUM) += (1<<fixnum_shift);
1801 
1802    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1803    while (dnode < GCndnodes_in_area) {
1804      if (bits == 0) {
1805        int remain = nbits_in_word - bitidx;
1806        dnode += remain;
1807        src += (remain+remain);
1808        bits = *++bitsp;
1809        bitidx = 0;
1810      } else {
1811        /* Have a non-zero markbits word; all bits more significant
1812           than "bitidx" are 0.  Count leading zeros in "bits"
1813           (there'll be at least "bitidx" of them.)  If there are more
1814           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1815           "src" by the difference. */
1816        nextbit = count_leading_zeros(bits);
1817        if ((diff = (nextbit - bitidx)) != 0) {
1818          dnode += diff;
1819          bitidx = nextbit;
1820          src += (diff+diff);
1821        }
1822        prev = current;
1823        current = src;
1824        if (GCDebug) {
1825          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1826            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x" LISP " to 0x" LISP ",\n expected to go to 0x" LISP "\n", 
1827                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1828          }
1829        }
1830
1831        node = *src++;
1832        tag = fulltag_of(node);
1833        if (nodeheader_tag_p(tag)) {
1834          elements = header_element_count(node);
1835          node_dnodes = (elements+2)>>1;
1836          dnode += node_dnodes;
1837          if (header_subtag(node) == subtag_function) {
1838#ifdef X8632
1839            int skip = *((unsigned short *)src);
1840            LispObj *f = dest;
1841#else
1842            int skip = *((int *)src);
1843#endif
1844            *dest++ = node;
1845            elements -= skip;
1846            while(skip--) {
1847              *dest++ = *src++;
1848            }
1849#ifdef X8632
1850            update_self_references(f);
1851#endif
1852            while(elements--) {
1853              *dest++ = node_forwarding_address(*src++);
1854            }
1855            if (((LispObj)src) & node_size) {
1856              src++;
1857              *dest++ = 0;
1858            }
1859          } else {
1860            if ((header_subtag(node) == subtag_hash_vector) &&
1861                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1862              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1863              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1864             
1865              *dest++ = node;
1866              elements -= skip;
1867              while(skip--) {
1868                *dest++ = node_forwarding_address(*src++);
1869              }
1870              /* There should be an even number of (key/value) pairs in elements;
1871                 an extra alignment word follows. */
1872              elements >>= 1;
1873              while (elements--) {
1874                if (hashp) {
1875                  node = *src++;
1876                  new = node_forwarding_address(node);
1877                  if (new != node) {
1878                    hashp->flags |= nhash_key_moved_mask;
1879                    hashp = NULL;
1880                    *dest++ = new;
1881                  } else {
1882                    *dest++ = node;
1883                  }
1884                } else {
1885                  *dest++ = node_forwarding_address(*src++);
1886                }
1887                *dest++ = node_forwarding_address(*src++);
1888              }
1889              *dest++ = 0;
1890              src++;
1891            } else {
1892              *dest++ = node;
1893              *dest++ = node_forwarding_address(*src++);
1894              while(--node_dnodes) {
1895                *dest++ = node_forwarding_address(*src++);
1896                *dest++ = node_forwarding_address(*src++);
1897              }
1898            }
1899          }
1900          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1901        } else if (immheader_tag_p(tag)) {
1902          *dest++ = node;
1903          *dest++ = *src++;
1904          elements = header_element_count(node);
1905          tag = header_subtag(node);
1906
1907#ifdef X8664
1908          switch(fulltag_of(tag)) {
1909          case ivector_class_64_bit:
1910            imm_dnodes = ((elements+1)+1)>>1;
1911            break;
1912          case ivector_class_32_bit:
1913            imm_dnodes = (((elements+2)+3)>>2);
1914            break;
1915          case ivector_class_other_bit:
1916            if (tag == subtag_bit_vector) {
1917              imm_dnodes = (((elements+64)+127)>>7);
1918            } else if (tag >= min_8_bit_ivector_subtag) {
1919              imm_dnodes = (((elements+8)+15)>>4);
1920            } else {
1921              imm_dnodes = (((elements+4)+7)>>3);
1922            }
1923          }
1924#endif
1925#ifdef X8632
1926          if (tag <= max_32_bit_ivector_subtag) {
1927            imm_dnodes = (((elements+1)+1)>>1);
1928          } else if (tag <= max_8_bit_ivector_subtag) {
1929            imm_dnodes = (((elements+4)+7)>>3);
1930          } else if (tag <= max_16_bit_ivector_subtag) {
1931            imm_dnodes = (((elements+2)+3)>>2);
1932          } else if (tag == subtag_bit_vector) {
1933            imm_dnodes = (((elements+32)+63)>>6);
1934          } else {
1935            imm_dnodes = elements+1;
1936          }
1937#endif
1938
1939          dnode += imm_dnodes;
1940          while (--imm_dnodes) {
1941            *dest++ = *src++;
1942            *dest++ = *src++;
1943          }
1944          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1945        } else {
1946          *dest++ = node_forwarding_address(node);
1947          *dest++ = node_forwarding_address(*src++);
1948          bits &= ~(BIT0_MASK >> bitidx);
1949          dnode++;
1950          bitidx++;
1951        }
1952      }
1953    }
1954  }
1955  return ptr_to_lispobj(dest);
1956}
1957
1958
1959
1960
1961
1962     
1963   
1964/*
1965  Total the (physical) byte sizes of all ivectors in the indicated memory range
1966*/
1967
1968natural
1969unboxed_bytes_in_range(LispObj *start, LispObj *end)
1970{
1971  natural total=0, elements, tag, subtag, bytes;
1972  LispObj header;
1973
1974  while (start < end) {
1975    header = *start;
1976    tag = fulltag_of(header);
1977   
1978    if ((nodeheader_tag_p(tag)) ||
1979        (immheader_tag_p(tag))) {
1980      elements = header_element_count(header);
1981      if (nodeheader_tag_p(tag)) {
1982        start += ((elements+2) & ~1);
1983      } else {
1984        subtag = header_subtag(header);
1985
1986#ifdef X8664
1987        switch(fulltag_of(header)) {
1988        case ivector_class_64_bit:
1989          bytes = 8 + (elements<<3);
1990          break;
1991        case ivector_class_32_bit:
1992          bytes = 8 + (elements<<2);
1993          break;
1994        case ivector_class_other_bit:
1995        default:
1996          if (subtag == subtag_bit_vector) {
1997            bytes = 8 + ((elements+7)>>3);
1998          } else if (subtag >= min_8_bit_ivector_subtag) {
1999            bytes = 8 + elements;
2000          } else {
2001            bytes = 8 + (elements<<1);
2002          }
2003        }
2004#endif
2005#ifdef X8632
2006          if (subtag <= max_32_bit_ivector_subtag) {
2007            bytes = 4 + (elements<<2);
2008          } else if (subtag <= max_8_bit_ivector_subtag) {
2009            bytes = 4 + elements;
2010          } else if (subtag <= max_16_bit_ivector_subtag) {
2011            bytes = 4 + (elements<<1);
2012          } else if (subtag == subtag_double_float_vector) {
2013            bytes = 8 + (elements<<3);
2014          } else {
2015            bytes = 4 + ((elements+7)>>3);
2016          }
2017#endif
2018
2019        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
2020        total += bytes;
2021        start += (bytes >> node_shift);
2022      }
2023    } else {
2024      start += 2;
2025    }
2026  }
2027  return total;
2028}
2029
2030
2031/*
2032  This assumes that it's getting called with a simple-{base,general}-string
2033  or code vector as an argument and that there's room for the object in the
2034  destination area.
2035*/
2036
2037
2038LispObj
2039purify_displaced_object(LispObj obj, area *dest, natural disp)
2040{
2041  BytePtr
2042    free = dest->active,
2043    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
2044  LispObj
2045    header = header_of(obj), 
2046    new;
2047  natural
2048    start = (natural)old,
2049    physbytes;
2050
2051  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
2052
2053  dest->active += physbytes;
2054
2055  new = ptr_to_lispobj(free)+disp;
2056
2057  memcpy(free, (BytePtr)old, physbytes);
2058  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
2059  /* Actually, it's best to always leave a trail, for two reasons.
2060     a) We may be walking the same heap that we're leaving forwaring
2061     pointers in, so we don't want garbage that we leave behind to
2062     look like a header.
2063     b) We'd like to be able to forward code-vector locatives, and
2064     it's easiest to do so if we leave a {forward_marker, dnode_locative}
2065     pair at every doubleword in the old vector.
2066     */
2067  while(physbytes) {
2068    *old++ = (BytePtr) forward_marker;
2069    *old++ = (BytePtr) free;
2070    free += dnode_size;
2071    physbytes -= dnode_size;
2072  }
2073  return new;
2074}
2075
2076LispObj
2077purify_object(LispObj obj, area *dest)
2078{
2079  return purify_displaced_object(obj, dest, fulltag_of(obj));
2080}
2081
2082Boolean
2083copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
2084{
2085  LispObj obj = *ref, header, new;
2086  natural tag = fulltag_of(obj), header_tag;
2087  Boolean changed = false;
2088
2089  if ((tag == fulltag_misc) &&
2090      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
2091      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
2092    header = deref(obj, 0);
2093    if (header == forward_marker) { /* already copied */
2094      *ref = (untag(deref(obj,1)) + tag);
2095      changed = true;
2096    } else {
2097      header_tag = fulltag_of(header);
2098      if (immheader_tag_p(header_tag)) {
2099        if (header_subtag(header) != subtag_macptr) {
2100          new = purify_object(obj, dest);
2101          *ref = new;
2102          changed = (new != obj);
2103        }
2104      }
2105    }
2106  }
2107  return changed;
2108}
2109
2110
2111void
2112purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
2113{
2114  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2115
2116  while ((*prev) != (LispObj)NULL) {
2117    copy_ivector_reference(prev, low, high, to);
2118    next = *prev;
2119    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2120  }
2121}
2122
2123void 
2124purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
2125{
2126  while (start < end) { 
2127    copy_ivector_reference(start, low, high, to);
2128    start++;
2129  }
2130}
2131   
2132void
2133purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
2134{
2135  LispObj header;
2136  unsigned tag;
2137  natural nwords;
2138  hash_table_vector_header *hashp;
2139
2140  while (start < end) {
2141    header = *start;
2142    if (header == forward_marker) {
2143      start += 2;
2144    } else {
2145      tag = fulltag_of(header);
2146      if (immheader_tag_p(tag)) {
2147        start = (LispObj *)skip_over_ivector((natural)start, header);
2148      } else if (nodeheader_tag_p(tag)) {
2149        nwords = header_element_count(header);
2150        nwords += (1 - (nwords&1));
2151        if ((header_subtag(header) == subtag_hash_vector) &&
2152          ((((hash_table_vector_header *)start)->flags) & 
2153           nhash_track_keys_mask)) {
2154          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2155
2156          hashp = (hash_table_vector_header *) start;
2157          start++;
2158          nwords -= skip;
2159          while(skip--) {
2160            copy_ivector_reference(start, low, high, to);
2161            start++;
2162          }
2163          /* "nwords" is odd at this point: there are (floor nwords 2)
2164             key/value pairs to look at, and then an extra word for
2165             alignment.  Process them two at a time, then bump "start"
2166             past the alignment word. */
2167          nwords >>= 1;
2168          while(nwords--) {
2169            if (copy_ivector_reference(start, low, high, to) && hashp) {
2170              hashp->flags |= nhash_key_moved_mask;
2171              hashp = NULL;
2172            }
2173            start++;
2174            copy_ivector_reference(start, low, high, to);
2175            start++;
2176          }
2177          *start++ = 0;
2178        } else {
2179          if (header_subtag(header) == subtag_function) {
2180#ifdef X8632
2181            int skip = (unsigned short)(start[1]);
2182#else
2183            int skip = (int)(start[1]);
2184#endif
2185            start += skip;
2186            nwords -= skip;
2187          }
2188          start++;
2189          while(nwords--) {
2190            copy_ivector_reference(start, low, high, to);
2191            start++;
2192          }
2193        }
2194      } else {
2195        /* Not a header, just a cons cell */
2196        copy_ivector_reference(start, low, high, to);
2197        start++;
2198        copy_ivector_reference(start, low, high, to);
2199        start++;
2200      }
2201    }
2202  }
2203}
2204       
2205/* Purify references from tstack areas */
2206void
2207purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
2208{
2209  LispObj
2210    *current,
2211    *next,
2212    *start = (LispObj *) (a->active),
2213    *end = start,
2214    *limit = (LispObj *) (a->high);
2215
2216  for (current = start;
2217       end != limit;
2218       current = next) {
2219    next = (LispObj *) ptr_from_lispobj(*current);
2220    end = ((next >= start) && (next < limit)) ? next : limit;
2221    purify_range(current+2, end, low, high, to);
2222  }
2223}
2224
2225/* Purify a vstack area */
2226void
2227purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
2228{
2229  LispObj
2230    *p = (LispObj *) a->active,
2231    *q = (LispObj *) a->high;
2232 
2233  purify_headerless_range(p, q, low, high, to);
2234}
2235
2236
2237void
2238purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
2239{
2240  natural *regs = (natural *) xpGPRvector(xp);
2241
2242
2243#ifdef X8664
2244  copy_ivector_reference(&(regs[Iarg_z]), low, high, to);
2245  copy_ivector_reference(&(regs[Iarg_y]), low, high, to);
2246  copy_ivector_reference(&(regs[Iarg_x]), low, high, to);
2247  copy_ivector_reference(&(regs[Isave3]), low, high, to);
2248  copy_ivector_reference(&(regs[Isave2]), low, high, to);
2249  copy_ivector_reference(&(regs[Isave1]), low, high, to);
2250  copy_ivector_reference(&(regs[Isave0]), low, high, to);
2251  copy_ivector_reference(&(regs[Ifn]), low, high, to);
2252  copy_ivector_reference(&(regs[Itemp0]), low, high, to);
2253  copy_ivector_reference(&(regs[Itemp1]), low, high, to);
2254  copy_ivector_reference(&(regs[Itemp2]), low, high, to);
2255#if 0
2256  purify_locref(&(regs[Iip]), low, high, to);
2257#endif
2258#else
2259#endif
2260}
2261
2262void
2263purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
2264{
2265  natural n = tcr->tlb_limit;
2266  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2267
2268  purify_range(start, end, low, high, to);
2269}
2270
2271void
2272purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
2273{
2274  xframe_list *xframes;
2275  ExceptionInformation *xp;
2276 
2277  xp = tcr->gc_context;
2278  if (xp) {
2279    purify_xp(xp, low, high, to);
2280  }
2281
2282  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2283    purify_xp(xframes->curr, low, high, to);
2284  }
2285}
2286
2287
2288void
2289purify_areas(BytePtr low, BytePtr high, area *target)
2290{
2291  area *next_area;
2292  area_code code;
2293     
2294  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2295    switch (code) {
2296    case AREA_TSTACK:
2297      purify_tstack_area(next_area, low, high, target);
2298      break;
2299     
2300    case AREA_VSTACK:
2301      purify_vstack_area(next_area, low, high, target);
2302      break;
2303     
2304    case AREA_CSTACK:
2305      break;
2306     
2307    case AREA_STATIC:
2308    case AREA_DYNAMIC:
2309      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
2310      break;
2311     
2312    default:
2313      break;
2314    }
2315  }
2316}
2317
2318/*
2319  So far, this is mostly for save_application's benefit.
2320  We -should- be able to return to lisp code after doing this,
2321  however.
2322
2323*/
2324
2325
2326int
2327purify(TCR *tcr, signed_natural param)
2328{
2329  extern area *extend_readonly_area(unsigned);
2330  area
2331    *a = active_dynamic_area,
2332    *new_pure_area;
2333
2334  TCR  *other_tcr;
2335  natural max_pure_size;
2336  BytePtr new_pure_start,
2337    low = (a->low + (static_dnodes_for_area(a) << dnode_shift)),
2338    high = a->active;
2339
2340
2341  max_pure_size = unboxed_bytes_in_range((LispObj *) low, (LispObj *) high);
2342  new_pure_area = extend_readonly_area(max_pure_size);
2343  if (new_pure_area) {
2344    new_pure_start = new_pure_area->active;
2345    lisp_global(IN_GC) = (1<<fixnumshift);
2346
2347    /*
2348
2349       
2350      Make the new_pure_area executable, just in case.
2351
2352      Caller will typically GC again (and that should recover quite a bit of
2353      the dynamic heap.)
2354      */
2355
2356
2357   
2358    purify_areas(low, high, new_pure_area);
2359   
2360    other_tcr = tcr;
2361    do {
2362      purify_tcr_xframes(other_tcr, low, high, new_pure_area);
2363      purify_tcr_tlb(other_tcr, low, high, new_pure_area);
2364      other_tcr = other_tcr->next;
2365    } while (other_tcr != tcr);
2366
2367    purify_gcable_ptrs(low, high, new_pure_area);
2368    {
2369      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2370      if (puresize != 0) {
2371        xMakeDataExecutable(new_pure_start, puresize);
2372 
2373      }
2374    }
2375    ProtectMemory(new_pure_area->low,
2376                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2377                                      log2_page_size));
2378    lisp_global(IN_GC) = 0;
2379    just_purified_p = true;
2380    return 0;
2381  }
2382  return -1;
2383}
2384
2385
2386 
2387Boolean
2388impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2389{
2390  LispObj q = *p;
2391 
2392  if (is_node_fulltag(fulltag_of(q)) &&
2393      (q >= low) && 
2394      (q < high)) {
2395    *p = (q+delta);
2396    return true;
2397  }
2398  return false;
2399}
2400 
2401
2402void
2403impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2404{
2405  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2406
2407  while ((*prev) != (LispObj)NULL) {
2408    impurify_noderef(prev, low, high, delta);
2409    next = *prev;
2410    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2411  }
2412}
2413
2414
2415void
2416impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2417{
2418  natural *regs = (natural *) xpGPRvector(xp);
2419
2420
2421#ifdef X8664
2422  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2423  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2424  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2425#ifndef WINDOWS
2426  impurify_noderef(&(regs[Isave3]), low, high, delta);
2427#endif
2428  impurify_noderef(&(regs[Isave2]), low, high, delta);
2429  impurify_noderef(&(regs[Isave1]), low, high, delta);
2430  impurify_noderef(&(regs[Isave0]), low, high, delta);
2431  impurify_noderef(&(regs[Ifn]), low, high, delta);
2432  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2433  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2434#if 0
2435  impurify_locref(&(regs[Iip]), low, high, delta);
2436#endif
2437#else
2438#endif
2439
2440}
2441
2442void
2443impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2444{
2445  while (start < end) {
2446    impurify_noderef(start, low, high, delta);
2447    start++;
2448  }
2449}
2450
2451
2452void
2453impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2454{
2455  LispObj header;
2456  unsigned tag;
2457  natural nwords;
2458  hash_table_vector_header *hashp;
2459
2460  while (start < end) {
2461    header = *start;
2462    if (header == forward_marker) {
2463      start += 2;
2464    } else {
2465      tag = fulltag_of(header);
2466      if (immheader_tag_p(tag)) {
2467        start = (LispObj *)skip_over_ivector((natural)start, header);
2468      } else if (nodeheader_tag_p(tag)) {
2469        nwords = header_element_count(header);
2470        nwords += (1 - (nwords&1));
2471        if ((header_subtag(header) == subtag_hash_vector) &&
2472          ((((hash_table_vector_header *)start)->flags) & 
2473           nhash_track_keys_mask)) {
2474          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2475
2476          hashp = (hash_table_vector_header *) start;
2477          start++;
2478          nwords -= skip;
2479          while(skip--) {
2480            impurify_noderef(start, low, high, delta);
2481            start++;
2482          }
2483          /* "nwords" is odd at this point: there are (floor nwords 2)
2484             key/value pairs to look at, and then an extra word for
2485             alignment.  Process them two at a time, then bump "start"
2486             past the alignment word. */
2487          nwords >>= 1;
2488          while(nwords--) {
2489            if (impurify_noderef(start, low, high, delta) && hashp) {
2490              hashp->flags |= nhash_key_moved_mask;
2491              hashp = NULL;
2492            }
2493            start++;
2494            impurify_noderef(start, low, high, delta);
2495            start++;
2496          }
2497          *start++ = 0;
2498        } else {
2499          if (header_subtag(header) == subtag_function) {
2500            int skip = (int)(start[1]);
2501            start += skip;
2502            nwords -= skip;
2503          }
2504          start++;
2505          while(nwords--) {
2506            impurify_noderef(start, low, high, delta);
2507            start++;
2508          }
2509        }
2510      } else {
2511        /* Not a header, just a cons cell */
2512        impurify_noderef(start, low, high, delta);
2513        start++;
2514        impurify_noderef(start, low, high, delta);
2515        start++;
2516      }
2517    }
2518  }
2519}
2520
2521
2522
2523
2524void
2525impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2526{
2527  unsigned n = tcr->tlb_limit;
2528  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2529 
2530  impurify_range(start, end, low, high, delta);
2531}
2532
2533void
2534impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2535{
2536  xframe_list *xframes;
2537  ExceptionInformation *xp;
2538 
2539  xp = tcr->gc_context;
2540  if (xp) {
2541    impurify_xp(xp, low, high, delta);
2542  }
2543
2544  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2545    impurify_xp(xframes->curr, low, high, delta);
2546  }
2547}
2548
2549void
2550impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2551{
2552  LispObj
2553    *current,
2554    *next,
2555    *start = (LispObj *) (a->active),
2556    *end = start,
2557    *limit = (LispObj *) (a->high);
2558
2559  for (current = start;
2560       end != limit;
2561       current = next) {
2562    next = (LispObj *) ptr_from_lispobj(*current);
2563    end = ((next >= start) && (next < limit)) ? next : limit;
2564    if (current[1] == 0) {
2565      impurify_range(current+2, end, low, high, delta);
2566    }
2567  }
2568}
2569void
2570impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2571{
2572  LispObj
2573    *p = (LispObj *) a->active,
2574    *q = (LispObj *) a->high;
2575
2576  impurify_headerless_range(p, q, low, high, delta);
2577}
2578
2579
2580void
2581impurify_areas(LispObj low, LispObj high, signed_natural delta)
2582{
2583  area *next_area;
2584  area_code code;
2585     
2586  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2587    switch (code) {
2588    case AREA_TSTACK:
2589      impurify_tstack_area(next_area, low, high, delta);
2590      break;
2591     
2592    case AREA_VSTACK:
2593      impurify_vstack_area(next_area, low, high, delta);
2594      break;
2595     
2596    case AREA_CSTACK:
2597      break;
2598     
2599    case AREA_STATIC:
2600    case AREA_DYNAMIC:
2601      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2602      break;
2603     
2604    default:
2605      break;
2606    }
2607  }
2608}
2609
2610int
2611impurify(TCR *tcr, signed_natural param)
2612{
2613  area *r = find_readonly_area();
2614
2615  if (r) {
2616    area *a = active_dynamic_area;
2617    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2618      oldhigh = a->high, newhigh; 
2619    unsigned n = ro_limit - ro_base;
2620    signed_natural delta = oldfree-ro_base;
2621    TCR *other_tcr;
2622
2623    if (n) {
2624      lisp_global(IN_GC) = 1;
2625      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2626                                               log2_heap_segment_size));
2627      if (newhigh > oldhigh) {
2628        grow_dynamic_area(newhigh-oldhigh);
2629      }
2630      a->active += n;
2631      memmove(oldfree, ro_base, n);
2632      UnMapMemory((void *)ro_base, n);
2633      a->ndnodes = area_dnode(a, a->active);
2634      pure_space_active = r->active = r->low;
2635      r->ndnodes = 0;
2636
2637      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2638
2639      other_tcr = tcr;
2640      do {
2641        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2642        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2643        other_tcr = other_tcr->next;
2644      } while (other_tcr != tcr);
2645
2646      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2647      lisp_global(IN_GC) = 0;
2648    }
2649    return 0;
2650  }
2651  return -1;
2652}
Note: See TracBrowser for help on using the repository browser.