source: release/1.3/source/lisp-kernel/x86-gc.c @ 11780

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

x8632 gc/runtime bugfixes from trunk (r11748, r11752, r11754)

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