source: branches/acl2-egc/lisp-kernel/gc-common.c @ 16371

Last change on this file since 16371 was 16371, checked in by gb, 5 years ago

still in progress

File size: 54.6 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
1557
1558void 
1559gc(TCR *tcr, signed_natural param)
1560{
1561  struct timeval start, stop;
1562  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1563  unsigned timeidx = 1;
1564  paging_info paging_info_start;
1565  LispObj
1566    pkg = 0,
1567    itabvec = 0;
1568  BytePtr oldfree = a->active;
1569  TCR *other_tcr;
1570  natural static_dnodes;
1571  natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift;
1572
1573#ifndef FORCE_DWS_MARK
1574  if ((natural) (TCR_AUX(tcr)->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1575    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1576  } else {
1577    GCstack_limit = (natural)(TCR_AUX(tcr)->cs_limit)+(natural)page_size;
1578  }
1579#else
1580  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1581#endif
1582
1583  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1584  if (GCephemeral_low) {
1585    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1586  } else {
1587    GCn_ephemeral_dnodes = 0;
1588  }
1589 
1590  if (GCn_ephemeral_dnodes) {
1591    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1592  } else {
1593    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1594  }
1595
1596  if (GCephemeral_low) {
1597    if ((oldfree-g1_area->low) < g1_area->threshold) {
1598      to = g1_area;
1599      note = a;
1600      timeidx = 4;
1601    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1602      to = g2_area;
1603      from = g1_area;
1604      note = g1_area;
1605      timeidx = 3;
1606    } else {
1607      to = tenured_area;
1608      from = g2_area;
1609      note = g2_area;
1610      timeidx = 2;
1611    } 
1612  } else {
1613    note = tenured_area;
1614  }
1615
1616  install_weak_mark_functions(weak_method);
1617 
1618  if (GCverbose) {
1619    char buf[16];
1620
1621    sample_paging_info(&paging_info_start);
1622    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1623    if (GCephemeral_low) {
1624      fprintf(dbgout,
1625              "\n\n;;; Starting Ephemeral GC of generation %d",
1626              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1627    } else {
1628      fprintf(dbgout,"\n\n;;; Starting full GC");
1629    }
1630    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1631  }
1632
1633#ifdef USE_DTRACE
1634  if (GCephemeral_low) {
1635    if (CCL_EGC_START_ENABLED()) {
1636      natural bytes_used = area_dnode(oldfree, a->low) << dnode_shift;
1637      unsigned generation = (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0;
1638      CCL_EGC_START(bytes_used, generation);
1639    }
1640  } else {
1641    if (CCL_GC_START_ENABLED()) {
1642      natural bytes_used = area_dnode(oldfree, a->low) << dnode_shift;
1643      CCL_GC_START(bytes_used);
1644    }
1645  }
1646#endif
1647
1648  get_time(start);
1649
1650  /* The link-inverting marker might need to write to watched areas */
1651  unprotect_watched_areas();
1652
1653  lisp_global(IN_GC) = (1<<fixnumshift);
1654
1655  if (just_purified_p) {
1656    just_purified_p = false;
1657    GCDebug = false;
1658  } else {
1659    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1660    if (GCDebug) {
1661      check_all_areas(tcr);
1662      check_static_cons_freelist("in pre-gc static-cons check");
1663    }
1664  }
1665
1666  if (from) {
1667    untenure_from_area(from);
1668  }
1669  static_dnodes = static_dnodes_for_area(a);
1670  GCmarkbits = a->markbits;
1671  GCarealow = ptr_to_lispobj(a->low);
1672  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1673  GCndnodes_in_area = gc_area_dnode(oldfree);
1674
1675  if (GCndnodes_in_area) {
1676    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1677    GCdynamic_markbits = 
1678      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1679
1680    zero_bits(GCmarkbits, GCndnodes_in_area);
1681
1682    init_weakvll();
1683
1684    if (GCn_ephemeral_dnodes == 0) {
1685      /* For GCTWA, mark the internal package hash table vector of
1686       *PACKAGE*, but don't mark its contents. */
1687      {
1688        LispObj
1689          itab,
1690          pkgidx = nrs_PACKAGE.binding_index;
1691        natural
1692          dnode, ndnodes;
1693     
1694        if ((pkgidx >= tcr->tlb_limit) ||
1695            ((pkg = tcr->tlb_pointer[pkgidx>>fixnumshift]) == 
1696             no_thread_local_binding_marker)) {
1697          pkg = nrs_PACKAGE.vcell;
1698        }
1699        if ((fulltag_of(pkg) == fulltag_misc) &&
1700            (header_subtag(header_of(pkg)) == subtag_package)) {
1701          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1702          itabvec = car(itab);
1703          dnode = gc_area_dnode(itabvec);
1704          if (dnode < GCndnodes_in_area) {
1705            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1706            set_n_bits(GCmarkbits, dnode, ndnodes);
1707          }
1708        }
1709      }
1710    }
1711
1712    mark_root(lisp_global(STATIC_CONSES));
1713
1714    {
1715      area *next_area;
1716      area_code code;
1717
1718      /* Could make a jump table instead of the typecase */
1719
1720      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1721        switch (code) {
1722        case AREA_TSTACK:
1723          mark_tstack_area(next_area);
1724          break;
1725
1726        case AREA_VSTACK:
1727          mark_vstack_area(next_area);
1728          break;
1729         
1730        case AREA_CSTACK:
1731          mark_cstack_area(next_area);
1732          break;
1733
1734        case AREA_STATIC:
1735        case AREA_WATCHED:
1736        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1737          /* In both of these cases, we -could- use the area's "markbits"
1738             bitvector as a reference map.  It's safe (but slower) to
1739             ignore that map and process the entire area.
1740          */
1741          if (next_area->younger == NULL) {
1742            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1743          }
1744          break;
1745
1746        default:
1747          break;
1748        }
1749      }
1750    }
1751
1752    if (GCephemeral_low) {
1753      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low), tenured_area->refidx);
1754      mark_memoized_area(managed_static_area,managed_static_area->ndnodes, managed_static_area->refidx);
1755    } else {
1756      mark_managed_static_refs(managed_static_area,low_markable_address,area_dnode(a->active,low_markable_address), managed_static_refidx);
1757    }
1758    other_tcr = tcr;
1759    do {
1760      mark_tcr_xframes(other_tcr);
1761      mark_tcr_tlb(other_tcr);
1762      other_tcr = TCR_AUX(other_tcr)->next;
1763    } while (other_tcr != tcr);
1764
1765
1766
1767
1768    /* Go back through *package*'s internal symbols, marking
1769       any that aren't worthless.
1770    */
1771   
1772    if (itabvec) {
1773      natural
1774        i,
1775        n = header_element_count(header_of(itabvec));
1776      LispObj
1777        sym,
1778        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1779
1780      for (i = 0; i < n; i++) {
1781        sym = *raw++;
1782        if (is_symbol_fulltag(sym)) {
1783          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1784          natural dnode = gc_area_dnode(sym);
1785         
1786          if ((dnode < GCndnodes_in_area) &&
1787              (!ref_bit(GCmarkbits,dnode))) {
1788            /* Symbol is in GC area, not marked.
1789               Mark it if fboundp, boundp, or if
1790               it has a plist or another home package.
1791            */
1792           
1793            if (FBOUNDP(rawsym) ||
1794                BOUNDP(rawsym) ||
1795                (rawsym->flags != 0) || /* SPECIAL, etc. */
1796                (rawsym->plist != lisp_nil) ||
1797                ((rawsym->package_predicate != pkg) &&
1798                 (rawsym->package_predicate != lisp_nil))) {
1799              mark_root(sym);
1800            }
1801          }
1802        }
1803      }
1804    }
1805
1806    (void)markhtabvs();
1807
1808    if (itabvec) {
1809      natural
1810        i,
1811        n = header_element_count(header_of(itabvec));
1812      LispObj
1813        sym,
1814        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1815
1816      for (i = 0; i < n; i++, raw++) {
1817        sym = *raw;
1818        if (is_symbol_fulltag(sym)) {
1819          natural dnode = gc_area_dnode(sym);
1820
1821          if ((dnode < GCndnodes_in_area) &&
1822              (!ref_bit(GCmarkbits,dnode))) {
1823            *raw = unbound_marker;
1824          }
1825        }
1826      }
1827    }
1828 
1829    reap_gcable_ptrs();
1830
1831    preforward_weakvll();
1832
1833    GCrelocptr = global_reloctab;
1834    GCfirstunmarked = calculate_relocation();
1835
1836    reclaim_static_dnodes();
1837
1838
1839    forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1840
1841    other_tcr = tcr;
1842    do {
1843      forward_tcr_xframes(other_tcr);
1844      forward_tcr_tlb(other_tcr);
1845      other_tcr = TCR_AUX(other_tcr)->next;
1846    } while (other_tcr != tcr);
1847
1848 
1849    forward_gcable_ptrs();
1850
1851
1852
1853    {
1854      area *next_area;
1855      area_code code;
1856
1857      /* Could make a jump table instead of the typecase */
1858
1859      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1860        switch (code) {
1861        case AREA_TSTACK:
1862          forward_tstack_area(next_area);
1863          break;
1864
1865        case AREA_VSTACK:
1866          forward_vstack_area(next_area);
1867          break;
1868
1869        case AREA_CSTACK:
1870          forward_cstack_area(next_area);
1871          break;
1872
1873        case AREA_STATIC:
1874        case AREA_WATCHED:
1875        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1876          if (next_area->younger == NULL) {
1877            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1878          }
1879          break;
1880
1881        default:
1882          break;
1883        }
1884      }
1885    }
1886
1887    if (GCephemeral_low) {
1888      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low), tenured_area->refbits, tenured_area->refidx);
1889      forward_memoized_area(managed_static_area,managed_static_area->ndnodes, managed_static_area->refbits, managed_static_area->refidx);
1890    } else {
1891      forward_memoized_area(managed_static_area,area_dnode(managed_static_area->active,managed_static_area->low),managed_static_refbits, NULL);
1892    }
1893    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1894
1895    forward_weakvll_links();
1896
1897    if (to) {
1898      tenure_to_area(to);
1899    }
1900
1901
1902    resize_dynamic_heap(a->active,
1903                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1904
1905
1906    /*
1907      If the EGC is enabled: If there's no room for the youngest
1908      generation, untenure everything.  If this was a full GC and
1909      there's now room for the youngest generation, tenure everything.
1910    */
1911    if (a->older != NULL) {
1912      natural nfree = (a->high - a->active);
1913
1914
1915      if (nfree < a->threshold) {
1916        untenure_from_area(tenured_area);
1917      } else {
1918        if (GCephemeral_low == 0) {
1919          tenure_to_area(tenured_area);
1920        }
1921      }
1922    }
1923  }
1924  lisp_global(GC_NUM) += (1<<fixnumshift);
1925  if (note) {
1926    note->gccount += (1<<fixnumshift);
1927  }
1928
1929  if (GCDebug) {
1930    check_all_areas(tcr);
1931    check_static_cons_freelist("in post-gc static-cons check");
1932  }
1933
1934 
1935  lisp_global(IN_GC) = 0;
1936 
1937  protect_watched_areas();
1938
1939  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1940  get_time(stop);
1941
1942  {
1943    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1944    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1945    LispObj val;
1946    struct timeval *timeinfo, elapsed = {0, 0};
1947
1948    val = total_gc_microseconds->vcell;
1949    if ((fulltag_of(val) == fulltag_misc) &&
1950        (header_subtag(header_of(val)) == subtag_macptr)) {
1951      timersub(&stop, &start, &elapsed);
1952      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1953      timeradd(timeinfo,  &elapsed, timeinfo);
1954      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1955    }
1956
1957    val = total_bytes_freed->vcell;
1958    if ((fulltag_of(val) == fulltag_misc) &&
1959        (header_subtag(header_of(val)) == subtag_macptr)) {
1960      long long justfreed = oldfree - a->active;
1961      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1962
1963#ifdef USE_DTRACE
1964      if (note == tenured_area) {
1965        if (CCL_GC_FINISH_ENABLED()) {
1966          natural bytes_freed = justfreed <= heap_segment_size ? 0 : justfreed;
1967          CCL_GC_FINISH(bytes_freed);
1968        }
1969      } else {
1970        if (CCL_EGC_FINISH_ENABLED()) {
1971          natural bytes_freed = justfreed <= heap_segment_size ? 0 : justfreed;
1972          unsigned generation = (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0;
1973          CCL_EGC_FINISH(bytes_freed, generation);
1974        }
1975      }
1976#endif
1977
1978      if (GCverbose) {
1979        char buf[16];
1980        paging_info paging_info_stop;
1981
1982        sample_paging_info(&paging_info_stop);
1983        if (justfreed <= heap_segment_size) {
1984          justfreed = 0;
1985        }
1986        comma_output_decimal(buf,16,justfreed);
1987        if (note == tenured_area) {
1988          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1989        } else {
1990          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1991                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1992                  buf, 
1993                  elapsed.tv_sec, elapsed.tv_usec);
1994        }
1995        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
1996      }
1997    }
1998  }
1999}
2000
2001/*
2002  This doesn't GC; it returns true if it made enough room, false
2003  otherwise.
2004  If "extend" is true, it can try to extend the dynamic area to
2005  satisfy the request.
2006*/
2007
2008Boolean
2009new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr, Boolean *crossed_threshold)
2010{
2011  area *a;
2012  natural newlimit, oldlimit;
2013  natural log2_allocation_quantum = TCR_AUX(tcr)->log2_allocation_quantum;
2014
2015  if (crossed_threshold) {
2016    *crossed_threshold = false;
2017  }
2018
2019  a  = active_dynamic_area;
2020  oldlimit = (natural) a->active;
2021  newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) +
2022              align_to_power_of_2(need, log2_allocation_quantum));
2023  if (newlimit > (natural) (a->high)) {
2024    if (extend) {
2025      signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2026      natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold;
2027      do {
2028        if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) {
2029          break;
2030        }
2031        extend_by = align_to_power_of_2(extend_by>>1,log2_allocation_quantum);
2032        if (extend_by < 4<<20) {
2033          return false;
2034        }
2035      } while (1);
2036    } else {
2037      return false;
2038    }
2039  }
2040  a->active = (BytePtr) newlimit;
2041  platform_new_heap_segment(xp, tcr, (BytePtr)oldlimit, (BytePtr)newlimit);
2042  if ((BytePtr)oldlimit < heap_dirty_limit) {
2043    if ((BytePtr)newlimit < heap_dirty_limit) {
2044      zero_dnodes((void *)oldlimit,area_dnode(newlimit,oldlimit)); 
2045    } else {
2046      zero_dnodes((void *)oldlimit,area_dnode(heap_dirty_limit,oldlimit));
2047    }
2048  }
2049  if ((BytePtr)newlimit > heap_dirty_limit) {
2050    heap_dirty_limit = (BytePtr)newlimit;       
2051  }
2052
2053  if (crossed_threshold && (!extend)) {
2054    if (((a->high - (BytePtr)newlimit) < lisp_heap_notify_threshold)&&
2055        ((a->high - (BytePtr)oldlimit) >= lisp_heap_notify_threshold)) {
2056      *crossed_threshold = true;
2057    }
2058  }
2059   
2060
2061  return true;
2062}
Note: See TracBrowser for help on using the repository browser.