source: trunk/source/lisp-kernel/x86-gc.c @ 11168

Last change on this file since 11168 was 11168, checked in by gb, 12 years ago

check_all_areas() takes the current tcr as argument; checks exception
frames, tlb, etc. (New! Improved! Even slower!).

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