source: trunk/source/lisp-kernel/gc-common.c @ 15821

Last change on this file since 15821 was 15821, checked in by gb, 7 years ago

Handle null refidx when checking refmap consistency.
Don't call memset() in zero_bits.
zero out refmaps/refidx's when tenuring to tenured area. (Should
use indices to find set bits in maps; shouldn't usually be many.)

File size: 51.7 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
1092void
1093forward_memoized_area(area *a, natural num_memo_dnodes, bitvector refbits)
1094{
1095  LispObj *p = (LispObj *) a->low, x1, x2, new;
1096#ifdef ARM
1097  LispObj *p0 = p;
1098#endif
1099  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
1100  int tag_x1;
1101  hash_table_vector_header *hashp = NULL;
1102  Boolean header_p;
1103  bitvector refidx = NULL;
1104 
1105  if (refbits == a->refbits) {
1106    refidx = a->refidx;
1107  }
1108
1109
1110
1111  if (num_memo_dnodes) {
1112    if (GCDebug) {
1113      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, refidx);
1114    }
1115
1116    /* This is pretty straightforward, but we have to note
1117       when we move a key in a hash table vector that wants
1118       us to tell it about that. */
1119
1120    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1121    while (memo_dnode < num_memo_dnodes) {
1122      if (bits == 0) {
1123        int remain = nbits_in_word - bitidx;
1124        memo_dnode += remain;
1125        p += (remain+remain);
1126        if (memo_dnode < num_memo_dnodes) {
1127          bits = *++bitsp;
1128        }
1129        bitidx = 0;
1130      } else {
1131        nextbit = count_leading_zeros(bits);
1132        if ((diff = (nextbit - bitidx)) != 0) {
1133          memo_dnode += diff;
1134          bitidx = nextbit;
1135          p += (diff+diff);
1136        }
1137        x1 = p[0];
1138        x2 = p[1];
1139        tag_x1 = fulltag_of(x1);
1140        bits &= ~(BIT0_MASK >> bitidx);
1141        header_p = (nodeheader_tag_p(tag_x1));
1142
1143        if (header_p &&
1144            (header_subtag(x1) == subtag_hash_vector)) {
1145          hashp = (hash_table_vector_header *) p;
1146          if (hashp->flags & nhash_track_keys_mask) {
1147            hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
1148          } else {
1149            hashp = NULL;
1150          }
1151        }
1152
1153
1154        if (! header_p) {
1155          new = node_forwarding_address(x1);
1156          if (new != x1) {
1157            *p = new;
1158#ifdef ARM
1159            if (p != p0) {
1160              if(header_subtag(p[-2]) == subtag_function) {
1161                /* Just updated the code vector; fix the entrypoint */
1162                if (p[-1] == (untag(x1)+fulltag_odd_fixnum)) {
1163                  p[-1] = (untag(new)+fulltag_odd_fixnum);
1164                }
1165              }
1166            }
1167#endif
1168          }
1169        }
1170        p++;
1171
1172        new = node_forwarding_address(x2);
1173        if (new != x2) {
1174          *p = new;
1175          if (memo_dnode < hash_dnode_limit) {
1176            /* If this code is reached, 'hashp' is non-NULL and pointing
1177               at the header of a hash_table_vector, and 'memo_dnode' identifies
1178               a pair of words inside the hash_table_vector.  It may be
1179               hard for program analysis tools to recognize that, but I
1180               believe that warnings about 'hashp' being NULL here can
1181               be safely ignored. */
1182            hashp->flags |= nhash_key_moved_mask;
1183            hash_dnode_limit = 0;
1184            hashp = NULL;
1185          }
1186        }
1187        p++;
1188        memo_dnode++;
1189        bitidx++;
1190
1191      }
1192    }
1193  }
1194}
1195
1196void
1197forward_tcr_tlb(TCR *tcr)
1198{
1199  natural n = tcr->tlb_limit;
1200  LispObj
1201    *start = tcr->tlb_pointer, 
1202    *end = (LispObj *) ((BytePtr)start+n),
1203    node;
1204
1205  while (start < end) {
1206    node = *start;
1207    if (node != no_thread_local_binding_marker) {
1208      update_noderef(start);
1209    }
1210    start++;
1211  }
1212}
1213
1214void
1215reclaim_static_dnodes()
1216{
1217  natural nstatic = tenured_area->static_dnodes, 
1218    i, 
1219    bits, 
1220    bitnum,
1221    nfree = 0,
1222    nstatic_conses = area_dnode(static_cons_area->high, static_cons_area->low);
1223  cons *c = (cons *)tenured_area->low, *d;
1224  bitvector bitsp = GCmarkbits;
1225  LispObj head = lisp_global(STATIC_CONSES);
1226
1227  for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
1228    bits = *bitsp++;
1229    if (bits != ALL_ONES) {
1230      for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
1231        if (! (bits & (BIT0_MASK>>bitnum))) {
1232          d = c + bitnum;
1233          if (i < nstatic_conses) {               
1234            d->car = unbound;
1235            d->cdr = head;
1236            head = ((LispObj)d)+fulltag_cons;
1237            nfree++;
1238          } else {
1239            d->car = 0;
1240            d->cdr = 0;
1241          }
1242        }
1243      }
1244    }
1245  }
1246  lisp_global(STATIC_CONSES) = head;
1247  lisp_global(FREE_STATIC_CONSES)+=(nfree<<fixnumshift);
1248}
1249
1250Boolean
1251youngest_non_null_area_p (area *a)
1252{
1253  if (a->active == a->high) {
1254    return false;
1255  } else {
1256    for (a = a->younger; a; a = a->younger) {
1257      if (a->active != a->high) {
1258        return false;
1259      }
1260    }
1261  };
1262  return true;
1263}
1264
1265Boolean just_purified_p = false;
1266
1267/*
1268  All thread's stack areas have been "normalized", as
1269  has the dynamic heap.  (The "active" pointer in these areas
1270  matches the stack pointer/freeptr value at the time that
1271  the exception occurred.)
1272*/
1273
1274#define get_time(when) gettimeofday(&when, NULL)
1275
1276
1277
1278#ifdef FORCE_DWS_MARK
1279#warning recursive marker disabled for testing; remember to re-enable it
1280#endif
1281
1282
1283Boolean
1284mark_static_ref(LispObj n, BytePtr dynamic_start, natural ndynamic_dnodes)
1285{
1286  int tag_n = fulltag_of(n);
1287  natural dyn_dnode;
1288
1289  if (nodeheader_tag_p(tag_n)) {
1290    return (header_subtag(n) == subtag_hash_vector);
1291  }
1292 
1293  if (is_node_fulltag (tag_n)) {
1294    dyn_dnode = area_dnode(n, dynamic_start);
1295    if (dyn_dnode < ndynamic_dnodes) {
1296      mark_root(n);             /* May or may not mark it */
1297      return true;              /* but return true 'cause it's a dynamic node */
1298    }
1299  }
1300  return false;                 /* Not a heap pointer or not dynamic */
1301}
1302
1303void
1304mark_managed_static_refs(area *a, BytePtr low_dynamic_address, natural ndynamic_dnodes)
1305{
1306  bitvector refbits = managed_static_refbits;
1307  LispObj *p = (LispObj *) a->low, x1, x2;
1308  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0,
1309    num_memo_dnodes = a->ndnodes;
1310  Boolean keep_x1, keep_x2;
1311
1312  if (num_memo_dnodes) {
1313    if (GCDebug) {
1314      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, NULL);
1315    }
1316
1317 
1318    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1319    inbits = outbits = bits;
1320    while (memo_dnode < num_memo_dnodes) {
1321      if (bits == 0) {
1322        int remain = nbits_in_word - bitidx;
1323        memo_dnode += remain;
1324        p += (remain+remain);
1325        if (outbits != inbits) {
1326          *bitsp = outbits;
1327        }
1328        if (memo_dnode < num_memo_dnodes) {
1329          bits = *++bitsp;
1330        }
1331        inbits = outbits = bits;
1332        bitidx = 0;
1333      } else {
1334        nextbit = count_leading_zeros(bits);
1335        if ((diff = (nextbit - bitidx)) != 0) {
1336          memo_dnode += diff;
1337          bitidx = nextbit;
1338          p += (diff+diff);
1339        }
1340        x1 = *p++;
1341        x2 = *p++;
1342        bits &= ~(BIT0_MASK >> bitidx);
1343        keep_x1 = mark_static_ref(x1, low_dynamic_address, ndynamic_dnodes);
1344        keep_x2 = mark_static_ref(x2, low_dynamic_address, ndynamic_dnodes);
1345        if ((keep_x1 == false) && 
1346            (keep_x2 == false)) {
1347          outbits &= ~(BIT0_MASK >> bitidx);
1348        }
1349        memo_dnode++;
1350        bitidx++;
1351      }
1352    }
1353    if (GCDebug) {
1354      p = (LispObj *) a->low;
1355      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, NULL);
1356    }
1357  }
1358}
1359
1360void
1361mark_memoized_area(area *a, natural num_memo_dnodes)
1362{
1363  bitvector refbits = a->refbits;
1364  LispObj *p = (LispObj *) a->low, x1, x2;
1365  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
1366  Boolean keep_x1, keep_x2;
1367  natural hash_dnode_limit = 0;
1368  hash_table_vector_header *hashp = NULL;
1369  int mark_method = 3;
1370
1371  if (num_memo_dnodes) {
1372    if (GCDebug) {
1373      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, a->refidx);
1374    }
1375
1376    /* The distinction between "inbits" and "outbits" is supposed to help us
1377       detect cases where "uninteresting" setfs have been memoized.  Storing
1378       NIL, fixnums, immediates (characters, etc.) or node pointers to static
1379       or readonly areas is definitely uninteresting, but other cases are
1380       more complicated (and some of these cases are hard to detect.)
1381
1382       Some headers are "interesting", to the forwarder if not to us.
1383
1384    */
1385
1386    /*
1387      We need to ensure that there are no bits set at or beyond
1388      "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
1389      tenures/untenures things.)  We find bits by grabbing a fullword at
1390      a time and doing a cntlzw instruction; and don't want to have to
1391      check for (< memo_dnode num_memo_dnodes) in the loop.
1392    */
1393
1394    {
1395      natural
1396        bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
1397        index_of_last_word = (num_memo_dnodes >> bitmap_shift);
1398
1399      if (bits_in_last_word != 0) {
1400        natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1);
1401        refbits[index_of_last_word] &= mask;
1402      }
1403    }
1404       
1405    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1406    inbits = outbits = bits;
1407    while (memo_dnode < num_memo_dnodes) {
1408      if (bits == 0) {
1409        int remain = nbits_in_word - bitidx;
1410        memo_dnode += remain;
1411        p += (remain+remain);
1412        if (outbits != inbits) {
1413          *bitsp = outbits;
1414        }
1415        if (memo_dnode < num_memo_dnodes) {
1416          bits = *++bitsp;
1417        } 
1418        inbits = outbits = bits;
1419        bitidx = 0;
1420      } else {
1421        nextbit = count_leading_zeros(bits);
1422        if ((diff = (nextbit - bitidx)) != 0) {
1423          memo_dnode += diff;
1424          bitidx = nextbit;
1425          p += (diff+diff);
1426        }
1427        x1 = *p++;
1428        x2 = *p++;
1429        bits &= ~(BIT0_MASK >> bitidx);
1430
1431
1432        if (hashp) {
1433          Boolean force_x1 = false;
1434          if ((memo_dnode >= hash_dnode_limit) && (mark_method == 3)) {
1435            /* if vector_header_count is odd, x1 might be the last word of the header */
1436            force_x1 = (hash_table_vector_header_count & 1) && (memo_dnode == hash_dnode_limit);
1437            /* was marking header, switch to data */
1438            hash_dnode_limit = area_dnode(((LispObj *)hashp)
1439                                          + 1
1440                                          + header_element_count(hashp->header),
1441                                          a->low);
1442            /* In traditional weak method, don't mark vector entries at all. */
1443            /* Otherwise mark the non-weak elements only */
1444            mark_method = ((lisp_global(WEAK_GC_METHOD) == 0) ? 0 :
1445                           ((hashp->flags & nhash_weak_value_mask)
1446                            ? (1 + (hash_table_vector_header_count & 1))
1447                            : (2 - (hash_table_vector_header_count & 1))));
1448          }
1449
1450          if (memo_dnode < hash_dnode_limit) {
1451            /* perhaps ignore one or both of the elements */
1452            if (!force_x1 && !(mark_method & 1)) x1 = 0;
1453            if (!(mark_method & 2)) x2 = 0;
1454          } else {
1455            hashp = NULL;
1456          }
1457        }
1458
1459        if (header_subtag(x1) == subtag_hash_vector) {
1460          if (hashp) Bug(NULL, "header inside hash vector?");
1461          hash_table_vector_header *hp = (hash_table_vector_header *)(p - 2);
1462          if (hp->flags & nhash_weak_mask) {
1463            /* Work around the issue that seems to cause ticket:817,
1464               which is that tenured hash vectors that are weak on value
1465               aren't always maintained on GCweakvll.  If they aren't and
1466               we process them weakly here, nothing will delete the unreferenced
1467               elements. */
1468            if (!(hp->flags & nhash_weak_value_mask)) {
1469              /* If header_count is odd, this cuts off the last header field */
1470              /* That case is handled specially above */
1471              hash_dnode_limit = memo_dnode + ((hash_table_vector_header_count) >>1);
1472              hashp = hp;
1473              mark_method = 3;
1474            }
1475          }
1476        }
1477
1478        keep_x1 = mark_ephemeral_root(x1);
1479        keep_x2 = mark_ephemeral_root(x2);
1480        if ((keep_x1 == false) && 
1481            (keep_x2 == false) &&
1482            (hashp == NULL)) {
1483          outbits &= ~(BIT0_MASK >> bitidx);
1484        }
1485        memo_dnode++;
1486        bitidx++;
1487      }
1488    }
1489    if (GCDebug) {
1490      p = (LispObj *) a->low;
1491      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits, a->refidx);
1492    }
1493  }
1494}
1495
1496extern void zero_dnodes(void *,natural);
1497
1498void 
1499gc(TCR *tcr, signed_natural param)
1500{
1501  struct timeval start, stop;
1502  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1503  unsigned timeidx = 1;
1504  paging_info paging_info_start;
1505  LispObj
1506    pkg = 0,
1507    itabvec = 0;
1508  BytePtr oldfree = a->active, last_zeroed_addr;
1509  TCR *other_tcr;
1510  natural static_dnodes;
1511  natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift;
1512
1513#ifndef FORCE_DWS_MARK
1514  if ((natural) (TCR_AUX(tcr)->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1515    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1516  } else {
1517    GCstack_limit = (natural)(TCR_AUX(tcr)->cs_limit)+(natural)page_size;
1518  }
1519#else
1520  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1521#endif
1522
1523  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1524  if (GCephemeral_low) {
1525    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1526  } else {
1527    GCn_ephemeral_dnodes = 0;
1528  }
1529 
1530  if (GCn_ephemeral_dnodes) {
1531    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1532  } else {
1533    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1534  }
1535
1536  if (GCephemeral_low) {
1537    if ((oldfree-g1_area->low) < g1_area->threshold) {
1538      to = g1_area;
1539      note = a;
1540      timeidx = 4;
1541    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1542      to = g2_area;
1543      from = g1_area;
1544      note = g1_area;
1545      timeidx = 3;
1546    } else {
1547      to = tenured_area;
1548      from = g2_area;
1549      note = g2_area;
1550      timeidx = 2;
1551    } 
1552  } else {
1553    note = tenured_area;
1554  }
1555
1556  install_weak_mark_functions(weak_method);
1557 
1558  if (GCverbose) {
1559    char buf[16];
1560
1561    sample_paging_info(&paging_info_start);
1562    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1563    if (GCephemeral_low) {
1564      fprintf(dbgout,
1565              "\n\n;;; Starting Ephemeral GC of generation %d",
1566              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1567    } else {
1568      fprintf(dbgout,"\n\n;;; Starting full GC");
1569    }
1570    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1571  }
1572
1573#ifdef USE_DTRACE
1574  if (GCephemeral_low) {
1575    if (CCL_EGC_START_ENABLED()) {
1576      natural bytes_used = area_dnode(oldfree, a->low) << dnode_shift;
1577      unsigned generation = (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0;
1578      CCL_EGC_START(bytes_used, generation);
1579    }
1580  } else {
1581    if (CCL_GC_START_ENABLED()) {
1582      natural bytes_used = area_dnode(oldfree, a->low) << dnode_shift;
1583      CCL_GC_START(bytes_used);
1584    }
1585  }
1586#endif
1587
1588  get_time(start);
1589
1590  /* The link-inverting marker might need to write to watched areas */
1591  unprotect_watched_areas();
1592
1593  lisp_global(IN_GC) = (1<<fixnumshift);
1594
1595  if (just_purified_p) {
1596    just_purified_p = false;
1597    GCDebug = false;
1598  } else {
1599    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1600    if (GCDebug) {
1601      check_all_areas(tcr);
1602      check_static_cons_freelist("in pre-gc static-cons check");
1603    }
1604  }
1605
1606  if (from) {
1607    untenure_from_area(from);
1608  }
1609  static_dnodes = static_dnodes_for_area(a);
1610  GCmarkbits = a->markbits;
1611  GCarealow = ptr_to_lispobj(a->low);
1612  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1613  GCndnodes_in_area = gc_area_dnode(oldfree);
1614
1615  if (GCndnodes_in_area) {
1616    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1617    GCdynamic_markbits = 
1618      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1619
1620    zero_bits(GCmarkbits, GCndnodes_in_area);
1621
1622    init_weakvll();
1623
1624    if (GCn_ephemeral_dnodes == 0) {
1625      /* For GCTWA, mark the internal package hash table vector of
1626       *PACKAGE*, but don't mark its contents. */
1627      {
1628        LispObj
1629          itab,
1630          pkgidx = nrs_PACKAGE.binding_index;
1631        natural
1632          dnode, ndnodes;
1633     
1634        if ((pkgidx >= tcr->tlb_limit) ||
1635            ((pkg = tcr->tlb_pointer[pkgidx>>fixnumshift]) == 
1636             no_thread_local_binding_marker)) {
1637          pkg = nrs_PACKAGE.vcell;
1638        }
1639        if ((fulltag_of(pkg) == fulltag_misc) &&
1640            (header_subtag(header_of(pkg)) == subtag_package)) {
1641          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1642          itabvec = car(itab);
1643          dnode = gc_area_dnode(itabvec);
1644          if (dnode < GCndnodes_in_area) {
1645            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1646            set_n_bits(GCmarkbits, dnode, ndnodes);
1647          }
1648        }
1649      }
1650    }
1651
1652    mark_root(lisp_global(STATIC_CONSES));
1653
1654    {
1655      area *next_area;
1656      area_code code;
1657
1658      /* Could make a jump table instead of the typecase */
1659
1660      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1661        switch (code) {
1662        case AREA_TSTACK:
1663          mark_tstack_area(next_area);
1664          break;
1665
1666        case AREA_VSTACK:
1667          mark_vstack_area(next_area);
1668          break;
1669         
1670        case AREA_CSTACK:
1671          mark_cstack_area(next_area);
1672          break;
1673
1674        case AREA_STATIC:
1675        case AREA_WATCHED:
1676        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1677          /* In both of these cases, we -could- use the area's "markbits"
1678             bitvector as a reference map.  It's safe (but slower) to
1679             ignore that map and process the entire area.
1680          */
1681          if (next_area->younger == NULL) {
1682            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1683          }
1684          break;
1685
1686        default:
1687          break;
1688        }
1689      }
1690    }
1691
1692    if (GCephemeral_low) {
1693      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1694      mark_memoized_area(managed_static_area,managed_static_area->ndnodes);
1695    } else {
1696      mark_managed_static_refs(managed_static_area,low_markable_address,area_dnode(a->active,low_markable_address));
1697    }
1698    other_tcr = tcr;
1699    do {
1700      mark_tcr_xframes(other_tcr);
1701      mark_tcr_tlb(other_tcr);
1702      other_tcr = TCR_AUX(other_tcr)->next;
1703    } while (other_tcr != tcr);
1704
1705
1706
1707
1708    /* Go back through *package*'s internal symbols, marking
1709       any that aren't worthless.
1710    */
1711   
1712    if (itabvec) {
1713      natural
1714        i,
1715        n = header_element_count(header_of(itabvec));
1716      LispObj
1717        sym,
1718        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1719
1720      for (i = 0; i < n; i++) {
1721        sym = *raw++;
1722        if (is_symbol_fulltag(sym)) {
1723          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1724          natural dnode = gc_area_dnode(sym);
1725         
1726          if ((dnode < GCndnodes_in_area) &&
1727              (!ref_bit(GCmarkbits,dnode))) {
1728            /* Symbol is in GC area, not marked.
1729               Mark it if fboundp, boundp, or if
1730               it has a plist or another home package.
1731            */
1732           
1733            if (FBOUNDP(rawsym) ||
1734                BOUNDP(rawsym) ||
1735                (rawsym->flags != 0) || /* SPECIAL, etc. */
1736                (rawsym->plist != lisp_nil) ||
1737                ((rawsym->package_predicate != pkg) &&
1738                 (rawsym->package_predicate != lisp_nil))) {
1739              mark_root(sym);
1740            }
1741          }
1742        }
1743      }
1744    }
1745
1746    (void)markhtabvs();
1747
1748    if (itabvec) {
1749      natural
1750        i,
1751        n = header_element_count(header_of(itabvec));
1752      LispObj
1753        sym,
1754        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1755
1756      for (i = 0; i < n; i++, raw++) {
1757        sym = *raw;
1758        if (is_symbol_fulltag(sym)) {
1759          natural dnode = gc_area_dnode(sym);
1760
1761          if ((dnode < GCndnodes_in_area) &&
1762              (!ref_bit(GCmarkbits,dnode))) {
1763            *raw = unbound_marker;
1764          }
1765        }
1766      }
1767    }
1768 
1769    reap_gcable_ptrs();
1770
1771    preforward_weakvll();
1772
1773    GCrelocptr = global_reloctab;
1774    GCfirstunmarked = calculate_relocation();
1775
1776    if (!GCephemeral_low) {
1777      reclaim_static_dnodes();
1778    }
1779
1780    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1781
1782    other_tcr = tcr;
1783    do {
1784      forward_tcr_xframes(other_tcr);
1785      forward_tcr_tlb(other_tcr);
1786      other_tcr = TCR_AUX(other_tcr)->next;
1787    } while (other_tcr != tcr);
1788
1789 
1790    forward_gcable_ptrs();
1791
1792
1793
1794    {
1795      area *next_area;
1796      area_code code;
1797
1798      /* Could make a jump table instead of the typecase */
1799
1800      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1801        switch (code) {
1802        case AREA_TSTACK:
1803          forward_tstack_area(next_area);
1804          break;
1805
1806        case AREA_VSTACK:
1807          forward_vstack_area(next_area);
1808          break;
1809
1810        case AREA_CSTACK:
1811          forward_cstack_area(next_area);
1812          break;
1813
1814        case AREA_STATIC:
1815        case AREA_WATCHED:
1816        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1817          if (next_area->younger == NULL) {
1818            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1819          }
1820          break;
1821
1822        default:
1823          break;
1824        }
1825      }
1826    }
1827
1828    if (GCephemeral_low) {
1829      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low), tenured_area->refbits);
1830      forward_memoized_area(managed_static_area,managed_static_area->ndnodes, managed_static_area->refbits);
1831    } else {
1832      forward_memoized_area(managed_static_area,area_dnode(managed_static_area->active,managed_static_area->low),managed_static_refbits);
1833    }
1834    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1835
1836    forward_weakvll_links();
1837
1838    if (to) {
1839      tenure_to_area(to);
1840    }
1841
1842
1843    resize_dynamic_heap(a->active,
1844                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1845
1846    if (oldfree < a->high) {
1847      last_zeroed_addr = oldfree;
1848    } else {
1849      last_zeroed_addr = a->high;
1850    }
1851    zero_dnodes(a->active, area_dnode(last_zeroed_addr,a->active));
1852
1853    /*
1854      If the EGC is enabled: If there's no room for the youngest
1855      generation, untenure everything.  If this was a full GC and
1856      there's now room for the youngest generation, tenure everything.
1857    */
1858    if (a->older != NULL) {
1859      natural nfree = (a->high - a->active);
1860
1861
1862      if (nfree < a->threshold) {
1863        untenure_from_area(tenured_area);
1864      } else {
1865        if (GCephemeral_low == 0) {
1866          tenure_to_area(tenured_area);
1867        }
1868      }
1869    }
1870  }
1871  lisp_global(GC_NUM) += (1<<fixnumshift);
1872  if (note) {
1873    note->gccount += (1<<fixnumshift);
1874  }
1875
1876  if (GCDebug) {
1877    check_all_areas(tcr);
1878    check_static_cons_freelist("in post-gc static-cons check");
1879  }
1880
1881 
1882  lisp_global(IN_GC) = 0;
1883 
1884  protect_watched_areas();
1885
1886  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1887  get_time(stop);
1888
1889  {
1890    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1891    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1892    LispObj val;
1893    struct timeval *timeinfo, elapsed = {0, 0};
1894
1895    val = total_gc_microseconds->vcell;
1896    if ((fulltag_of(val) == fulltag_misc) &&
1897        (header_subtag(header_of(val)) == subtag_macptr)) {
1898      timersub(&stop, &start, &elapsed);
1899      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1900      timeradd(timeinfo,  &elapsed, timeinfo);
1901      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1902    }
1903
1904    val = total_bytes_freed->vcell;
1905    if ((fulltag_of(val) == fulltag_misc) &&
1906        (header_subtag(header_of(val)) == subtag_macptr)) {
1907      long long justfreed = oldfree - a->active;
1908      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1909
1910#ifdef USE_DTRACE
1911      if (note == tenured_area) {
1912        if (CCL_GC_FINISH_ENABLED()) {
1913          natural bytes_freed = justfreed <= heap_segment_size ? 0 : justfreed;
1914          CCL_GC_FINISH(bytes_freed);
1915        }
1916      } else {
1917        if (CCL_EGC_FINISH_ENABLED()) {
1918          natural bytes_freed = justfreed <= heap_segment_size ? 0 : justfreed;
1919          unsigned generation = (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0;
1920          CCL_EGC_FINISH(bytes_freed, generation);
1921        }
1922      }
1923#endif
1924
1925      if (GCverbose) {
1926        char buf[16];
1927        paging_info paging_info_stop;
1928
1929        sample_paging_info(&paging_info_stop);
1930        if (justfreed <= heap_segment_size) {
1931          justfreed = 0;
1932        }
1933        comma_output_decimal(buf,16,justfreed);
1934        if (note == tenured_area) {
1935          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1936        } else {
1937          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1938                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1939                  buf, 
1940                  elapsed.tv_sec, elapsed.tv_usec);
1941        }
1942        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
1943      }
1944    }
1945  }
1946}
Note: See TracBrowser for help on using the repository browser.