source: branches/x8632-functions/lisp-kernel/x86-gc.c @ 12349

Last change on this file since 12349 was 12349, checked in by rme, 11 years ago

Preliminary bootstrapping changes to support new function scheme on x8632.

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