source: branches/gb-egc/lisp-kernel/gc-common.c @ 15827

Last change on this file since 15827 was 15827, checked in by gb, 8 years ago

Make refidx optional when walking refidx_state;
Clear "nextbit" in oldbits, not uninitialized "bitidx".

File size: 53.0 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lisp.h"
19#include "lisp_globals.h"
20#include "bits.h"
21#include "gc.h"
22#include "area.h"
23#include "threads.h"
24#include <stddef.h>
25#include <stdlib.h>
26#include <string.h>
27
28#ifndef WINDOWS
29#include <sys/time.h>
30#endif
31
32#ifndef timeradd
33# define timeradd(a, b, result)                                               \
34  do {                                                                        \
35    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
36    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
37    if ((result)->tv_usec >= 1000000)                                         \
38      {                                                                       \
39        ++(result)->tv_sec;                                                   \
40        (result)->tv_usec -= 1000000;                                         \
41      }                                                                       \
42  } while (0)
43#endif
44#ifndef timersub
45# define timersub(a, b, result)                                               \
46  do {                                                                        \
47    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
48    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
49    if ((result)->tv_usec < 0) {                                              \
50      --(result)->tv_sec;                                                     \
51      (result)->tv_usec += 1000000;                                           \
52    }                                                                         \
53  } while (0)
54#endif
55
56void
57comma_output_decimal(char *buf, int len, natural n) 
58{
59  int nout = 0;
60
61  buf[--len] = 0;
62  do {
63    buf[--len] = n%10+'0';
64    n = n/10;
65    if (n == 0) {
66      while (len) {
67        buf[--len] = ' ';
68      }
69      return;
70    }
71    if (len == 0) return;
72    nout ++;
73    if (nout == 3) {
74      buf[--len] = ',';
75      nout = 0;
76    }
77  } while (len >= 0);
78}
79
80
81natural
82static_dnodes_for_area(area *a)
83{
84  if (a->low == tenured_area->low) {
85    return tenured_area->static_dnodes;
86  }
87  return 0;
88}
89
90Boolean GCDebug = false, GCverbose = false;
91bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL, managed_static_refbits = NULL;
92LispObj GCarealow = 0, GCareadynamiclow = 0;
93natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0;
94LispObj GCweakvll = (LispObj)NULL;
95LispObj GCdwsweakvll = (LispObj)NULL;
96LispObj GCephemeral_low = 0;
97natural GCn_ephemeral_dnodes = 0;
98natural GCstack_limit = 0;
99
100void
101check_static_cons_freelist(char *phase)
102{
103  LispObj
104    n,
105    base = (LispObj)static_cons_area->low, 
106    limit = static_cons_area->ndnodes;
107  natural i=0;
108
109  for (n=lisp_global(STATIC_CONSES);n!=lisp_nil;n=((cons *)untag(n))->cdr, i++) {
110    if ((fulltag_of(n) != fulltag_cons) ||
111        (area_dnode(n,base) >= limit)) {
112      Bug(NULL, "%s: static cons freelist has invalid element 0x" LISP "\n",
113          phase, i);
114    }
115  }
116}
117
118void
119reapweakv(LispObj weakv)
120{
121  /*
122    element 2 of the weak vector should be tagged as a cons: if it
123    isn't, just mark it as a root.  if it is, cdr through it until a
124    "marked" cons is encountered.  If the car of any unmarked cons is
125    marked, mark the cons which contains it; otherwise, splice the
126    cons out of the list.  N.B. : elements 0 and 1 are already marked
127    (or are immediate, etc.)
128  */
129  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
130  LispObj termination_list = lisp_nil;
131  natural weak_type = (natural) deref(weakv,2);
132  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
133    terminatablep = ((weak_type >> population_termination_bit) != 0);
134  Boolean done = false;
135  cons *rawcons;
136  natural dnode, car_dnode;
137  bitvector markbits = GCmarkbits;
138
139  if (terminatablep) {
140    termination_list = deref(weakv,1+3);
141  }
142
143  if (fulltag_of(cell) != fulltag_cons) {
144    mark_root(cell);
145  } else if (alistp) {
146    /* weak alist */
147    while (! done) {
148      dnode = gc_area_dnode(cell);
149      if ((dnode >= GCndnodes_in_area) ||
150          (ref_bit(markbits, dnode))) {
151        done = true;
152      } else {
153        /* Cons cell is unmarked. */
154        LispObj alist_cell, thecar;
155        unsigned cell_tag;
156
157        rawcons = (cons *) ptr_from_lispobj(untag(cell));
158        alist_cell = rawcons->car;
159        cell_tag = fulltag_of(alist_cell);
160
161        if ((cell_tag == fulltag_cons) &&
162            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
163            (! ref_bit(markbits, car_dnode)) &&
164            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
165            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
166            (! ref_bit(markbits, car_dnode))) {
167          *prev = rawcons->cdr;
168          if (terminatablep) {
169            rawcons->cdr = termination_list;
170            termination_list = cell;
171          }
172        } else {
173          set_bit(markbits, dnode);
174          prev = (LispObj *)(&(rawcons->cdr));
175          mark_root(alist_cell);
176        }
177        cell = *prev;
178      }
179    }
180  } else {
181    /* weak list */
182    while (! done) {
183      dnode = gc_area_dnode(cell);
184      if ((dnode >= GCndnodes_in_area) ||
185          (ref_bit(markbits, dnode))) {
186        done = true;
187      } else {
188        /* Cons cell is unmarked. */
189        LispObj thecar;
190        unsigned cartag;
191
192        rawcons = (cons *) ptr_from_lispobj(untag(cell));
193        thecar = rawcons->car;
194        cartag = fulltag_of(thecar);
195
196        if (is_node_fulltag(cartag) &&
197            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
198            (! ref_bit(markbits, car_dnode))) {
199          *prev = rawcons->cdr;
200          if (terminatablep) {
201            rawcons->cdr = termination_list;
202            termination_list = cell;
203          }
204        } else {
205          set_bit(markbits, dnode);
206          prev = (LispObj *)(&(rawcons->cdr));
207        }
208        cell = *prev;
209      }
210    }
211  }
212
213  if (terminatablep) {
214    deref(weakv,1+3) = termination_list;
215  }
216  if (termination_list != lisp_nil) {
217    deref(weakv,1) = GCweakvll;
218    GCweakvll = untag(weakv);
219  } else {
220    deref(weakv,1) = lisp_global(WEAKVLL);
221    lisp_global(WEAKVLL) = untag(weakv);
222  }
223}
224
225/*
226  Screw: doesn't deal with finalization.
227  */
228
229void
230reaphashv(LispObj hashv)
231{
232  hash_table_vector_header
233    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
234  natural
235    dnode;
236  signed_natural
237    npairs = (header_element_count(hashp->header) - 
238              (hash_table_vector_header_count -1)) >> 1;
239  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
240  int weak_index = (((hashp->flags & nhash_weak_value_mask) == 0) ? 0 : 1);
241  Boolean
242    keys_frozen = ((hashp->flags & nhash_keys_frozen_mask) != 0);
243  // Probably no reason why the non-keys_frozen case couldn't use slot_unbound as well,
244  // but I don't want to risk it.
245  LispObj empty_value = (keys_frozen ? slot_unbound : lisp_nil);
246  bitvector markbits = GCmarkbits;
247  int tag;
248
249  natural *tenured_low = (LispObj *)tenured_area->low;
250  natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
251  natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+weak_index), tenured_low);
252  Boolean
253    hashv_tenured = (memo_dnode < tenured_dnodes);
254  natural bits, bitidx, *bitsp;
255
256  if (hashv_tenured) {
257    set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx);
258  }
259
260  while (true) {
261    if (hashv_tenured) {
262      while (bits == 0) {
263        int skip = nbits_in_word - bitidx;
264        npairs -= skip;
265        if (npairs <= 0) break;
266        pairp += (skip+skip);
267        bitidx = 0;
268        bits = *++bitsp;
269      }
270      if (bits != 0) {
271        int skip = (count_leading_zeros(bits) - bitidx);
272        if (skip != 0) {
273          npairs -= skip;
274          pairp += (skip+skip);
275          bitidx += skip;
276        }
277      }
278    }
279
280    if (npairs <= 0) break;
281
282    weakelement = pairp[weak_index];
283    tag = fulltag_of(weakelement);
284    if (is_node_fulltag(tag)) {
285      dnode = gc_area_dnode(weakelement);
286      if ((dnode < GCndnodes_in_area) && 
287          ! ref_bit(markbits, dnode)) {
288        pairp[0] = slot_unbound;
289        pairp[1] = empty_value;
290        hashp->count += (1<<fixnumshift);
291        if (!keys_frozen) {
292          hashp->deleted_count += (1<<fixnumshift);
293        }
294      }
295    }
296    pairp += 2;
297    --npairs;
298  }
299  deref(hashv, 1) = lisp_global(WEAKVLL);
300  lisp_global(WEAKVLL) = untag(hashv);
301}
302
303void
304traditional_dws_mark_htabv(LispObj htabv)
305{
306  /* Do nothing, just add htabv to GCweakvll */
307  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
308
309  base[1] = GCweakvll;
310  GCweakvll = ptr_to_lispobj(base);
311}
312
313void
314ncircle_dws_mark_htabv(LispObj htabv)
315{
316  /* Do nothing, just add htabv to GCdwsweakvll */
317  deref(htabv,1) = GCdwsweakvll;
318  GCdwsweakvll = htabv;
319}
320
321void
322traditional_mark_weak_htabv(LispObj htabv)
323{
324  int i, skip = hash_table_vector_header_count;;
325  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
326
327  for (i = 2; i <= skip; i++) {
328    rmark(base[i]);
329  }
330  base[1] = GCweakvll;
331  GCweakvll = ptr_to_lispobj(base);
332}
333
334void
335ncircle_mark_weak_htabv(LispObj htabv)
336{
337  int i, skip = hash_table_vector_header_count;
338  hash_table_vector_header *hashp = (hash_table_vector_header *)(untag(htabv));
339  natural
340    npairs = (header_element_count(hashp->header) - 
341              (hash_table_vector_header_count - 1)) >> 1;
342  LispObj *pairp = (LispObj*) (hashp+1);
343  Boolean
344    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
345
346
347  for (i = 2; i <= skip; i++) {
348    rmark(deref(htabv,i));
349  }
350 
351  if (!weak_on_value) {
352    pairp++;
353  }
354  /* unconditionally mark the non-weak element of each pair */
355  while (npairs--) {
356    rmark(*pairp);
357    pairp += 2;
358  }
359  deref(htabv,1)  = GCweakvll;
360  GCweakvll = (LispObj)untag(htabv);
361}
362
363
364Boolean
365mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
366{
367  natural flags = hashp->flags, weak_dnode, nonweak_dnode;
368  Boolean
369    marked_new = false, 
370    weak_marked;
371  int non_weak_index = (((flags & nhash_weak_value_mask) != 0) ? 0 : 1);
372  int 
373    skip = hash_table_vector_header_count-1,
374    weak_tag,
375    nonweak_tag,
376    i;
377  signed_natural
378    npairs = (elements - skip) >> 1;
379  LispObj
380    *pairp = (LispObj*) (hashp+1),
381    weak,
382    nonweak;
383
384  natural *tenured_low = (LispObj *)tenured_area->low;
385  natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
386  natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+non_weak_index), tenured_low);
387  Boolean hashv_tenured = (memo_dnode < tenured_dnodes);
388  natural bits, bitidx, *bitsp;
389
390  if (hashv_tenured) {
391    set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx);
392  }
393
394  /* Mark everything in the header */
395 
396  for (i = 2; i<= skip; i++) {
397    mark_root(deref(ptr_to_lispobj(hashp),i));
398  }
399
400  while (true) {
401    if (hashv_tenured) {
402      while (bits == 0) {
403        int skip = nbits_in_word - bitidx;
404        npairs -= skip;
405        if (npairs <= 0) break;
406        pairp += (skip+skip);
407        bitidx = 0;
408        bits = *++bitsp;
409      }
410      if (bits != 0) {
411        int skip = count_leading_zeros(bits) - bitidx;
412        if (skip != 0) {
413          npairs -= skip;
414          pairp += (skip+skip);
415          bitidx += skip;
416        }
417      }
418    }
419    if (npairs <= 0) break;
420
421    nonweak = pairp[non_weak_index];
422    weak = pairp[1-non_weak_index];
423
424    nonweak_tag = fulltag_of(nonweak);
425    if (is_node_fulltag(nonweak_tag)) {
426      nonweak_dnode = gc_area_dnode(nonweak);
427      if ((nonweak_dnode < GCndnodes_in_area) &&
428          ! ref_bit(GCmarkbits,nonweak_dnode)) {
429        weak_marked = true;
430        weak_tag = fulltag_of(weak);
431        if (is_node_fulltag(weak_tag)) {
432          weak_dnode = gc_area_dnode(weak);
433          if ((weak_dnode < GCndnodes_in_area) &&
434              ! ref_bit(GCmarkbits, weak_dnode)) {
435            weak_marked = false;
436          }
437        }
438        if (weak_marked) {
439          mark_root(nonweak);
440          marked_new = true;
441        }
442      }
443    }
444
445    pairp+=2;
446    --npairs;
447  }
448  return marked_new;
449}
450
451
452Boolean
453mark_weak_alist(LispObj weak_alist, int weak_type)
454{
455  natural
456    elements = header_element_count(header_of(weak_alist)),
457    dnode;
458  int pair_tag;
459  Boolean marked_new = false;
460  LispObj alist, pair, key, value;
461  bitvector markbits = GCmarkbits;
462
463  if (weak_type >> population_termination_bit) {
464    elements -= 1;
465  }
466  for(alist = deref(weak_alist, elements);
467      (fulltag_of(alist) == fulltag_cons) &&
468      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
469      (! ref_bit(markbits,dnode));
470      alist = cdr(alist)) {
471    pair = car(alist);
472    pair_tag = fulltag_of(pair);
473    if ((is_node_fulltag(pair_tag)) &&
474        ((dnode = gc_area_dnode(pair)) < GCndnodes_in_area) &&
475        (! ref_bit(markbits,dnode))) {
476      if (pair_tag == fulltag_cons) {
477        key = car(pair);
478        if ((! is_node_fulltag(fulltag_of(key))) ||
479            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
480            ref_bit(markbits,dnode)) {
481          /* key is marked, mark value if necessary */
482          value = cdr(pair);
483          if (is_node_fulltag(fulltag_of(value)) &&
484              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
485              (! ref_bit(markbits,dnode))) {
486            mark_root(value);
487            marked_new = true;
488          }
489        }
490      } else {
491          mark_root(pair);
492          marked_new = true;
493      }
494    }
495  }
496  return marked_new;
497}
498 
499void
500mark_termination_lists()
501{
502  /*
503     Mark the termination lists in all terminatable weak vectors, which
504     are now linked together on GCweakvll, and add them to WEAKVLL,
505     which already contains all other weak vectors.
506  */
507  LispObj pending = GCweakvll,
508          *base = (LispObj *)NULL;
509
510  while (pending) {
511    base = ptr_from_lispobj(pending);
512    pending = base[1];
513
514    mark_root(base[1+3]);
515  }
516  if (base) {
517    base[1] = lisp_global(WEAKVLL);
518    lisp_global(WEAKVLL) = GCweakvll;
519  }
520
521}
522
523
524void
525traditional_markhtabvs()
526{
527  LispObj *base, this, header, pending;
528  int subtag;
529  hash_table_vector_header *hashp;
530  Boolean marked_new;
531
532  do {
533    pending = (LispObj) NULL;
534    marked_new = false;
535   
536    while (GCweakvll) {
537      base = ptr_from_lispobj(GCweakvll);
538      GCweakvll = base[1];
539     
540      header = base[0];
541      subtag = header_subtag(header);
542     
543      if (subtag == subtag_weak) {
544        natural weak_type = base[2];
545        this = ptr_to_lispobj(base) + fulltag_misc;
546        base[1] = pending;
547        pending = ptr_to_lispobj(base);
548        if ((weak_type & population_type_mask) == population_weak_alist) {
549          if (mark_weak_alist(this, weak_type)) {
550            marked_new = true;
551          }
552        }
553      } else if (subtag == subtag_hash_vector) {
554        natural elements = header_element_count(header);
555
556        hashp = (hash_table_vector_header *) base;
557        if (hashp->flags & nhash_weak_mask) {
558          base[1] = pending;
559          pending = ptr_to_lispobj(base);
560          if (mark_weak_hash_vector(hashp, elements)) {
561            marked_new = true;
562          }
563        } 
564      } else {
565        Bug(NULL, "Strange object on weak vector linked list: " LISP "\n", base);
566      }
567    }
568
569    if (marked_new) {
570      GCweakvll = pending;
571    }
572  } while (marked_new);
573
574  /* Now, everything's marked that's going to be,  and "pending" is a list
575     of populations and weak hash tables.  CDR down that list and free
576     anything that isn't marked.
577     */
578
579  while (pending) {
580    base = ptr_from_lispobj(pending);
581    pending = base[1];
582    base[1] = (LispObj)NULL;
583
584    this = ptr_to_lispobj(base) + fulltag_misc;
585
586    subtag = header_subtag(base[0]);
587    if (subtag == subtag_weak) {
588      reapweakv(this);
589    } else {
590      reaphashv(this);
591    }
592  }
593  mark_termination_lists();
594}
595
596void
597ncircle_markhtabvs()
598{
599  LispObj *base, this, header, pending = 0;
600  int subtag;
601
602  /* First, process any weak hash tables that may have
603     been encountered by the link-inverting marker; we
604     should have more stack space now. */
605
606  while (GCdwsweakvll) {
607    this = GCdwsweakvll;
608    GCdwsweakvll = deref(this,1);
609    ncircle_mark_weak_htabv(this);
610  }
611
612  while (GCweakvll) {
613    base = ptr_from_lispobj(GCweakvll);
614    GCweakvll = base[1];
615    base[1] = (LispObj)NULL;
616
617    this = ptr_to_lispobj(base) + fulltag_misc;
618
619    header = base[0];
620    subtag = header_subtag(header);
621     
622    if (subtag == subtag_weak) {
623      natural weak_type = base[2];
624      base[1] = pending;
625      pending = ptr_to_lispobj(base);
626      if ((weak_type & population_type_mask) == population_weak_alist) {
627        mark_weak_alist(this, weak_type);
628      }
629    } else if (subtag == subtag_hash_vector) {
630      reaphashv(this);
631    }
632  }
633
634  /* Now, everything's marked that's going to be,  and "pending" is a list
635     of populations.  CDR down that list and free
636     anything that isn't marked.
637     */
638
639  while (pending) {
640    base = ptr_from_lispobj(pending);
641    pending = base[1];
642    base[1] = (LispObj)NULL;
643
644    this = ptr_to_lispobj(base) + fulltag_misc;
645
646    subtag = header_subtag(base[0]);
647    if (subtag == subtag_weak) {
648      reapweakv(this);
649    } else {
650      Bug(NULL, "Bad object on pending list: %s\n", this);
651    }
652  }
653
654  mark_termination_lists();
655}
656
657void
658mark_tcr_tlb(TCR *tcr)
659{
660  natural n = tcr->tlb_limit;
661  LispObj
662    *start = tcr->tlb_pointer,
663    *end = (LispObj *) ((BytePtr)start+n),
664    node;
665
666  while (start < end) {
667    node = *start;
668    if (node != no_thread_local_binding_marker) {
669      mark_root(node);
670    }
671    start++;
672  }
673}
674
675/*
676  Mark things that're only reachable through some (suspended) TCR.
677  (This basically means the tcr's gc_context and the exception
678  frames on its xframe_list.)
679*/
680
681void
682mark_tcr_xframes(TCR *tcr)
683{
684  xframe_list *xframes;
685  ExceptionInformation *xp;
686
687  xp = TCR_AUX(tcr)->gc_context;
688  if (xp) {
689#ifndef X8632
690    mark_xp(xp);
691#else
692    mark_xp(xp, tcr->node_regs_mask);
693#endif
694  }
695#ifdef X8632
696  mark_root(tcr->save0);
697  mark_root(tcr->save1);
698  mark_root(tcr->save2);
699  mark_root(tcr->save3);
700  mark_root(tcr->next_method_context);
701#endif
702 
703  for (xframes = (xframe_list *) tcr->xframe; 
704       xframes; 
705       xframes = xframes->prev) {
706#ifndef X8632
707      mark_xp(xframes->curr);
708#else
709      mark_xp(xframes->curr, xframes->node_regs_mask);
710#endif
711  }
712}
713     
714
715struct xmacptr *user_postGC_macptrs = NULL;
716
717
718
719void
720postGCfreexmacptr(struct xmacptr *p)
721{
722  p->link = (LispObj) user_postGC_macptrs;
723  user_postGC_macptrs = p;
724}
725
726
727xmacptr_dispose_fn xmacptr_dispose_functions[xmacptr_flag_user_last-xmacptr_flag_user_first];
728
729
730
731void
732freeGCptrs()
733{
734  void *p, *next, *addr;
735  struct xmacptr *x, *xnext;
736  int flags;
737  xmacptr_dispose_fn dfn;
738
739 
740  for (x = user_postGC_macptrs; x; x = xnext) {
741    xnext = (xmacptr *) (x->link);
742    flags = x->flags;
743    addr = (void *)x->address;
744    x->address = 0;
745    x->flags = 0;
746    x->link = 0;
747    x->class = 0;
748    if (addr) {
749      switch(flags) {
750      case xmacptr_flag_recursive_lock:
751        destroy_recursive_lock((RECURSIVE_LOCK)addr);
752        break;
753      case xmacptr_flag_ptr:
754        free(addr);
755        break;
756      case xmacptr_flag_none:   /* ?? */
757        break;
758      case xmacptr_flag_rwlock:
759        rwlock_destroy((rwlock *)addr);
760        break;
761      case xmacptr_flag_semaphore:
762        destroy_semaphore((void **)&addr);
763        break;
764      default:
765        if ((flags >= xmacptr_flag_user_first) &&
766            (flags < xmacptr_flag_user_last)) {
767          flags -= xmacptr_flag_user_first;
768          dfn = xmacptr_dispose_functions[flags];
769          if (dfn && addr) {
770            dfn(addr);
771          }
772        }
773      }
774    }
775  }
776
777  user_postGC_macptrs = NULL;
778}
779
780int
781register_xmacptr_dispose_function(void *dfn)
782{
783  int i, k;
784 
785  for( i = 0, k = xmacptr_flag_user_first; k < xmacptr_flag_user_last; i++, k++) {
786    if (xmacptr_dispose_functions[i]==NULL) {
787      xmacptr_dispose_functions[i] = dfn;
788      return k;
789    }
790    if (xmacptr_dispose_functions[i] == dfn) {
791      return k;
792    }
793  }
794  return 0;
795}
796
797void
798reap_gcable_ptrs()
799{
800  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
801  natural dnode;
802  xmacptr *x;
803
804  while((next = *prev) != (LispObj)NULL) {
805    dnode = gc_area_dnode(next);
806    x = (xmacptr *) ptr_from_lispobj(untag(next));
807
808    if ((dnode >= GCndnodes_in_area) ||
809        (ref_bit(GCmarkbits,dnode))) {
810      prev = &(x->link);
811    } else {
812      *prev = x->link;
813      ptr = x->address;
814
815      if (ptr) {
816        set_n_bits(GCmarkbits,dnode,3);
817        postGCfreexmacptr(x);
818      }
819    }
820  }
821}
822
823
824
825#if  WORD_SIZE == 64
826unsigned short *_one_bits = NULL;
827
828unsigned short
829logcount16(unsigned short n)
830{
831  unsigned short c=0;
832 
833  while(n) {
834    n = n & (n-1);
835    c++;
836  }
837  return c;
838}
839
840void
841gc_init()
842{
843  int i;
844 
845  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
846
847  for (i = 0; i < (1<<16); i++) {
848    _one_bits[i] = dnode_size*logcount16(i);
849  }
850}
851
852
853#else
854const unsigned char _one_bits[256] = {
855    0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,
856    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
857    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
858    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
859    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
860    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
861    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
862    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
863    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
864    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
865    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
866    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
867    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
868    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
869    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
870    4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8
871};
872
873
874void
875gc_init()
876{
877}
878
879#endif
880
881
882weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv;
883weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv;
884weak_process_fun markhtabvs = traditional_markhtabvs;
885
886void
887install_weak_mark_functions(natural set) {
888  switch(set) {
889  case 0:
890  default:
891    dws_mark_weak_htabv = traditional_dws_mark_htabv;
892    mark_weak_htabv = traditional_mark_weak_htabv;
893    markhtabvs = traditional_markhtabvs;
894    break;
895  case 1:
896    dws_mark_weak_htabv = ncircle_dws_mark_htabv;
897    mark_weak_htabv = ncircle_mark_weak_htabv;
898    markhtabvs = ncircle_markhtabvs;
899    break;
900  }
901}
902
903void
904init_weakvll ()
905{
906  LispObj this = lisp_global(WEAKVLL); /* all weak vectors as of last gc */
907
908  GCweakvll = (LispObj)NULL;
909  lisp_global(WEAKVLL) = (LispObj)NULL;
910
911  if (GCn_ephemeral_dnodes) {
912    /* For egc case, initialize GCweakvll with weak vectors not in the
913       GC area.  Weak vectors in the GC area will be added during marking.
914    */
915
916    LispObj *tenured_low = (LispObj *)tenured_area->low;
917    natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
918    bitvector refbits = tenured_area->refbits;
919
920    while (this) {
921      LispObj *base = ptr_from_lispobj(this);
922      LispObj next = base[1];
923      natural dnode = gc_dynamic_area_dnode(this);
924      if (dnode < GCndynamic_dnodes_in_area) {
925        base[1] = (LispObj)NULL; /* drop it, might be garbage */
926      } else {
927        base[1] = GCweakvll;
928        GCweakvll = ptr_to_lispobj(base);
929        if (header_subtag(base[0]) == subtag_weak) {
930          dnode = area_dnode(&base[3], tenured_low);
931          if (dnode < tenured_dnodes) {
932            clr_bit(refbits, dnode); /* Don't treat population.data as root */
933          }
934        } else {
935          if (header_subtag(base[0]) != subtag_hash_vector)
936            Bug(NULL, "Unexpected entry " LISP " -> " LISP " on WEAKVLL", base, base[0]);
937          dnode = area_dnode(base, tenured_low);
938          if ((dnode < tenured_dnodes) && !ref_bit(refbits, dnode)) {
939            Boolean drop = true;
940            /* hash vectors get marked headers if they have any ephemeral keys */
941            /* but not if they have ephemeral values. */
942            if (((hash_table_vector_header *)base)->flags & nhash_weak_value_mask) {
943              signed_natural count = (header_element_count(base[0]) + 2) >> 1;
944              natural bits, bitidx, *bitsp;
945              set_bitidx_vars(refbits, dnode, bitsp, bits, bitidx);
946              while ((0 < count) && (bits == 0)) {
947                int skip = nbits_in_word - bitidx;
948                count -= skip;
949                bits = *++bitsp;
950                bitidx = 0;
951              }
952              count -=  (count_leading_zeros(bits) - bitidx);
953
954              if (0 < count) {
955                set_bit(refbits, dnode); /* has ephemeral values, mark header */
956                drop = false;
957              }
958            }
959            if (drop) { /* if nothing ephemeral, drop it from GCweakvll. */
960              GCweakvll = base[1];
961              base[1] = lisp_global(WEAKVLL);
962              lisp_global(WEAKVLL) = ptr_to_lispobj(base);
963            }
964          }
965        }
966      }
967      this = next;
968    }
969  }
970}
971
972 
973void
974preforward_weakvll ()
975{
976  /* reset population refbits for forwarding */
977  if (GCn_ephemeral_dnodes) {
978    LispObj this = lisp_global(WEAKVLL);
979    LispObj *tenured_low = (LispObj *)tenured_area->low;
980    natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
981    bitvector refbits = tenured_area->refbits;
982
983    while (this) {
984      LispObj *base = ptr_from_lispobj(this);
985      if (header_subtag(base[0]) == subtag_weak) {
986        natural dnode = area_dnode(&base[3], tenured_low);
987        if (base[3] >= GCarealow) {
988          if (dnode < tenured_dnodes) {
989            set_bit(refbits, dnode);
990          }
991        }
992        /* might have set termination list to a new pointer */
993        if ((base[2] >> population_termination_bit) && (base[4] >= GCarealow)) {
994          if ((dnode + 1) < tenured_dnodes) {
995            set_bit(refbits, dnode+1);
996          }
997        }
998      }
999      this = base[1];
1000    }
1001  }
1002}
1003
1004
1005void
1006forward_weakvll_links()
1007{
1008  LispObj *ptr = &(lisp_global(WEAKVLL)), this, new, old;
1009
1010  while ((this = *ptr)) {
1011    old = this + fulltag_misc;
1012    new = node_forwarding_address(old);
1013    if (old != new) {
1014      *ptr = untag(new);
1015    }
1016    ptr = &(deref(new,1));
1017  }
1018}
1019
1020
1021
1022
1023
1024LispObj
1025node_forwarding_address(LispObj node)
1026{
1027  int tag_n;
1028  natural dnode = gc_dynamic_area_dnode(node);
1029
1030  if ((dnode >= GCndynamic_dnodes_in_area) ||
1031      (node < GCfirstunmarked)) {
1032    return node;
1033  }
1034
1035  tag_n = fulltag_of(node);
1036  if (!is_node_fulltag(tag_n)) {
1037    return node;
1038  }
1039
1040  return dnode_forwarding_address(dnode, tag_n);
1041}
1042
1043Boolean
1044update_noderef(LispObj *noderef)
1045{
1046  LispObj
1047    node = *noderef,
1048    new = node_forwarding_address(node);
1049
1050  if (new != node) {
1051    *noderef = new;
1052    return true;
1053  }
1054  return false;
1055}
1056
1057void
1058update_locref(LispObj *locref)
1059{
1060  LispObj
1061    obj = *locref,
1062    new = locative_forwarding_address(obj);
1063
1064  if (new != obj) {
1065    *locref = new;
1066  }
1067}
1068
1069void
1070forward_gcable_ptrs()
1071{
1072  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new;
1073  struct xmacptr **xprev, *xnext, *xnew;
1074
1075  while ((next = *prev) != (LispObj)NULL) {
1076    new = node_forwarding_address(next);
1077    if (new != next) {
1078      *prev = new;
1079    }
1080    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1081  }
1082  xprev = &user_postGC_macptrs;
1083  while ((xnext = *xprev)) {
1084    xnew = (struct xmacptr *)locative_forwarding_address((LispObj)xnext);
1085    if (xnew != xnext) {
1086      *xprev = xnew;
1087    }
1088    xprev = (struct xmacptr **)(&(xnext->link));
1089  }
1090}
1091
1092typedef struct {
1093  bitvector refidx;
1094  bitvector refbits;
1095  bitvector idxp;
1096  bitvector idxlimit;
1097  bitvector rangelimit;
1098  bitvector reflimit;
1099  bitvector refp;
1100  natural idx;
1101  bitvector idxbase;
1102} bitidx_state;
1103
1104natural *
1105next_refbits(bitidx_state *s)
1106{
1107  bitvector p, limit;
1108  natural idxbit, idx;
1109
1110  while (1) {
1111    p = s->refp;
1112    limit = s->rangelimit;
1113    while (p < limit) {
1114      if (*p) {
1115        s->refp = p+1;
1116        return p;
1117      }
1118      p++;
1119    }
1120    if (!s->refidx) {
1121      return NULL;
1122    }
1123    idx = s->idx;
1124    while (idx == 0) {
1125      if (s->idxp == s->idxlimit) {
1126        return NULL;
1127      }
1128      idx = *(s->idxp);
1129      if (idx) {
1130        s->idx = idx;
1131        s->idxbase = s->refbits + ((s->idxp - s->refidx) * (WORD_SIZE * (256 / WORD_SIZE)));
1132      }
1133      s->idxp++;
1134    }
1135    idxbit = count_leading_zeros(idx);
1136    s->idx &= ~(BIT0_MASK>>idxbit);
1137    p = s->idxbase + (idxbit * (256/WORD_SIZE));
1138    s->refp = p;
1139    s->rangelimit = p + (256/WORD_SIZE);
1140    if (s->reflimit < s->rangelimit) {
1141      s->rangelimit = s->reflimit;
1142    }
1143  }
1144}
1145
1146void
1147init_bitidx_state(bitidx_state *s, bitvector refidx, bitvector refbits, natural ndnodes) 
1148{
1149  s->refidx = refidx;
1150  s->refbits = refbits;
1151  s->idxp = refidx;
1152  s->idx = 0;
1153  s->refp = refbits;
1154  s->reflimit = refbits + ((ndnodes + (WORD_SIZE-1)) >> bitmap_shift);
1155  if (refidx == NULL) {
1156    s->idxlimit = NULL;
1157    s->rangelimit = s->reflimit;
1158  } else {
1159  s->idxlimit = refidx + ((((ndnodes + 255) >> 8) + (WORD_SIZE-1)) >> bitmap_shift);
1160    s->rangelimit = s->idxbase = NULL;
1161  }
1162}
1163
1164
1165void
1166forward_memoized_area(area *a, natural num_memo_dnodes, bitvector refbits, bitvector refidx)
1167{
1168  LispObj *p = (LispObj *) a->low, *pbase = p, x1, x2, new;
1169#ifdef ARM
1170  LispObj *p0 = p;
1171#endif
1172  natural bits, *bitsp, nextbit,  memo_dnode = 0, ref_dnode, hash_dnode_limit = 0;
1173  int tag_x1;
1174  hash_table_vector_header *hashp = NULL;
1175  Boolean header_p;
1176  bitidx_state state;
1177
1178
1179
1180
1181  if (num_memo_dnodes) {
1182    init_bitidx_state(&state, refidx, refbits, num_memo_dnodes);
1183    if (GCDebug) {
1184      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, refidx);
1185    }
1186
1187    /* This is pretty straightforward, but we have to note
1188       when we move a key in a hash table vector that wants
1189       us to tell it about that. */
1190   
1191    bits = 0;
1192    while (1) {
1193      if (bits == 0) {
1194        bitsp = next_refbits(&state);
1195        if (bitsp == NULL) {
1196          return;
1197        }
1198        bits = *bitsp;
1199        ref_dnode = (bitsp-refbits)<<bitmap_shift;
1200      }
1201      nextbit = count_leading_zeros(bits);
1202      bits &= ~(BIT0_MASK>>nextbit);
1203      memo_dnode = ref_dnode + nextbit;
1204      p = pbase+(memo_dnode*2);
1205      x1 = p[0];
1206      x2 = p[1];
1207      tag_x1 = fulltag_of(x1);
1208      header_p = (nodeheader_tag_p(tag_x1));
1209
1210      if (header_p &&
1211          (header_subtag(x1) == subtag_hash_vector)) {
1212        hashp = (hash_table_vector_header *) p;
1213        if (hashp->flags & nhash_track_keys_mask) {
1214          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
1215        } else {
1216          hashp = NULL;
1217        }
1218      }
1219      if (! header_p) {
1220        new = node_forwarding_address(x1);
1221        if (new != x1) {
1222          *p = new;
1223#ifdef ARM
1224          /* This is heuristic: the two words before P might be immediate
1225             data that just happens to look like a function header and
1226             an unboxed reference to p[0].  That's extremely unlikely,
1227             but close doesn't count ... Fix this. */
1228          if (p != p0) {
1229            if(header_subtag(p[-2]) == subtag_function) {
1230              /* Just updated the code vector; fix the entrypoint */
1231              if (p[-1] == (untag(x1)+fulltag_odd_fixnum)) {
1232                p[-1] = (untag(new)+fulltag_odd_fixnum);
1233              }
1234            }
1235          }
1236#endif
1237        }
1238      }
1239      p++;
1240     
1241      new = node_forwarding_address(x2);
1242      if (new != x2) {
1243        *p = new;
1244        if (memo_dnode < hash_dnode_limit) {
1245          /* If this code is reached, 'hashp' is non-NULL and pointing
1246             at the header of a hash_table_vector, and 'memo_dnode' identifies
1247             a pair of words inside the hash_table_vector.  It may be
1248             hard for program analysis tools to recognize that, but I
1249             believe that warnings about 'hashp' being NULL here can
1250             be safely ignored. */
1251          hashp->flags |= nhash_key_moved_mask;
1252          hash_dnode_limit = 0;
1253          hashp = NULL;
1254        }
1255      }
1256    }
1257  }
1258}
1259
1260void
1261forward_tcr_tlb(TCR *tcr)
1262{
1263  natural n = tcr->tlb_limit;
1264  LispObj
1265    *start = tcr->tlb_pointer, 
1266    *end = (LispObj *) ((BytePtr)start+n),
1267    node;
1268
1269  while (start < end) {
1270    node = *start;
1271    if (node != no_thread_local_binding_marker) {
1272      update_noderef(start);
1273    }
1274    start++;
1275  }
1276}
1277
1278void
1279reclaim_static_dnodes()
1280{
1281  natural nstatic = tenured_area->static_dnodes, 
1282    i, 
1283    bits, 
1284    bitnum,
1285    nfree = 0,
1286    nstatic_conses = area_dnode(static_cons_area->high, static_cons_area->low);
1287  cons *c = (cons *)tenured_area->low, *d;
1288  bitvector bitsp = GCmarkbits;
1289  LispObj head = lisp_global(STATIC_CONSES);
1290
1291  for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
1292    bits = *bitsp++;
1293    if (bits != ALL_ONES) {
1294      for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
1295        if (! (bits & (BIT0_MASK>>bitnum))) {
1296          d = c + bitnum;
1297          if (i < nstatic_conses) {               
1298            d->car = unbound;
1299            d->cdr = head;
1300            head = ((LispObj)d)+fulltag_cons;
1301            nfree++;
1302          } else {
1303            d->car = 0;
1304            d->cdr = 0;
1305          }
1306        }
1307      }
1308    }
1309  }
1310  lisp_global(STATIC_CONSES) = head;
1311  lisp_global(FREE_STATIC_CONSES)+=(nfree<<fixnumshift);
1312}
1313
1314Boolean
1315youngest_non_null_area_p (area *a)
1316{
1317  if (a->active == a->high) {
1318    return false;
1319  } else {
1320    for (a = a->younger; a; a = a->younger) {
1321      if (a->active != a->high) {
1322        return false;
1323      }
1324    }
1325  };
1326  return true;
1327}
1328
1329Boolean just_purified_p = false;
1330
1331/*
1332  All thread's stack areas have been "normalized", as
1333  has the dynamic heap.  (The "active" pointer in these areas
1334  matches the stack pointer/freeptr value at the time that
1335  the exception occurred.)
1336*/
1337
1338#define get_time(when) gettimeofday(&when, NULL)
1339
1340
1341
1342#ifdef FORCE_DWS_MARK
1343#warning recursive marker disabled for testing; remember to re-enable it
1344#endif
1345
1346
1347Boolean
1348mark_static_ref(LispObj n, BytePtr dynamic_start, natural ndynamic_dnodes)
1349{
1350  int tag_n = fulltag_of(n);
1351  natural dyn_dnode;
1352
1353  if (nodeheader_tag_p(tag_n)) {
1354    return (header_subtag(n) == subtag_hash_vector);
1355  }
1356 
1357  if (is_node_fulltag (tag_n)) {
1358    dyn_dnode = area_dnode(n, dynamic_start);
1359    if (dyn_dnode < ndynamic_dnodes) {
1360      mark_root(n);             /* May or may not mark it */
1361      return true;              /* but return true 'cause it's a dynamic node */
1362    }
1363  }
1364  return false;                 /* Not a heap pointer or not dynamic */
1365}
1366
1367
1368void
1369mark_managed_static_refs(area *a, BytePtr low_dynamic_address, natural ndynamic_dnodes, bitvector refidx)
1370{
1371  bitvector refbits = managed_static_refbits;
1372  dnode *dnodes = (dnode *)a->low, *d;
1373  LispObj *p = (LispObj *) a->low, x1, x2;
1374  natural inbits, outbits, bits, *bitsp, nextbit, memo_dnode = 0,
1375    num_memo_dnodes = a->ndnodes, ref_dnode;
1376  Boolean keep_x1, keep_x2;
1377  bitidx_state state;
1378
1379  if (num_memo_dnodes) {
1380    init_bitidx_state(&state, refidx, refbits, num_memo_dnodes);
1381
1382    if (GCDebug) {
1383      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, refidx);
1384    }
1385
1386 
1387
1388
1389    inbits = outbits = bits = 0;
1390    while (1) {
1391      if (bits == 0) {
1392        if (outbits != inbits) {
1393          *bitsp = outbits;
1394        }
1395        bitsp = next_refbits(&state);
1396        if (bitsp == NULL) {
1397          break;
1398        }
1399        inbits = outbits = bits = *bitsp;
1400        ref_dnode = (bitsp-refbits)<<bitmap_shift;
1401      }
1402      nextbit = count_leading_zeros(bits);
1403      bits &= ~(BIT0_MASK>>nextbit);
1404      memo_dnode = ref_dnode + nextbit;
1405      d = dnodes+memo_dnode;
1406      x1 = d->w0;
1407      x2 = d->w1;
1408      keep_x1 = mark_static_ref(x1, low_dynamic_address, ndynamic_dnodes);
1409      keep_x2 = mark_static_ref(x2, low_dynamic_address, ndynamic_dnodes);
1410      if ((keep_x1 == false) && 
1411          (keep_x2 == false)) {
1412        outbits &= ~(BIT0_MASK >> nextbit);
1413      }
1414    }
1415    if (GCDebug) {
1416      p = (LispObj *) a->low;
1417      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, NULL);
1418    }
1419  }
1420}
1421
1422
1423void
1424mark_memoized_area(area *a, natural num_memo_dnodes, bitvector refidx)
1425{
1426  bitvector refbits = a->refbits;
1427  dnode *dnodes = (dnode *)a->low, *d;
1428  LispObj *p = (LispObj *) a->low,x1, x2;
1429  natural inbits, outbits, bits,  *bitsp, nextbit,  memo_dnode = 0, ref_dnode = 0;
1430  Boolean keep_x1, keep_x2;
1431  natural hash_dnode_limit = 0;
1432  hash_table_vector_header *hashp = NULL;
1433  int mark_method = 3;
1434  bitidx_state state;
1435
1436
1437
1438  if (num_memo_dnodes) {
1439    init_bitidx_state(&state, refidx, refbits, num_memo_dnodes);   
1440   
1441    if (GCDebug) {
1442      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, refidx);
1443    }
1444
1445    /* The distinction between "inbits" and "outbits" is supposed to help us
1446       detect cases where "uninteresting" setfs have been memoized.  Storing
1447       NIL, fixnums, immediates (characters, etc.) or node pointers to static
1448       or readonly areas is definitely uninteresting, but other cases are
1449       more complicated (and some of these cases are hard to detect.)
1450       Some headers are "interesting", to the forwarder if not to us.
1451
1452    */
1453
1454    /*
1455      We need to ensure that there are no bits set at or beyond
1456      "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
1457      tenures/untenures things.)  We find bits by grabbing a fullword at
1458      a time and doing a cntlzw instruction; and don't want to have to
1459      check for (< memo_dnode num_memo_dnodes) in the loop.
1460    */
1461
1462    {
1463      natural
1464        bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
1465        index_of_last_word = (num_memo_dnodes >> bitmap_shift);
1466
1467      if (bits_in_last_word != 0) {
1468        natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1);
1469        refbits[index_of_last_word] &= mask;
1470      }
1471    }
1472     
1473     
1474
1475    inbits = outbits = bits = 0;
1476    while (1) {
1477      if (bits == 0) {
1478        if (outbits != inbits) {
1479          *bitsp = outbits;
1480        }
1481        bitsp = next_refbits(&state);
1482        if (bitsp == NULL) {
1483          break;
1484        }
1485        inbits = outbits = bits = *bitsp;
1486        ref_dnode = (bitsp-refbits)<<bitmap_shift;
1487      } 
1488      nextbit = count_leading_zeros(bits);
1489      bits &= ~(BIT0_MASK >> nextbit);
1490      memo_dnode = ref_dnode + nextbit;
1491      d = dnodes+memo_dnode;
1492      x1 = d->w0;
1493      x2 = d->w1;
1494
1495
1496      if (hashp) {
1497        Boolean force_x1 = false;
1498        if ((memo_dnode >= hash_dnode_limit) && (mark_method == 3)) {
1499          /* if vector_header_count is odd, x1 might be the last word of the header */
1500          force_x1 = (hash_table_vector_header_count & 1) && (memo_dnode == hash_dnode_limit);
1501          /* was marking header, switch to data */
1502          hash_dnode_limit = area_dnode(((LispObj *)hashp)
1503                                        + 1
1504                                        + header_element_count(hashp->header),
1505                                        a->low);
1506          /* In traditional weak method, don't mark vector entries at all. */
1507          /* Otherwise mark the non-weak elements only */
1508          mark_method = ((lisp_global(WEAK_GC_METHOD) == 0) ? 0 :
1509                         ((hashp->flags & nhash_weak_value_mask)
1510                          ? (1 + (hash_table_vector_header_count & 1))
1511                          : (2 - (hash_table_vector_header_count & 1))));
1512        }
1513       
1514        if (memo_dnode < hash_dnode_limit) {
1515          /* perhaps ignore one or both of the elements */
1516          if (!force_x1 && !(mark_method & 1)) x1 = 0;
1517          if (!(mark_method & 2)) x2 = 0;
1518        } else {
1519          hashp = NULL;
1520        }
1521      }
1522
1523      if (header_subtag(x1) == subtag_hash_vector) {
1524        if (hashp) Bug(NULL, "header inside hash vector?");
1525        hash_table_vector_header *hp = (hash_table_vector_header *)d;
1526        if (hp->flags & nhash_weak_mask) {
1527          /* Work around the issue that seems to cause ticket:817,
1528             which is that tenured hash vectors that are weak on value
1529             aren't always maintained on GCweakvll.  If they aren't and
1530             we process them weakly here, nothing will delete the unreferenced
1531             elements. */
1532          if (!(hp->flags & nhash_weak_value_mask)) {
1533            /* If header_count is odd, this cuts off the last header field */
1534            /* That case is handled specially above */
1535            hash_dnode_limit = memo_dnode + ((hash_table_vector_header_count) >>1);
1536            hashp = hp;
1537            mark_method = 3;
1538          }
1539        }
1540      }
1541
1542      keep_x1 = mark_ephemeral_root(x1);
1543      keep_x2 = mark_ephemeral_root(x2);
1544      if ((keep_x1 == false) && 
1545          (keep_x2 == false) &&
1546          (hashp == NULL)) {
1547        outbits &= ~(BIT0_MASK >> nextbit);
1548      }
1549    }
1550    if (GCDebug) {
1551      p = (LispObj *) a->low;
1552      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, a->refidx);
1553    }
1554  }
1555}
1556
1557extern void zero_dnodes(void *,natural);
1558
1559void 
1560gc(TCR *tcr, signed_natural param)
1561{
1562  struct timeval start, stop;
1563  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1564  unsigned timeidx = 1;
1565  paging_info paging_info_start;
1566  LispObj
1567    pkg = 0,
1568    itabvec = 0;
1569  BytePtr oldfree = a->active, last_zeroed_addr;
1570  TCR *other_tcr;
1571  natural static_dnodes;
1572  natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift;
1573
1574#ifndef FORCE_DWS_MARK
1575  if ((natural) (TCR_AUX(tcr)->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1576    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1577  } else {
1578    GCstack_limit = (natural)(TCR_AUX(tcr)->cs_limit)+(natural)page_size;
1579  }
1580#else
1581  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1582#endif
1583
1584  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1585  if (GCephemeral_low) {
1586    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1587  } else {
1588    GCn_ephemeral_dnodes = 0;
1589  }
1590 
1591  if (GCn_ephemeral_dnodes) {
1592    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1593  } else {
1594    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1595  }
1596
1597  if (GCephemeral_low) {
1598    if ((oldfree-g1_area->low) < g1_area->threshold) {
1599      to = g1_area;
1600      note = a;
1601      timeidx = 4;
1602    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1603      to = g2_area;
1604      from = g1_area;
1605      note = g1_area;
1606      timeidx = 3;
1607    } else {
1608      to = tenured_area;
1609      from = g2_area;
1610      note = g2_area;
1611      timeidx = 2;
1612    } 
1613  } else {
1614    note = tenured_area;
1615  }
1616
1617  install_weak_mark_functions(weak_method);
1618 
1619  if (GCverbose) {
1620    char buf[16];
1621
1622    sample_paging_info(&paging_info_start);
1623    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1624    if (GCephemeral_low) {
1625      fprintf(dbgout,
1626              "\n\n;;; Starting Ephemeral GC of generation %d",
1627              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1628    } else {
1629      fprintf(dbgout,"\n\n;;; Starting full GC");
1630    }
1631    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1632  }
1633
1634#ifdef USE_DTRACE
1635  if (GCephemeral_low) {
1636    if (CCL_EGC_START_ENABLED()) {
1637      natural bytes_used = area_dnode(oldfree, a->low) << dnode_shift;
1638      unsigned generation = (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0;
1639      CCL_EGC_START(bytes_used, generation);
1640    }
1641  } else {
1642    if (CCL_GC_START_ENABLED()) {
1643      natural bytes_used = area_dnode(oldfree, a->low) << dnode_shift;
1644      CCL_GC_START(bytes_used);
1645    }
1646  }
1647#endif
1648
1649  get_time(start);
1650
1651  /* The link-inverting marker might need to write to watched areas */
1652  unprotect_watched_areas();
1653
1654  lisp_global(IN_GC) = (1<<fixnumshift);
1655
1656  if (just_purified_p) {
1657    just_purified_p = false;
1658    GCDebug = false;
1659  } else {
1660    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1661    if (GCDebug) {
1662      check_all_areas(tcr);
1663      check_static_cons_freelist("in pre-gc static-cons check");
1664    }
1665  }
1666
1667  if (from) {
1668    untenure_from_area(from);
1669  }
1670  static_dnodes = static_dnodes_for_area(a);
1671  GCmarkbits = a->markbits;
1672  GCarealow = ptr_to_lispobj(a->low);
1673  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1674  GCndnodes_in_area = gc_area_dnode(oldfree);
1675
1676  if (GCndnodes_in_area) {
1677    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1678    GCdynamic_markbits = 
1679      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1680
1681    zero_bits(GCmarkbits, GCndnodes_in_area);
1682
1683    init_weakvll();
1684
1685    if (GCn_ephemeral_dnodes == 0) {
1686      /* For GCTWA, mark the internal package hash table vector of
1687       *PACKAGE*, but don't mark its contents. */
1688      {
1689        LispObj
1690          itab,
1691          pkgidx = nrs_PACKAGE.binding_index;
1692        natural
1693          dnode, ndnodes;
1694     
1695        if ((pkgidx >= tcr->tlb_limit) ||
1696            ((pkg = tcr->tlb_pointer[pkgidx>>fixnumshift]) == 
1697             no_thread_local_binding_marker)) {
1698          pkg = nrs_PACKAGE.vcell;
1699        }
1700        if ((fulltag_of(pkg) == fulltag_misc) &&
1701            (header_subtag(header_of(pkg)) == subtag_package)) {
1702          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1703          itabvec = car(itab);
1704          dnode = gc_area_dnode(itabvec);
1705          if (dnode < GCndnodes_in_area) {
1706            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1707            set_n_bits(GCmarkbits, dnode, ndnodes);
1708          }
1709        }
1710      }
1711    }
1712
1713    mark_root(lisp_global(STATIC_CONSES));
1714
1715    {
1716      area *next_area;
1717      area_code code;
1718
1719      /* Could make a jump table instead of the typecase */
1720
1721      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1722        switch (code) {
1723        case AREA_TSTACK:
1724          mark_tstack_area(next_area);
1725          break;
1726
1727        case AREA_VSTACK:
1728          mark_vstack_area(next_area);
1729          break;
1730         
1731        case AREA_CSTACK:
1732          mark_cstack_area(next_area);
1733          break;
1734
1735        case AREA_STATIC:
1736        case AREA_WATCHED:
1737        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1738          /* In both of these cases, we -could- use the area's "markbits"
1739             bitvector as a reference map.  It's safe (but slower) to
1740             ignore that map and process the entire area.
1741          */
1742          if (next_area->younger == NULL) {
1743            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1744          }
1745          break;
1746
1747        default:
1748          break;
1749        }
1750      }
1751    }
1752
1753    if (GCephemeral_low) {
1754      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low), tenured_area->refidx);
1755      mark_memoized_area(managed_static_area,managed_static_area->ndnodes, managed_static_area->refidx);
1756    } else {
1757      mark_managed_static_refs(managed_static_area,low_markable_address,area_dnode(a->active,low_markable_address), managed_static_refidx);
1758    }
1759    other_tcr = tcr;
1760    do {
1761      mark_tcr_xframes(other_tcr);
1762      mark_tcr_tlb(other_tcr);
1763      other_tcr = TCR_AUX(other_tcr)->next;
1764    } while (other_tcr != tcr);
1765
1766
1767
1768
1769    /* Go back through *package*'s internal symbols, marking
1770       any that aren't worthless.
1771    */
1772   
1773    if (itabvec) {
1774      natural
1775        i,
1776        n = header_element_count(header_of(itabvec));
1777      LispObj
1778        sym,
1779        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1780
1781      for (i = 0; i < n; i++) {
1782        sym = *raw++;
1783        if (is_symbol_fulltag(sym)) {
1784          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1785          natural dnode = gc_area_dnode(sym);
1786         
1787          if ((dnode < GCndnodes_in_area) &&
1788              (!ref_bit(GCmarkbits,dnode))) {
1789            /* Symbol is in GC area, not marked.
1790               Mark it if fboundp, boundp, or if
1791               it has a plist or another home package.
1792            */
1793           
1794            if (FBOUNDP(rawsym) ||
1795                BOUNDP(rawsym) ||
1796                (rawsym->flags != 0) || /* SPECIAL, etc. */
1797                (rawsym->plist != lisp_nil) ||
1798                ((rawsym->package_predicate != pkg) &&
1799                 (rawsym->package_predicate != lisp_nil))) {
1800              mark_root(sym);
1801            }
1802          }
1803        }
1804      }
1805    }
1806
1807    (void)markhtabvs();
1808
1809    if (itabvec) {
1810      natural
1811        i,
1812        n = header_element_count(header_of(itabvec));
1813      LispObj
1814        sym,
1815        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1816
1817      for (i = 0; i < n; i++, raw++) {
1818        sym = *raw;
1819        if (is_symbol_fulltag(sym)) {
1820          natural dnode = gc_area_dnode(sym);
1821
1822          if ((dnode < GCndnodes_in_area) &&
1823              (!ref_bit(GCmarkbits,dnode))) {
1824            *raw = unbound_marker;
1825          }
1826        }
1827      }
1828    }
1829 
1830    reap_gcable_ptrs();
1831
1832    preforward_weakvll();
1833
1834    GCrelocptr = global_reloctab;
1835    GCfirstunmarked = calculate_relocation();
1836
1837    if (!GCephemeral_low) {
1838      reclaim_static_dnodes();
1839    }
1840
1841    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1842
1843    other_tcr = tcr;
1844    do {
1845      forward_tcr_xframes(other_tcr);
1846      forward_tcr_tlb(other_tcr);
1847      other_tcr = TCR_AUX(other_tcr)->next;
1848    } while (other_tcr != tcr);
1849
1850 
1851    forward_gcable_ptrs();
1852
1853
1854
1855    {
1856      area *next_area;
1857      area_code code;
1858
1859      /* Could make a jump table instead of the typecase */
1860
1861      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1862        switch (code) {
1863        case AREA_TSTACK:
1864          forward_tstack_area(next_area);
1865          break;
1866
1867        case AREA_VSTACK:
1868          forward_vstack_area(next_area);
1869          break;
1870
1871        case AREA_CSTACK:
1872          forward_cstack_area(next_area);
1873          break;
1874
1875        case AREA_STATIC:
1876        case AREA_WATCHED:
1877        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1878          if (next_area->younger == NULL) {
1879            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1880          }
1881          break;
1882
1883        default:
1884          break;
1885        }
1886      }
1887    }
1888
1889    if (GCephemeral_low) {
1890      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low), tenured_area->refbits, tenured_area->refidx);
1891      forward_memoized_area(managed_static_area,managed_static_area->ndnodes, managed_static_area->refbits, managed_static_area->refidx);
1892    } else {
1893      forward_memoized_area(managed_static_area,area_dnode(managed_static_area->active,managed_static_area->low),managed_static_refbits, NULL);
1894    }
1895    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1896
1897    forward_weakvll_links();
1898
1899    if (to) {
1900      tenure_to_area(to);
1901    }
1902
1903
1904    resize_dynamic_heap(a->active,
1905                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1906
1907    if (oldfree < a->high) {
1908      last_zeroed_addr = oldfree;
1909    } else {
1910      last_zeroed_addr = a->high;
1911    }
1912    zero_dnodes(a->active, area_dnode(last_zeroed_addr,a->active));
1913
1914    /*
1915      If the EGC is enabled: If there's no room for the youngest
1916      generation, untenure everything.  If this was a full GC and
1917      there's now room for the youngest generation, tenure everything.
1918    */
1919    if (a->older != NULL) {
1920      natural nfree = (a->high - a->active);
1921
1922
1923      if (nfree < a->threshold) {
1924        untenure_from_area(tenured_area);
1925      } else {
1926        if (GCephemeral_low == 0) {
1927          tenure_to_area(tenured_area);
1928        }
1929      }
1930    }
1931  }
1932  lisp_global(GC_NUM) += (1<<fixnumshift);
1933  if (note) {
1934    note->gccount += (1<<fixnumshift);
1935  }
1936
1937  if (GCDebug) {
1938    check_all_areas(tcr);
1939    check_static_cons_freelist("in post-gc static-cons check");
1940  }
1941
1942 
1943  lisp_global(IN_GC) = 0;
1944 
1945  protect_watched_areas();
1946
1947  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1948  get_time(stop);
1949
1950  {
1951    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1952    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1953    LispObj val;
1954    struct timeval *timeinfo, elapsed = {0, 0};
1955
1956    val = total_gc_microseconds->vcell;
1957    if ((fulltag_of(val) == fulltag_misc) &&
1958        (header_subtag(header_of(val)) == subtag_macptr)) {
1959      timersub(&stop, &start, &elapsed);
1960      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1961      timeradd(timeinfo,  &elapsed, timeinfo);
1962      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1963    }
1964
1965    val = total_bytes_freed->vcell;
1966    if ((fulltag_of(val) == fulltag_misc) &&
1967        (header_subtag(header_of(val)) == subtag_macptr)) {
1968      long long justfreed = oldfree - a->active;
1969      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1970
1971#ifdef USE_DTRACE
1972      if (note == tenured_area) {
1973        if (CCL_GC_FINISH_ENABLED()) {
1974          natural bytes_freed = justfreed <= heap_segment_size ? 0 : justfreed;
1975          CCL_GC_FINISH(bytes_freed);
1976        }
1977      } else {
1978        if (CCL_EGC_FINISH_ENABLED()) {
1979          natural bytes_freed = justfreed <= heap_segment_size ? 0 : justfreed;
1980          unsigned generation = (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0;
1981          CCL_EGC_FINISH(bytes_freed, generation);
1982        }
1983      }
1984#endif
1985
1986      if (GCverbose) {
1987        char buf[16];
1988        paging_info paging_info_stop;
1989
1990        sample_paging_info(&paging_info_stop);
1991        if (justfreed <= heap_segment_size) {
1992          justfreed = 0;
1993        }
1994        comma_output_decimal(buf,16,justfreed);
1995        if (note == tenured_area) {
1996          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1997        } else {
1998          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1999                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
2000                  buf, 
2001                  elapsed.tv_sec, elapsed.tv_usec);
2002        }
2003        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
2004      }
2005    }
2006  }
2007}
Note: See TracBrowser for help on using the repository browser.