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

Last change on this file since 11523 was 11523, checked in by gb, 11 years ago

x86 support for FLASH-FREEZE.
Use signed_natural in x86 gc-like functions.
RECURSIVE-LOCK-WHOSTATE and the RWLOCK-WHOSTATE functions: use
WITH-STANDARD-IO-SYNTAX when consing up the string. Do that in
higher-level code, to avoid early refs to CL-USER pacjage.
(In general, other things similar to RECURSIVE-LOCK-WHOSTATE are
suspect, in that they call (FORMAT NIL ...) in a random environment
where things like *PRINT-READABLY* may be in effect. There are
probably other cases of this.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 72.6 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(stderr, "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  offset = node[--i];
1861  while (offset) {
1862    *(LispObj *)(p + offset) = fn;
1863    offset = node[--i];
1864  }   
1865}
1866#endif
1867
1868/*
1869  Compact the dynamic heap (from GCfirstunmarked through its end.)
1870  Return the doublenode address of the new freeptr.
1871  */
1872
1873LispObj
1874compact_dynamic_heap()
1875{
1876  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
1877  natural
1878    elements, 
1879    dnode = gc_area_dnode(GCfirstunmarked), 
1880    node_dnodes = 0, 
1881    imm_dnodes = 0, 
1882    bitidx, 
1883    *bitsp, 
1884    bits, 
1885    nextbit, 
1886    diff;
1887  int tag;
1888  bitvector markbits = GCmarkbits;
1889
1890  if (dnode < GCndnodes_in_area) {
1891    lisp_global(FWDNUM) += (1<<fixnum_shift);
1892 
1893    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1894    while (dnode < GCndnodes_in_area) {
1895      if (bits == 0) {
1896        int remain = nbits_in_word - bitidx;
1897        dnode += remain;
1898        src += (remain+remain);
1899        bits = *++bitsp;
1900        bitidx = 0;
1901      } else {
1902        /* Have a non-zero markbits word; all bits more significant
1903           than "bitidx" are 0.  Count leading zeros in "bits"
1904           (there'll be at least "bitidx" of them.)  If there are more
1905           than "bitidx" leading zeros, bump "dnode", "bitidx", and
1906           "src" by the difference. */
1907        nextbit = count_leading_zeros(bits);
1908        if ((diff = (nextbit - bitidx)) != 0) {
1909          dnode += diff;
1910          bitidx = nextbit;
1911          src += (diff+diff);
1912        }
1913        prev = current;
1914        current = src;
1915        if (GCDebug) {
1916          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
1917            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x" LISP " to 0x" LISP ",\n expected to go to 0x" LISP "\n", 
1918                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
1919          }
1920        }
1921
1922        node = *src++;
1923        tag = fulltag_of(node);
1924        if (nodeheader_tag_p(tag)) {
1925          elements = header_element_count(node);
1926          node_dnodes = (elements+2)>>1;
1927          dnode += node_dnodes;
1928          if (header_subtag(node) == subtag_function) {
1929#ifdef X8632
1930            int skip = *((unsigned short *)src);
1931            LispObj *f = dest;
1932#else
1933            int skip = *((int *)src);
1934#endif
1935            *dest++ = node;
1936            elements -= skip;
1937            while(skip--) {
1938              *dest++ = *src++;
1939            }
1940#ifdef X8632
1941            update_self_references(f);
1942#endif
1943            while(elements--) {
1944              *dest++ = node_forwarding_address(*src++);
1945            }
1946            if (((LispObj)src) & node_size) {
1947              src++;
1948              *dest++ = 0;
1949            }
1950          } else {
1951            if ((header_subtag(node) == subtag_hash_vector) &&
1952                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
1953              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
1954              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
1955             
1956              *dest++ = node;
1957              elements -= skip;
1958              while(skip--) {
1959                *dest++ = node_forwarding_address(*src++);
1960              }
1961              /* There should be an even number of (key/value) pairs in elements;
1962                 an extra alignment word follows. */
1963              elements >>= 1;
1964              while (elements--) {
1965                if (hashp) {
1966                  node = *src++;
1967                  new = node_forwarding_address(node);
1968                  if (new != node) {
1969                    hashp->flags |= nhash_key_moved_mask;
1970                    hashp = NULL;
1971                    *dest++ = new;
1972                  } else {
1973                    *dest++ = node;
1974                  }
1975                } else {
1976                  *dest++ = node_forwarding_address(*src++);
1977                }
1978                *dest++ = node_forwarding_address(*src++);
1979              }
1980              *dest++ = 0;
1981              src++;
1982            } else {
1983              *dest++ = node;
1984              *dest++ = node_forwarding_address(*src++);
1985              while(--node_dnodes) {
1986                *dest++ = node_forwarding_address(*src++);
1987                *dest++ = node_forwarding_address(*src++);
1988              }
1989            }
1990          }
1991          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
1992        } else if (immheader_tag_p(tag)) {
1993          *dest++ = node;
1994          *dest++ = *src++;
1995          elements = header_element_count(node);
1996          tag = header_subtag(node);
1997
1998#ifdef X8664
1999          switch(fulltag_of(tag)) {
2000          case ivector_class_64_bit:
2001            imm_dnodes = ((elements+1)+1)>>1;
2002            break;
2003          case ivector_class_32_bit:
2004            imm_dnodes = (((elements+2)+3)>>2);
2005            break;
2006          case ivector_class_other_bit:
2007            if (tag == subtag_bit_vector) {
2008              imm_dnodes = (((elements+64)+127)>>7);
2009            } else if (tag >= min_8_bit_ivector_subtag) {
2010              imm_dnodes = (((elements+8)+15)>>4);
2011            } else {
2012              imm_dnodes = (((elements+4)+7)>>3);
2013            }
2014          }
2015#endif
2016#ifdef X8632
2017          if (tag <= max_32_bit_ivector_subtag) {
2018            imm_dnodes = (((elements+1)+1)>>1);
2019          } else if (tag <= max_8_bit_ivector_subtag) {
2020            imm_dnodes = (((elements+4)+7)>>3);
2021          } else if (tag <= max_16_bit_ivector_subtag) {
2022            imm_dnodes = (((elements+2)+3)>>2);
2023          } else if (tag == subtag_bit_vector) {
2024            imm_dnodes = (((elements+32)+63)>>6);
2025          } else {
2026            imm_dnodes = elements+1;
2027          }
2028#endif
2029
2030          dnode += imm_dnodes;
2031          while (--imm_dnodes) {
2032            *dest++ = *src++;
2033            *dest++ = *src++;
2034          }
2035          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
2036        } else {
2037          *dest++ = node_forwarding_address(node);
2038          *dest++ = node_forwarding_address(*src++);
2039          bits &= ~(BIT0_MASK >> bitidx);
2040          dnode++;
2041          bitidx++;
2042        }
2043      }
2044    }
2045  }
2046  return ptr_to_lispobj(dest);
2047}
2048
2049
2050
2051
2052
2053     
2054   
2055/*
2056  Total the (physical) byte sizes of all ivectors in the indicated memory range
2057*/
2058
2059natural
2060unboxed_bytes_in_range(LispObj *start, LispObj *end)
2061{
2062  natural total=0, elements, tag, subtag, bytes;
2063  LispObj header;
2064
2065  while (start < end) {
2066    header = *start;
2067    tag = fulltag_of(header);
2068   
2069    if ((nodeheader_tag_p(tag)) ||
2070        (immheader_tag_p(tag))) {
2071      elements = header_element_count(header);
2072      if (nodeheader_tag_p(tag)) {
2073        start += ((elements+2) & ~1);
2074      } else {
2075        subtag = header_subtag(header);
2076
2077#ifdef X8664
2078        switch(fulltag_of(header)) {
2079        case ivector_class_64_bit:
2080          bytes = 8 + (elements<<3);
2081          break;
2082        case ivector_class_32_bit:
2083          bytes = 8 + (elements<<2);
2084          break;
2085        case ivector_class_other_bit:
2086        default:
2087          if (subtag == subtag_bit_vector) {
2088            bytes = 8 + ((elements+7)>>3);
2089          } else if (subtag >= min_8_bit_ivector_subtag) {
2090            bytes = 8 + elements;
2091          } else {
2092            bytes = 8 + (elements<<1);
2093          }
2094        }
2095#endif
2096#ifdef X8632
2097          if (subtag <= max_32_bit_ivector_subtag) {
2098            bytes = 4 + (elements<<2);
2099          } else if (subtag <= max_8_bit_ivector_subtag) {
2100            bytes = 4 + elements;
2101          } else if (subtag <= max_16_bit_ivector_subtag) {
2102            bytes = 4 + (elements<<1);
2103          } else if (subtag == subtag_double_float_vector) {
2104            bytes = 8 + (elements<<3);
2105          } else {
2106            bytes = 4 + ((elements+7)>>3);
2107          }
2108#endif
2109
2110        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
2111        total += bytes;
2112        start += (bytes >> node_shift);
2113      }
2114    } else {
2115      start += 2;
2116    }
2117  }
2118  return total;
2119}
2120
2121
2122/*
2123  This assumes that it's getting called with a simple-{base,general}-string
2124  or code vector as an argument and that there's room for the object in the
2125  destination area.
2126*/
2127
2128
2129LispObj
2130purify_displaced_object(LispObj obj, area *dest, natural disp)
2131{
2132  BytePtr
2133    free = dest->active,
2134    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
2135  LispObj
2136    header = header_of(obj), 
2137    new;
2138  natural
2139    start = (natural)old,
2140    physbytes;
2141
2142  physbytes = ((natural)(skip_over_ivector(start,header))) - start;
2143
2144  dest->active += physbytes;
2145
2146  new = ptr_to_lispobj(free)+disp;
2147
2148  memcpy(free, (BytePtr)old, physbytes);
2149  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
2150  /* Actually, it's best to always leave a trail, for two reasons.
2151     a) We may be walking the same heap that we're leaving forwaring
2152     pointers in, so we don't want garbage that we leave behind to
2153     look like a header.
2154     b) We'd like to be able to forward code-vector locatives, and
2155     it's easiest to do so if we leave a {forward_marker, dnode_locative}
2156     pair at every doubleword in the old vector.
2157     */
2158  while(physbytes) {
2159    *old++ = (BytePtr) forward_marker;
2160    *old++ = (BytePtr) free;
2161    free += dnode_size;
2162    physbytes -= dnode_size;
2163  }
2164  return new;
2165}
2166
2167LispObj
2168purify_object(LispObj obj, area *dest)
2169{
2170  return purify_displaced_object(obj, dest, fulltag_of(obj));
2171}
2172
2173Boolean
2174copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest)
2175{
2176  LispObj obj = *ref, header, new;
2177  natural tag = fulltag_of(obj), header_tag;
2178  Boolean changed = false;
2179
2180  if ((tag == fulltag_misc) &&
2181      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
2182      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
2183    header = deref(obj, 0);
2184    if (header == forward_marker) { /* already copied */
2185      *ref = (untag(deref(obj,1)) + tag);
2186      changed = true;
2187    } else {
2188      header_tag = fulltag_of(header);
2189      if (immheader_tag_p(header_tag)) {
2190        if (header_subtag(header) != subtag_macptr) {
2191          new = purify_object(obj, dest);
2192          *ref = new;
2193          changed = (new != obj);
2194        }
2195      }
2196    }
2197  }
2198  return changed;
2199}
2200
2201
2202void
2203purify_gcable_ptrs(BytePtr low, BytePtr high, area *to)
2204{
2205  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2206
2207  while ((*prev) != (LispObj)NULL) {
2208    copy_ivector_reference(prev, low, high, to);
2209    next = *prev;
2210    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2211  }
2212}
2213
2214void 
2215purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
2216{
2217  while (start < end) { 
2218    copy_ivector_reference(start, low, high, to);
2219    start++;
2220  }
2221}
2222   
2223void
2224purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to)
2225{
2226  LispObj header;
2227  unsigned tag;
2228  natural nwords;
2229  hash_table_vector_header *hashp;
2230
2231  while (start < end) {
2232    header = *start;
2233    if (header == forward_marker) {
2234      start += 2;
2235    } else {
2236      tag = fulltag_of(header);
2237      if (immheader_tag_p(tag)) {
2238        start = (LispObj *)skip_over_ivector((natural)start, header);
2239      } else if (nodeheader_tag_p(tag)) {
2240        nwords = header_element_count(header);
2241        nwords += (1 - (nwords&1));
2242        if ((header_subtag(header) == subtag_hash_vector) &&
2243          ((((hash_table_vector_header *)start)->flags) & 
2244           nhash_track_keys_mask)) {
2245          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2246
2247          hashp = (hash_table_vector_header *) start;
2248          start++;
2249          nwords -= skip;
2250          while(skip--) {
2251            copy_ivector_reference(start, low, high, to);
2252            start++;
2253          }
2254          /* "nwords" is odd at this point: there are (floor nwords 2)
2255             key/value pairs to look at, and then an extra word for
2256             alignment.  Process them two at a time, then bump "start"
2257             past the alignment word. */
2258          nwords >>= 1;
2259          while(nwords--) {
2260            if (copy_ivector_reference(start, low, high, to) && hashp) {
2261              hashp->flags |= nhash_key_moved_mask;
2262              hashp = NULL;
2263            }
2264            start++;
2265            copy_ivector_reference(start, low, high, to);
2266            start++;
2267          }
2268          *start++ = 0;
2269        } else {
2270          if (header_subtag(header) == subtag_function) {
2271#ifdef X8632
2272            int skip = (unsigned short)(start[1]);
2273#else
2274            int skip = (int)(start[1]);
2275#endif
2276            start += skip;
2277            nwords -= skip;
2278          }
2279          start++;
2280          while(nwords--) {
2281            copy_ivector_reference(start, low, high, to);
2282            start++;
2283          }
2284        }
2285      } else {
2286        /* Not a header, just a cons cell */
2287        copy_ivector_reference(start, low, high, to);
2288        start++;
2289        copy_ivector_reference(start, low, high, to);
2290        start++;
2291      }
2292    }
2293  }
2294}
2295       
2296/* Purify references from tstack areas */
2297void
2298purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to)
2299{
2300  LispObj
2301    *current,
2302    *next,
2303    *start = (LispObj *) (a->active),
2304    *end = start,
2305    *limit = (LispObj *) (a->high);
2306
2307  for (current = start;
2308       end != limit;
2309       current = next) {
2310    next = (LispObj *) ptr_from_lispobj(*current);
2311    end = ((next >= start) && (next < limit)) ? next : limit;
2312    purify_range(current+2, end, low, high, to);
2313  }
2314}
2315
2316/* Purify a vstack area */
2317void
2318purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to)
2319{
2320  LispObj
2321    *p = (LispObj *) a->active,
2322    *q = (LispObj *) a->high;
2323 
2324  purify_headerless_range(p, q, low, high, to);
2325}
2326
2327
2328void
2329purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to)
2330{
2331  natural *regs = (natural *) xpGPRvector(xp);
2332
2333
2334#ifdef X8664
2335  copy_ivector_reference(&(regs[Iarg_z]), low, high, to);
2336  copy_ivector_reference(&(regs[Iarg_y]), low, high, to);
2337  copy_ivector_reference(&(regs[Iarg_x]), low, high, to);
2338  copy_ivector_reference(&(regs[Isave3]), low, high, to);
2339  copy_ivector_reference(&(regs[Isave2]), low, high, to);
2340  copy_ivector_reference(&(regs[Isave1]), low, high, to);
2341  copy_ivector_reference(&(regs[Isave0]), low, high, to);
2342  copy_ivector_reference(&(regs[Ifn]), low, high, to);
2343  copy_ivector_reference(&(regs[Itemp0]), low, high, to);
2344  copy_ivector_reference(&(regs[Itemp1]), low, high, to);
2345  copy_ivector_reference(&(regs[Itemp2]), low, high, to);
2346#if 0
2347  purify_locref(&(regs[Iip]), low, high, to);
2348#endif
2349#else
2350#endif
2351}
2352
2353void
2354purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to)
2355{
2356  natural n = tcr->tlb_limit;
2357  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2358
2359  purify_range(start, end, low, high, to);
2360}
2361
2362void
2363purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to)
2364{
2365  xframe_list *xframes;
2366  ExceptionInformation *xp;
2367 
2368  xp = tcr->gc_context;
2369  if (xp) {
2370    purify_xp(xp, low, high, to);
2371  }
2372
2373  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2374    purify_xp(xframes->curr, low, high, to);
2375  }
2376}
2377
2378
2379void
2380purify_areas(BytePtr low, BytePtr high, area *target)
2381{
2382  area *next_area;
2383  area_code code;
2384     
2385  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2386    switch (code) {
2387    case AREA_TSTACK:
2388      purify_tstack_area(next_area, low, high, target);
2389      break;
2390     
2391    case AREA_VSTACK:
2392      purify_vstack_area(next_area, low, high, target);
2393      break;
2394     
2395    case AREA_CSTACK:
2396      break;
2397     
2398    case AREA_STATIC:
2399    case AREA_DYNAMIC:
2400      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target);
2401      break;
2402     
2403    default:
2404      break;
2405    }
2406  }
2407}
2408
2409/*
2410  So far, this is mostly for save_application's benefit.
2411  We -should- be able to return to lisp code after doing this,
2412  however.
2413
2414*/
2415
2416
2417signed_natural
2418purify(TCR *tcr, signed_natural param)
2419{
2420  extern area *extend_readonly_area(unsigned);
2421  area
2422    *a = active_dynamic_area,
2423    *new_pure_area;
2424
2425  TCR  *other_tcr;
2426  natural max_pure_size;
2427  BytePtr new_pure_start,
2428    low = (a->low + (static_dnodes_for_area(a) << dnode_shift)),
2429    high = a->active;
2430
2431
2432  max_pure_size = unboxed_bytes_in_range((LispObj *) low, (LispObj *) high);
2433  new_pure_area = extend_readonly_area(max_pure_size);
2434  if (new_pure_area) {
2435    new_pure_start = new_pure_area->active;
2436    lisp_global(IN_GC) = (1<<fixnumshift);
2437
2438    /*
2439
2440       
2441      Make the new_pure_area executable, just in case.
2442
2443      Caller will typically GC again (and that should recover quite a bit of
2444      the dynamic heap.)
2445      */
2446
2447
2448   
2449    purify_areas(low, high, new_pure_area);
2450   
2451    other_tcr = tcr;
2452    do {
2453      purify_tcr_xframes(other_tcr, low, high, new_pure_area);
2454      purify_tcr_tlb(other_tcr, low, high, new_pure_area);
2455      other_tcr = other_tcr->next;
2456    } while (other_tcr != tcr);
2457
2458    purify_gcable_ptrs(low, high, new_pure_area);
2459    {
2460      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
2461      if (puresize != 0) {
2462        xMakeDataExecutable(new_pure_start, puresize);
2463 
2464      }
2465    }
2466    ProtectMemory(new_pure_area->low,
2467                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
2468                                      log2_page_size));
2469    lisp_global(IN_GC) = 0;
2470    just_purified_p = true;
2471    return 0;
2472  }
2473  return -1;
2474}
2475
2476
2477 
2478Boolean
2479impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
2480{
2481  LispObj q = *p;
2482 
2483  if (is_node_fulltag(fulltag_of(q)) &&
2484      (q >= low) && 
2485      (q < high)) {
2486    *p = (q+delta);
2487    return true;
2488  }
2489  return false;
2490}
2491 
2492
2493void
2494impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta)
2495{
2496  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;
2497
2498  while ((*prev) != (LispObj)NULL) {
2499    impurify_noderef(prev, low, high, delta);
2500    next = *prev;
2501    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
2502  }
2503}
2504
2505
2506void
2507impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta)
2508{
2509  natural *regs = (natural *) xpGPRvector(xp);
2510
2511
2512#ifdef X8664
2513  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
2514  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
2515  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
2516#ifndef WINDOWS
2517  impurify_noderef(&(regs[Isave3]), low, high, delta);
2518#endif
2519  impurify_noderef(&(regs[Isave2]), low, high, delta);
2520  impurify_noderef(&(regs[Isave1]), low, high, delta);
2521  impurify_noderef(&(regs[Isave0]), low, high, delta);
2522  impurify_noderef(&(regs[Ifn]), low, high, delta);
2523  impurify_noderef(&(regs[Itemp0]), low, high, delta);
2524  impurify_noderef(&(regs[Itemp1]), low, high, delta);
2525#if 0
2526  impurify_locref(&(regs[Iip]), low, high, delta);
2527#endif
2528#else
2529#endif
2530
2531}
2532
2533void
2534impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2535{
2536  while (start < end) {
2537    impurify_noderef(start, low, high, delta);
2538    start++;
2539  }
2540}
2541
2542
2543void
2544impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta)
2545{
2546  LispObj header;
2547  unsigned tag;
2548  natural nwords;
2549  hash_table_vector_header *hashp;
2550
2551  while (start < end) {
2552    header = *start;
2553    if (header == forward_marker) {
2554      start += 2;
2555    } else {
2556      tag = fulltag_of(header);
2557      if (immheader_tag_p(tag)) {
2558        start = (LispObj *)skip_over_ivector((natural)start, header);
2559      } else if (nodeheader_tag_p(tag)) {
2560        nwords = header_element_count(header);
2561        nwords += (1 - (nwords&1));
2562        if ((header_subtag(header) == subtag_hash_vector) &&
2563          ((((hash_table_vector_header *)start)->flags) & 
2564           nhash_track_keys_mask)) {
2565          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
2566
2567          hashp = (hash_table_vector_header *) start;
2568          start++;
2569          nwords -= skip;
2570          while(skip--) {
2571            impurify_noderef(start, low, high, delta);
2572            start++;
2573          }
2574          /* "nwords" is odd at this point: there are (floor nwords 2)
2575             key/value pairs to look at, and then an extra word for
2576             alignment.  Process them two at a time, then bump "start"
2577             past the alignment word. */
2578          nwords >>= 1;
2579          while(nwords--) {
2580            if (impurify_noderef(start, low, high, delta) && hashp) {
2581              hashp->flags |= nhash_key_moved_mask;
2582              hashp = NULL;
2583            }
2584            start++;
2585            impurify_noderef(start, low, high, delta);
2586            start++;
2587          }
2588          *start++ = 0;
2589        } else {
2590          if (header_subtag(header) == subtag_function) {
2591            int skip = (int)(start[1]);
2592            start += skip;
2593            nwords -= skip;
2594          }
2595          start++;
2596          while(nwords--) {
2597            impurify_noderef(start, low, high, delta);
2598            start++;
2599          }
2600        }
2601      } else {
2602        /* Not a header, just a cons cell */
2603        impurify_noderef(start, low, high, delta);
2604        start++;
2605        impurify_noderef(start, low, high, delta);
2606        start++;
2607      }
2608    }
2609  }
2610}
2611
2612
2613
2614
2615void
2616impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, signed_natural delta)
2617{
2618  unsigned n = tcr->tlb_limit;
2619  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
2620 
2621  impurify_range(start, end, low, high, delta);
2622}
2623
2624void
2625impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta)
2626{
2627  xframe_list *xframes;
2628  ExceptionInformation *xp;
2629 
2630  xp = tcr->gc_context;
2631  if (xp) {
2632    impurify_xp(xp, low, high, delta);
2633  }
2634
2635  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
2636    impurify_xp(xframes->curr, low, high, delta);
2637  }
2638}
2639
2640void
2641impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2642{
2643  LispObj
2644    *current,
2645    *next,
2646    *start = (LispObj *) (a->active),
2647    *end = start,
2648    *limit = (LispObj *) (a->high);
2649
2650  for (current = start;
2651       end != limit;
2652       current = next) {
2653    next = (LispObj *) ptr_from_lispobj(*current);
2654    end = ((next >= start) && (next < limit)) ? next : limit;
2655    if (current[1] == 0) {
2656      impurify_range(current+2, end, low, high, delta);
2657    }
2658  }
2659}
2660void
2661impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta)
2662{
2663  LispObj
2664    *p = (LispObj *) a->active,
2665    *q = (LispObj *) a->high;
2666
2667  impurify_headerless_range(p, q, low, high, delta);
2668}
2669
2670
2671void
2672impurify_areas(LispObj low, LispObj high, signed_natural delta)
2673{
2674  area *next_area;
2675  area_code code;
2676     
2677  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
2678    switch (code) {
2679    case AREA_TSTACK:
2680      impurify_tstack_area(next_area, low, high, delta);
2681      break;
2682     
2683    case AREA_VSTACK:
2684      impurify_vstack_area(next_area, low, high, delta);
2685      break;
2686     
2687    case AREA_CSTACK:
2688      break;
2689     
2690    case AREA_STATIC:
2691    case AREA_DYNAMIC:
2692      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
2693      break;
2694     
2695    default:
2696      break;
2697    }
2698  }
2699}
2700
2701signed_natural
2702impurify(TCR *tcr, signed_natural param)
2703{
2704  area *r = find_readonly_area();
2705
2706  if (r) {
2707    area *a = active_dynamic_area;
2708    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
2709      oldhigh = a->high, newhigh; 
2710    unsigned n = ro_limit - ro_base;
2711    signed_natural delta = oldfree-ro_base;
2712    TCR *other_tcr;
2713
2714    if (n) {
2715      lisp_global(IN_GC) = 1;
2716      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
2717                                               log2_heap_segment_size));
2718      if (newhigh > oldhigh) {
2719        grow_dynamic_area(newhigh-oldhigh);
2720      }
2721      a->active += n;
2722      memmove(oldfree, ro_base, n);
2723      UnMapMemory((void *)ro_base, n);
2724      a->ndnodes = area_dnode(a, a->active);
2725      pure_space_active = r->active = r->low;
2726      r->ndnodes = 0;
2727
2728      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2729
2730      other_tcr = tcr;
2731      do {
2732        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2733        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2734        other_tcr = other_tcr->next;
2735      } while (other_tcr != tcr);
2736
2737      impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
2738      lisp_global(IN_GC) = 0;
2739    }
2740    return 0;
2741  }
2742  return -1;
2743}
Note: See TracBrowser for help on using the repository browser.