source: branches/qres/ccl/lisp-kernel/gc-common.c @ 14049

Last change on this file since 14049 was 14049, checked in by gz, 10 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

File size: 42.2 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;
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
100
101void
102reapweakv(LispObj weakv)
103{
104  /*
105    element 2 of the weak vector should be tagged as a cons: if it
106    isn't, just mark it as a root.  if it is, cdr through it until a
107    "marked" cons is encountered.  If the car of any unmarked cons is
108    marked, mark the cons which contains it; otherwise, splice the
109    cons out of the list.  N.B. : elements 0 and 1 are already marked
110    (or are immediate, etc.)
111  */
112  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
113  LispObj termination_list = lisp_nil;
114  natural weak_type = (natural) deref(weakv,2);
115  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
116    terminatablep = ((weak_type >> population_termination_bit) != 0);
117  Boolean done = false;
118  cons *rawcons;
119  natural dnode, car_dnode;
120  bitvector markbits = GCmarkbits;
121
122  if (terminatablep) {
123    termination_list = deref(weakv,1+3);
124  }
125
126  if (fulltag_of(cell) != fulltag_cons) {
127    mark_root(cell);
128  } else if (alistp) {
129    /* weak alist */
130    while (! done) {
131      dnode = gc_area_dnode(cell);
132      if ((dnode >= GCndnodes_in_area) ||
133          (ref_bit(markbits, dnode))) {
134        done = true;
135      } else {
136        /* Cons cell is unmarked. */
137        LispObj alist_cell, thecar;
138        unsigned cell_tag;
139
140        rawcons = (cons *) ptr_from_lispobj(untag(cell));
141        alist_cell = rawcons->car;
142        cell_tag = fulltag_of(alist_cell);
143
144        if ((cell_tag == fulltag_cons) &&
145            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
146            (! ref_bit(markbits, car_dnode)) &&
147            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
148            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
149            (! ref_bit(markbits, car_dnode))) {
150          *prev = rawcons->cdr;
151          if (terminatablep) {
152            rawcons->cdr = termination_list;
153            termination_list = cell;
154          }
155        } else {
156          set_bit(markbits, dnode);
157          prev = (LispObj *)(&(rawcons->cdr));
158          mark_root(alist_cell);
159        }
160        cell = *prev;
161      }
162    }
163  } else {
164    /* weak list */
165    while (! done) {
166      dnode = gc_area_dnode(cell);
167      if ((dnode >= GCndnodes_in_area) ||
168          (ref_bit(markbits, dnode))) {
169        done = true;
170      } else {
171        /* Cons cell is unmarked. */
172        LispObj thecar;
173        unsigned cartag;
174
175        rawcons = (cons *) ptr_from_lispobj(untag(cell));
176        thecar = rawcons->car;
177        cartag = fulltag_of(thecar);
178
179        if (is_node_fulltag(cartag) &&
180            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
181            (! ref_bit(markbits, car_dnode))) {
182          *prev = rawcons->cdr;
183          if (terminatablep) {
184            rawcons->cdr = termination_list;
185            termination_list = cell;
186          }
187        } else {
188          set_bit(markbits, dnode);
189          prev = (LispObj *)(&(rawcons->cdr));
190        }
191        cell = *prev;
192      }
193    }
194  }
195
196  if (terminatablep) {
197    deref(weakv,1+3) = termination_list;
198  }
199  if (termination_list != lisp_nil) {
200    deref(weakv,1) = GCweakvll;
201    GCweakvll = untag(weakv);
202  } else {
203    deref(weakv,1) = lisp_global(WEAKVLL);
204    lisp_global(WEAKVLL) = untag(weakv);
205  }
206}
207
208/*
209  Screw: doesn't deal with finalization.
210  */
211
212void
213reaphashv(LispObj hashv)
214{
215  hash_table_vector_header
216    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
217  natural
218    dnode;
219  signed_natural
220    npairs = (header_element_count(hashp->header) - 
221              (hash_table_vector_header_count -1)) >> 1;
222  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
223  int weak_index = (((hashp->flags & nhash_weak_value_mask) == 0) ? 0 : 1);
224  Boolean
225    keys_frozen = ((hashp->flags & nhash_keys_frozen_mask) != 0);
226  bitvector markbits = GCmarkbits;
227  int tag;
228
229  natural *tenured_low = (LispObj *)tenured_area->low;
230  natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
231  natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+weak_index), tenured_low);
232  Boolean
233    hashv_tenured = (memo_dnode < tenured_dnodes);
234  natural bits, bitidx, *bitsp;
235
236  if (hashv_tenured) {
237    set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx);
238  }
239
240  while (true) {
241    if (hashv_tenured) {
242      while (bits == 0) {
243        int skip = nbits_in_word - bitidx;
244        npairs -= skip;
245        if (npairs <= 0) break;
246        pairp += (skip+skip);
247        bitidx = 0;
248        bits = *++bitsp;
249      }
250      if (bits != 0) {
251        int skip = (count_leading_zeros(bits) - bitidx);
252        if (skip != 0) {
253          npairs -= skip;
254          pairp += (skip+skip);
255          bitidx += skip;
256        }
257      }
258    }
259
260    if (npairs <= 0) break;
261
262    weakelement = pairp[weak_index];
263    tag = fulltag_of(weakelement);
264    if (is_node_fulltag(tag)) {
265      dnode = gc_area_dnode(weakelement);
266      if ((dnode < GCndnodes_in_area) && 
267          ! ref_bit(markbits, dnode)) {
268        pairp[0] = slot_unbound;
269        if (keys_frozen) {
270          if (pairp[1] != slot_unbound) {
271            pairp[1] = unbound;
272          }
273        }
274        else {
275          pairp[1] = lisp_nil;
276        }
277        hashp->weak_deletions_count += (1<<fixnumshift);
278      }
279    }
280    pairp += 2;
281    --npairs;
282  }
283  deref(hashv, 1) = lisp_global(WEAKVLL);
284  lisp_global(WEAKVLL) = untag(hashv);
285}
286
287void
288traditional_dws_mark_htabv(LispObj htabv)
289{
290  /* Do nothing, just add htabv to GCweakvll */
291  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
292
293  base[1] = GCweakvll;
294  GCweakvll = ptr_to_lispobj(base);
295}
296
297void
298ncircle_dws_mark_htabv(LispObj htabv)
299{
300  /* Do nothing, just add htabv to GCdwsweakvll */
301  deref(htabv,1) = GCdwsweakvll;
302  GCdwsweakvll = htabv;
303}
304
305void
306traditional_mark_weak_htabv(LispObj htabv)
307{
308  int i, skip = hash_table_vector_header_count;;
309  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
310
311  for (i = 2; i <= skip; i++) {
312    rmark(base[i]);
313  }
314  base[1] = GCweakvll;
315  GCweakvll = ptr_to_lispobj(base);
316}
317
318void
319ncircle_mark_weak_htabv(LispObj htabv)
320{
321  int i, skip = hash_table_vector_header_count;
322  hash_table_vector_header *hashp = (hash_table_vector_header *)(untag(htabv));
323  natural
324    npairs = (header_element_count(hashp->header) - 
325              (hash_table_vector_header_count - 1)) >> 1;
326  LispObj *pairp = (LispObj*) (hashp+1);
327  Boolean
328    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
329
330
331  for (i = 2; i <= skip; i++) {
332    rmark(deref(htabv,i));
333  }
334 
335  if (!weak_on_value) {
336    pairp++;
337  }
338  /* unconditionally mark the non-weak element of each pair */
339  while (npairs--) {
340    rmark(*pairp);
341    pairp += 2;
342  }
343  deref(htabv,1)  = GCweakvll;
344  GCweakvll = (LispObj)untag(htabv);
345}
346
347
348Boolean
349mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
350{
351  natural flags = hashp->flags, weak_dnode, nonweak_dnode;
352  Boolean
353    marked_new = false, 
354    weak_marked;
355  int non_weak_index = (((flags & nhash_weak_value_mask) != 0) ? 0 : 1);
356  int 
357    skip = hash_table_vector_header_count-1,
358    weak_tag,
359    nonweak_tag,
360    i;
361  signed_natural
362    npairs = (elements - skip) >> 1;
363  LispObj
364    *pairp = (LispObj*) (hashp+1),
365    weak,
366    nonweak;
367
368  natural *tenured_low = (LispObj *)tenured_area->low;
369  natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
370  natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+non_weak_index), tenured_low);
371  Boolean hashv_tenured = (memo_dnode < tenured_dnodes);
372  natural bits, bitidx, *bitsp;
373
374  if (hashv_tenured) {
375    set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx);
376  }
377
378  /* Mark everything in the header */
379 
380  for (i = 2; i<= skip; i++) {
381    mark_root(deref(ptr_to_lispobj(hashp),i));
382  }
383
384  while (true) {
385    if (hashv_tenured) {
386      while (bits == 0) {
387        int skip = nbits_in_word - bitidx;
388        npairs -= skip;
389        if (npairs <= 0) break;
390        pairp += (skip+skip);
391        bitidx = 0;
392        bits = *++bitsp;
393      }
394      if (bits != 0) {
395        int skip = count_leading_zeros(bits) - bitidx;
396        if (skip != 0) {
397          npairs -= skip;
398          pairp += (skip+skip);
399          bitidx += skip;
400        }
401      }
402    }
403    if (npairs <= 0) break;
404
405    nonweak = pairp[non_weak_index];
406    weak = pairp[1-non_weak_index];
407
408    nonweak_tag = fulltag_of(nonweak);
409    if (is_node_fulltag(nonweak_tag)) {
410      nonweak_dnode = gc_area_dnode(nonweak);
411      if ((nonweak_dnode < GCndnodes_in_area) &&
412          ! ref_bit(GCmarkbits,nonweak_dnode)) {
413        weak_marked = true;
414        weak_tag = fulltag_of(weak);
415        if (is_node_fulltag(weak_tag)) {
416          weak_dnode = gc_area_dnode(weak);
417          if ((weak_dnode < GCndnodes_in_area) &&
418              ! ref_bit(GCmarkbits, weak_dnode)) {
419            weak_marked = false;
420          }
421        }
422        if (weak_marked) {
423          mark_root(nonweak);
424          marked_new = true;
425        }
426      }
427    }
428
429    pairp+=2;
430    --npairs;
431  }
432  return marked_new;
433}
434
435
436Boolean
437mark_weak_alist(LispObj weak_alist, int weak_type)
438{
439  natural
440    elements = header_element_count(header_of(weak_alist)),
441    dnode;
442  int pair_tag;
443  Boolean marked_new = false;
444  LispObj alist, pair, key, value;
445  bitvector markbits = GCmarkbits;
446
447  if (weak_type >> population_termination_bit) {
448    elements -= 1;
449  }
450  for(alist = deref(weak_alist, elements);
451      (fulltag_of(alist) == fulltag_cons) &&
452      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
453      (! ref_bit(markbits,dnode));
454      alist = cdr(alist)) {
455    pair = car(alist);
456    pair_tag = fulltag_of(pair);
457    if ((is_node_fulltag(pair_tag)) &&
458        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
459        (! ref_bit(markbits,dnode))) {
460      if (pair_tag == fulltag_cons) {
461        key = car(pair);
462        if ((! is_node_fulltag(fulltag_of(key))) ||
463            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
464            ref_bit(markbits,dnode)) {
465          /* key is marked, mark value if necessary */
466          value = cdr(pair);
467          if (is_node_fulltag(fulltag_of(value)) &&
468              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
469              (! ref_bit(markbits,dnode))) {
470            mark_root(value);
471            marked_new = true;
472          }
473        }
474      } else {
475          mark_root(pair);
476          marked_new = true;
477      }
478    }
479  }
480  return marked_new;
481}
482 
483void
484mark_termination_lists()
485{
486  /*
487     Mark the termination lists in all terminatable weak vectors, which
488     are now linked together on GCweakvll, and add them to WEAKVLL,
489     which already contains all other weak vectors.
490  */
491  LispObj pending = GCweakvll,
492          *base = (LispObj *)NULL;
493
494  while (pending) {
495    base = ptr_from_lispobj(pending);
496    pending = base[1];
497
498    mark_root(base[1+3]);
499  }
500  if (base) {
501    base[1] = lisp_global(WEAKVLL);
502    lisp_global(WEAKVLL) = GCweakvll;
503  }
504
505}
506
507
508void
509traditional_markhtabvs()
510{
511  LispObj *base, this, header, pending;
512  int subtag;
513  hash_table_vector_header *hashp;
514  Boolean marked_new;
515
516  do {
517    pending = (LispObj) NULL;
518    marked_new = false;
519   
520    while (GCweakvll) {
521      base = ptr_from_lispobj(GCweakvll);
522      GCweakvll = base[1];
523     
524      header = base[0];
525      subtag = header_subtag(header);
526     
527      if (subtag == subtag_weak) {
528        natural weak_type = base[2];
529        this = ptr_to_lispobj(base) + fulltag_misc;
530        base[1] = pending;
531        pending = ptr_to_lispobj(base);
532        if ((weak_type & population_type_mask) == population_weak_alist) {
533          if (mark_weak_alist(this, weak_type)) {
534            marked_new = true;
535          }
536        }
537      } else if (subtag == subtag_hash_vector) {
538        natural elements = header_element_count(header);
539
540        hashp = (hash_table_vector_header *) base;
541        if (hashp->flags & nhash_weak_mask) {
542          base[1] = pending;
543          pending = ptr_to_lispobj(base);
544          if (mark_weak_hash_vector(hashp, elements)) {
545            marked_new = true;
546          }
547        } 
548      } else {
549        Bug(NULL, "Strange object on weak vector linked list: " LISP "\n", base);
550      }
551    }
552
553    if (marked_new) {
554      GCweakvll = pending;
555    }
556  } while (marked_new);
557
558  /* Now, everything's marked that's going to be,  and "pending" is a list
559     of populations and weak hash tables.  CDR down that list and free
560     anything that isn't marked.
561     */
562
563  while (pending) {
564    base = ptr_from_lispobj(pending);
565    pending = base[1];
566    base[1] = (LispObj)NULL;
567
568    this = ptr_to_lispobj(base) + fulltag_misc;
569
570    subtag = header_subtag(base[0]);
571    if (subtag == subtag_weak) {
572      reapweakv(this);
573    } else {
574      reaphashv(this);
575    }
576  }
577  mark_termination_lists();
578}
579
580void
581ncircle_markhtabvs()
582{
583  LispObj *base, this, header, pending = 0;
584  int subtag;
585
586  /* First, process any weak hash tables that may have
587     been encountered by the link-inverting marker; we
588     should have more stack space now. */
589
590  while (GCdwsweakvll) {
591    this = GCdwsweakvll;
592    GCdwsweakvll = deref(this,1);
593    ncircle_mark_weak_htabv(this);
594  }
595
596  while (GCweakvll) {
597    base = ptr_from_lispobj(GCweakvll);
598    GCweakvll = base[1];
599    base[1] = (LispObj)NULL;
600
601    this = ptr_to_lispobj(base) + fulltag_misc;
602
603    header = base[0];
604    subtag = header_subtag(header);
605     
606    if (subtag == subtag_weak) {
607      natural weak_type = base[2];
608      base[1] = pending;
609      pending = ptr_to_lispobj(base);
610      if ((weak_type & population_type_mask) == population_weak_alist) {
611        mark_weak_alist(this, weak_type);
612      }
613    } else if (subtag == subtag_hash_vector) {
614      reaphashv(this);
615    }
616  }
617
618  /* Now, everything's marked that's going to be,  and "pending" is a list
619     of populations.  CDR down that list and free
620     anything that isn't marked.
621     */
622
623  while (pending) {
624    base = ptr_from_lispobj(pending);
625    pending = base[1];
626    base[1] = (LispObj)NULL;
627
628    this = ptr_to_lispobj(base) + fulltag_misc;
629
630    subtag = header_subtag(base[0]);
631    if (subtag == subtag_weak) {
632      reapweakv(this);
633    } else {
634      Bug(NULL, "Bad object on pending list: %s\n", this);
635    }
636  }
637
638  mark_termination_lists();
639}
640
641void
642mark_tcr_tlb(TCR *tcr)
643{
644  natural n = tcr->tlb_limit;
645  LispObj
646    *start = tcr->tlb_pointer,
647    *end = (LispObj *) ((BytePtr)start+n),
648    node;
649
650  while (start < end) {
651    node = *start;
652    if (node != no_thread_local_binding_marker) {
653      mark_root(node);
654    }
655    start++;
656  }
657}
658
659/*
660  Mark things that're only reachable through some (suspended) TCR.
661  (This basically means the tcr's gc_context and the exception
662  frames on its xframe_list.)
663*/
664
665void
666mark_tcr_xframes(TCR *tcr)
667{
668  xframe_list *xframes;
669  ExceptionInformation *xp;
670
671  xp = tcr->gc_context;
672  if (xp) {
673#ifndef X8632
674    mark_xp(xp);
675#else
676    mark_xp(xp, tcr->node_regs_mask);
677#endif
678  }
679#ifdef X8632
680  mark_root(tcr->save0);
681  mark_root(tcr->save1);
682  mark_root(tcr->save2);
683  mark_root(tcr->save3);
684  mark_root(tcr->next_method_context);
685#endif
686 
687  for (xframes = (xframe_list *) tcr->xframe; 
688       xframes; 
689       xframes = xframes->prev) {
690#ifndef X8632
691      mark_xp(xframes->curr);
692#else
693      mark_xp(xframes->curr, xframes->node_regs_mask);
694#endif
695  }
696}
697     
698
699void *postGCptrs = NULL;
700struct xmacptr *user_postGC_macptrs = NULL;
701
702
703void
704postGCfree(void *p)
705{
706  *(void **)p = postGCptrs;
707  postGCptrs = p;
708}
709
710void
711postGCfreexmacptr(struct xmacptr *p)
712{
713  p->class = (LispObj) user_postGC_macptrs;
714  user_postGC_macptrs = p;
715}
716
717
718xmacptr_dispose_fn xmacptr_dispose_functions[xmacptr_flag_user_last-xmacptr_flag_user_first];
719
720
721
722void
723freeGCptrs()
724{
725  void *p, *next, *addr;
726  struct xmacptr *x, *xnext;
727  int i, flags;
728  xmacptr_dispose_fn dfn;
729
730  for (p = postGCptrs; p; p = next) {
731    next = *((void **)p);
732    free(p);
733  }
734  postGCptrs = NULL;
735 
736  for (x = user_postGC_macptrs; x; x = xnext) {
737    xnext = (xmacptr *) (x->class);;
738    flags = x->flags - xmacptr_flag_user_first;
739    dfn = xmacptr_dispose_functions[flags];
740    addr = (void *) x->address;
741    x->address = 0;
742    x->flags = 0;
743    x->link = 0;
744    x->class = 0;
745    if (dfn && addr) {
746      dfn(addr);
747    }
748  }
749
750  user_postGC_macptrs = NULL;
751}
752
753int
754register_xmacptr_dispose_function(void *dfn)
755{
756  int i, k;
757 
758  for( i = 0, k = xmacptr_flag_user_first; k < xmacptr_flag_user_last; i++, k++) {
759    if (xmacptr_dispose_functions[i]==NULL) {
760      xmacptr_dispose_functions[i] = dfn;
761      return k;
762    }
763    if (xmacptr_dispose_functions[i] == dfn) {
764      return k;
765    }
766  }
767  return 0;
768}
769
770void
771reap_gcable_ptrs()
772{
773  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
774  xmacptr_flag flag;
775  natural dnode;
776  xmacptr *x;
777
778  while((next = *prev) != (LispObj)NULL) {
779    dnode = gc_area_dnode(next);
780    x = (xmacptr *) ptr_from_lispobj(untag(next));
781
782    if ((dnode >= GCndnodes_in_area) ||
783        (ref_bit(GCmarkbits,dnode))) {
784      prev = &(x->link);
785    } else {
786      *prev = x->link;
787      flag = (xmacptr_flag)(x->flags);
788      ptr = x->address;
789
790      if (ptr) {
791        switch (flag) {
792        case xmacptr_flag_recursive_lock:
793          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
794          break;
795
796        case xmacptr_flag_ptr:
797          postGCfree((void *)ptr_from_lispobj(ptr));
798          break;
799
800        case xmacptr_flag_rwlock:
801          rwlock_destroy((rwlock *)ptr_from_lispobj(ptr));
802          break;
803
804        case xmacptr_flag_semaphore:
805          destroy_semaphore((void**)&(x->address));
806          break;
807
808        default:
809          if ((flag >= xmacptr_flag_user_first) &&
810              (flag < xmacptr_flag_user_last)) {
811            set_n_bits(GCmarkbits,dnode,3);
812            postGCfreexmacptr(x);
813            break;
814          }
815          /* (warn "unknown xmacptr_flag: ~s" flag) */
816          /* Unknowd, and perhaps unknowdable. */
817          /* Fall in: */
818        case xmacptr_flag_none:
819          break;
820        }
821      }
822    }
823  }
824}
825
826
827
828#if  WORD_SIZE == 64
829unsigned short *_one_bits = NULL;
830
831unsigned short
832logcount16(unsigned short n)
833{
834  unsigned short c=0;
835 
836  while(n) {
837    n = n & (n-1);
838    c++;
839  }
840  return c;
841}
842
843void
844gc_init()
845{
846  int i;
847 
848  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
849
850  for (i = 0; i < (1<<16); i++) {
851    _one_bits[i] = dnode_size*logcount16(i);
852  }
853}
854
855
856#else
857const unsigned char _one_bits[256] = {
858    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,
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    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,
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    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,
863    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,
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    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,
866    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,
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    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,
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    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,
871    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,
872    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,
873    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
874};
875
876
877void
878gc_init()
879{
880}
881
882#endif
883
884
885weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv;
886weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv;
887weak_process_fun markhtabvs = traditional_markhtabvs;
888
889void
890install_weak_mark_functions(natural set) {
891  switch(set) {
892  case 0:
893  default:
894    dws_mark_weak_htabv = traditional_dws_mark_htabv;
895    mark_weak_htabv = traditional_mark_weak_htabv;
896    markhtabvs = traditional_markhtabvs;
897    break;
898  case 1:
899    dws_mark_weak_htabv = ncircle_dws_mark_htabv;
900    mark_weak_htabv = ncircle_mark_weak_htabv;
901    markhtabvs = ncircle_markhtabvs;
902    break;
903  }
904}
905
906void
907init_weakvll ()
908{
909  LispObj this = lisp_global(WEAKVLL); /* all weak vectors as of last gc */
910
911  GCweakvll = (LispObj)NULL;
912  lisp_global(WEAKVLL) = (LispObj)NULL;
913
914  if (GCn_ephemeral_dnodes) {
915    /* For egc case, initialize GCweakvll with weak vectors not in the
916       GC area.  Weak vectors in the GC area will be added during marking.
917    */
918
919    LispObj *tenured_low = (LispObj *)tenured_area->low;
920    natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
921    bitvector refbits = tenured_area->refbits;
922
923    while (this) {
924      LispObj *base = ptr_from_lispobj(this);
925      LispObj next = base[1];
926      natural dnode = gc_dynamic_area_dnode(this);
927      if (dnode < GCndynamic_dnodes_in_area) {
928        base[1] = (LispObj)NULL; /* drop it, might be garbage */
929      } else {
930        base[1] = GCweakvll;
931        GCweakvll = ptr_to_lispobj(base);
932        if (header_subtag(base[0]) == subtag_weak) {
933          dnode = area_dnode(&base[3], tenured_low);
934          if (dnode < tenured_dnodes) {
935            clr_bit(refbits, dnode); /* Don't treat population.data as root */
936          }
937        } else {
938          if (header_subtag(base[0]) != subtag_hash_vector)
939            Bug(NULL, "Unexpected entry " LISP " -> " LISP " on WEAKVLL", base, base[0]);
940          dnode = area_dnode(base, tenured_low);
941          if ((dnode < tenured_dnodes) && !ref_bit(refbits, dnode)) {
942            Boolean drop = true;
943            /* hash vectors get marked headers if they have any ephemeral keys */
944            /* but not if they have ephemeral values. */
945            if (((hash_table_vector_header *)base)->flags & nhash_weak_value_mask) {
946              signed_natural count = (header_element_count(base[0]) + 2) >> 1;
947              natural bits, bitidx, *bitsp;
948              set_bitidx_vars(refbits, dnode, bitsp, bits, bitidx);
949              while ((0 < count) && (bits == 0)) {
950                int skip = nbits_in_word - bitidx;
951                count -= skip;
952                bits = *++bitsp;
953                bitidx = 0;
954              }
955              count -=  (count_leading_zeros(bits) - bitidx);
956
957              if (0 < count) {
958                set_bit(refbits, dnode); /* has ephemeral values, mark header */
959                drop = false;
960              }
961            }
962            if (drop) { /* if nothing ephemeral, drop it from GCweakvll. */
963              GCweakvll = base[1];
964              base[1] = lisp_global(WEAKVLL);
965              lisp_global(WEAKVLL) = ptr_to_lispobj(base);
966            }
967          }
968        }
969      }
970      this = next;
971    }
972  }
973}
974
975 
976void
977preforward_weakvll ()
978{
979  /* reset population refbits for forwarding */
980  if (GCn_ephemeral_dnodes) {
981    LispObj this = lisp_global(WEAKVLL);
982    LispObj *tenured_low = (LispObj *)tenured_area->low;
983    natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
984    bitvector refbits = tenured_area->refbits;
985
986    while (this) {
987      LispObj *base = ptr_from_lispobj(this);
988      if (header_subtag(base[0]) == subtag_weak) {
989        natural dnode = area_dnode(&base[3], tenured_low);
990        if (base[3] >= GCarealow) {
991          if (dnode < tenured_dnodes) {
992            set_bit(refbits, dnode);
993          }
994        }
995        /* might have set termination list to a new pointer */
996        if ((base[2] >> population_termination_bit) && (base[4] >= GCarealow)) {
997          if ((dnode + 1) < tenured_dnodes) {
998            set_bit(refbits, dnode+1);
999          }
1000        }
1001      }
1002      this = base[1];
1003    }
1004  }
1005}
1006
1007
1008void
1009forward_weakvll_links()
1010{
1011  LispObj *ptr = &(lisp_global(WEAKVLL)), this, new, old;
1012
1013  while (this = *ptr) {
1014    old = this + fulltag_misc;
1015    new = node_forwarding_address(old);
1016    if (old != new) {
1017      *ptr = untag(new);
1018    }
1019    ptr = &(deref(new,1));
1020  }
1021}
1022
1023
1024
1025
1026
1027LispObj
1028node_forwarding_address(LispObj node)
1029{
1030  int tag_n;
1031  natural dnode = gc_dynamic_area_dnode(node);
1032
1033  if ((dnode >= GCndynamic_dnodes_in_area) ||
1034      (node < GCfirstunmarked)) {
1035    return node;
1036  }
1037
1038  tag_n = fulltag_of(node);
1039  if (!is_node_fulltag(tag_n)) {
1040    return node;
1041  }
1042
1043  return dnode_forwarding_address(dnode, tag_n);
1044}
1045
1046Boolean
1047update_noderef(LispObj *noderef)
1048{
1049  LispObj
1050    node = *noderef,
1051    new = node_forwarding_address(node);
1052
1053  if (new != node) {
1054    *noderef = new;
1055    return true;
1056  }
1057  return false;
1058}
1059
1060void
1061update_locref(LispObj *locref)
1062{
1063  LispObj
1064    obj = *locref,
1065    new = locative_forwarding_address(obj);
1066
1067  if (new != obj) {
1068    *locref = new;
1069  }
1070}
1071
1072void
1073forward_gcable_ptrs()
1074{
1075  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new;
1076  struct xmacptr **xprev, *xnext, *xnew;
1077
1078  while ((next = *prev) != (LispObj)NULL) {
1079    new = node_forwarding_address(next);
1080    if (new != next) {
1081      *prev = new;
1082    }
1083    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1084  }
1085  xprev = &user_postGC_macptrs;
1086  while (xnext = *xprev) {
1087    xnew = (struct xmacptr *)locative_forwarding_address((LispObj)xnext);
1088    if (xnew != xnext) {
1089      *xprev = xnew;
1090    }
1091    xprev = (struct xmacptr **)(&(xnext->class));
1092  }
1093}
1094
1095void
1096forward_memoized_area(area *a, natural num_memo_dnodes)
1097{
1098  bitvector refbits = a->refbits;
1099  LispObj *p = (LispObj *) a->low, x1, x2, new;
1100  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
1101  int tag_x1;
1102  hash_table_vector_header *hashp = NULL;
1103  Boolean header_p;
1104
1105  if (GCDebug) {
1106    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1107  }
1108
1109  /* This is pretty straightforward, but we have to note
1110     when we move a key in a hash table vector that wants
1111     us to tell it about that. */
1112
1113  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1114  while (memo_dnode < num_memo_dnodes) {
1115    if (bits == 0) {
1116      int remain = nbits_in_word - bitidx;
1117      memo_dnode += remain;
1118      p += (remain+remain);
1119      bits = *++bitsp;
1120      bitidx = 0;
1121    } else {
1122      nextbit = count_leading_zeros(bits);
1123      if ((diff = (nextbit - bitidx)) != 0) {
1124        memo_dnode += diff;
1125        bitidx = nextbit;
1126        p += (diff+diff);
1127      }
1128      x1 = p[0];
1129      x2 = p[1];
1130      tag_x1 = fulltag_of(x1);
1131      bits &= ~(BIT0_MASK >> bitidx);
1132      header_p = (nodeheader_tag_p(tag_x1));
1133
1134      if (header_p &&
1135          (header_subtag(x1) == subtag_hash_vector)) {
1136        hashp = (hash_table_vector_header *) p;
1137        if (hashp->flags & nhash_track_keys_mask) {
1138          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
1139        } else {
1140          hashp = NULL;
1141        }
1142      }
1143
1144
1145      if (! header_p) {
1146        new = node_forwarding_address(x1);
1147        if (new != x1) {
1148          *p = new;
1149        }
1150      }
1151      p++;
1152
1153      new = node_forwarding_address(x2);
1154      if (new != x2) {
1155        *p = new;
1156        if (memo_dnode < hash_dnode_limit) {
1157          /* If this code is reached, 'hashp' is non-NULL and pointing
1158             at the header of a hash_table_vector, and 'memo_dnode' identifies
1159             a pair of words inside the hash_table_vector.  It may be
1160             hard for program analysis tools to recognize that, but I
1161             believe that warnings about 'hashp' being NULL here can
1162             be safely ignored. */
1163          hashp->flags |= nhash_key_moved_mask;
1164          hash_dnode_limit = 0;
1165          hashp = NULL;
1166        }
1167      }
1168      p++;
1169      memo_dnode++;
1170      bitidx++;
1171
1172    }
1173  }
1174}
1175
1176void
1177forward_tcr_tlb(TCR *tcr)
1178{
1179  natural n = tcr->tlb_limit;
1180  LispObj
1181    *start = tcr->tlb_pointer, 
1182    *end = (LispObj *) ((BytePtr)start+n),
1183    node;
1184
1185  while (start < end) {
1186    node = *start;
1187    if (node != no_thread_local_binding_marker) {
1188      update_noderef(start);
1189    }
1190    start++;
1191  }
1192}
1193
1194void
1195reclaim_static_dnodes()
1196{
1197  natural nstatic = tenured_area->static_dnodes, i, bits, bitnum;
1198  cons *c = (cons *)tenured_area->low, *d;
1199  bitvector bitsp = GCmarkbits;
1200  LispObj head = lisp_global(STATIC_CONSES);
1201
1202  if (nstatic) {
1203    if (head) {
1204      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
1205        bits = *bitsp++;
1206        if (bits != ALL_ONES) {
1207          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
1208            if (! (bits & (BIT0_MASK>>bitnum))) {
1209              d = c + bitnum;
1210              d->car = 0;
1211              d->cdr = head;
1212              head = ((LispObj)d)+fulltag_cons;
1213            }
1214          }
1215        }
1216      }
1217      lisp_global(STATIC_CONSES) = head;
1218    } else {
1219      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
1220        bits = *bitsp++;
1221        if (bits != ALL_ONES) {
1222          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
1223            if (! (bits & (BIT0_MASK>>bitnum))) {
1224              d = c + bitnum;
1225              d->car = 0;
1226              d->cdr = 0;
1227            }
1228          }
1229        }
1230      }
1231    }
1232  }
1233}
1234
1235Boolean
1236youngest_non_null_area_p (area *a)
1237{
1238  if (a->active == a->high) {
1239    return false;
1240  } else {
1241    for (a = a->younger; a; a = a->younger) {
1242      if (a->active != a->high) {
1243        return false;
1244      }
1245    }
1246  };
1247  return true;
1248}
1249
1250Boolean just_purified_p = false;
1251
1252/*
1253  All thread's stack areas have been "normalized", as
1254  has the dynamic heap.  (The "active" pointer in these areas
1255  matches the stack pointer/freeptr value at the time that
1256  the exception occurred.)
1257*/
1258
1259#define get_time(when) gettimeofday(&when, NULL)
1260
1261
1262
1263#ifdef FORCE_DWS_MARK
1264#warning recursive marker disabled for testing; remember to re-enable it
1265#endif
1266
1267
1268void 
1269gc(TCR *tcr, signed_natural param)
1270{
1271  struct timeval start, stop;
1272  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1273  unsigned timeidx = 1;
1274  paging_info paging_info_start;
1275  LispObj
1276    pkg = 0,
1277    itabvec = 0;
1278  BytePtr oldfree = a->active, last_zeroed_addr;
1279  TCR *other_tcr;
1280  natural static_dnodes;
1281  natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift;
1282
1283#ifndef FORCE_DWS_MARK
1284  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1285    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1286  } else {
1287    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1288  }
1289#else
1290  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1291#endif
1292
1293  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1294  if (GCephemeral_low) {
1295    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1296  } else {
1297    GCn_ephemeral_dnodes = 0;
1298  }
1299 
1300  if (GCn_ephemeral_dnodes) {
1301    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1302  } else {
1303    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1304  }
1305
1306  if (GCephemeral_low) {
1307    if ((oldfree-g1_area->low) < g1_area->threshold) {
1308      to = g1_area;
1309      note = a;
1310      timeidx = 4;
1311    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1312      to = g2_area;
1313      from = g1_area;
1314      note = g1_area;
1315      timeidx = 3;
1316    } else {
1317      to = tenured_area;
1318      from = g2_area;
1319      note = g2_area;
1320      timeidx = 2;
1321    } 
1322  } else {
1323    note = tenured_area;
1324  }
1325
1326  install_weak_mark_functions(weak_method);
1327 
1328  if (GCverbose) {
1329    char buf[16];
1330
1331    sample_paging_info(&paging_info_start);
1332    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1333    if (GCephemeral_low) {
1334      fprintf(dbgout,
1335              "\n\n;;; Starting Ephemeral GC of generation %d",
1336              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1337    } else {
1338      fprintf(dbgout,"\n\n;;; Starting full GC");
1339    }
1340    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1341  }
1342
1343  get_time(start);
1344
1345  /* The link-inverting marker might need to write to watched areas */
1346  unprotect_watched_areas();
1347
1348  lisp_global(IN_GC) = (1<<fixnumshift);
1349
1350  if (just_purified_p) {
1351    just_purified_p = false;
1352    GCDebug = false;
1353  } else {
1354    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1355    if (GCDebug) {
1356      check_all_areas(tcr);
1357    }
1358  }
1359
1360  if (from) {
1361    untenure_from_area(from);
1362  }
1363  static_dnodes = static_dnodes_for_area(a);
1364  GCmarkbits = a->markbits;
1365  GCarealow = ptr_to_lispobj(a->low);
1366  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1367  GCndnodes_in_area = gc_area_dnode(oldfree);
1368
1369  if (GCndnodes_in_area) {
1370    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1371    GCdynamic_markbits = 
1372      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1373
1374    zero_bits(GCmarkbits, GCndnodes_in_area);
1375
1376    init_weakvll();
1377
1378    if (GCn_ephemeral_dnodes == 0) {
1379      /* For GCTWA, mark the internal package hash table vector of
1380       *PACKAGE*, but don't mark its contents. */
1381      {
1382        LispObj
1383          itab;
1384        natural
1385          dnode, ndnodes;
1386     
1387        pkg = nrs_PACKAGE.vcell;
1388        if ((fulltag_of(pkg) == fulltag_misc) &&
1389            (header_subtag(header_of(pkg)) == subtag_package)) {
1390          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1391          itabvec = car(itab);
1392          dnode = gc_area_dnode(itabvec);
1393          if (dnode < GCndnodes_in_area) {
1394            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1395            set_n_bits(GCmarkbits, dnode, ndnodes);
1396          }
1397        }
1398      }
1399    }
1400
1401    mark_root(lisp_global(STATIC_CONSES));
1402
1403    {
1404      area *next_area;
1405      area_code code;
1406
1407      /* Could make a jump table instead of the typecase */
1408
1409      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1410        switch (code) {
1411        case AREA_TSTACK:
1412          mark_tstack_area(next_area);
1413          break;
1414
1415        case AREA_VSTACK:
1416          mark_vstack_area(next_area);
1417          break;
1418         
1419        case AREA_CSTACK:
1420          mark_cstack_area(next_area);
1421          break;
1422
1423        case AREA_STATIC:
1424        case AREA_WATCHED:
1425        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1426          /* In both of these cases, we -could- use the area's "markbits"
1427             bitvector as a reference map.  It's safe (but slower) to
1428             ignore that map and process the entire area.
1429          */
1430          if (next_area->younger == NULL) {
1431            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1432          }
1433          break;
1434
1435        default:
1436          break;
1437        }
1438      }
1439    }
1440 
1441    if (GCephemeral_low) {
1442      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1443    }
1444
1445    other_tcr = tcr;
1446    do {
1447      mark_tcr_xframes(other_tcr);
1448      mark_tcr_tlb(other_tcr);
1449      other_tcr = other_tcr->next;
1450    } while (other_tcr != tcr);
1451
1452
1453
1454
1455    /* Go back through *package*'s internal symbols, marking
1456       any that aren't worthless.
1457    */
1458   
1459    if (itabvec) {
1460      natural
1461        i,
1462        n = header_element_count(header_of(itabvec));
1463      LispObj
1464        sym,
1465        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1466
1467      for (i = 0; i < n; i++) {
1468        sym = *raw++;
1469        if (is_symbol_fulltag(sym)) {
1470          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1471          natural dnode = gc_area_dnode(sym);
1472         
1473          if ((dnode < GCndnodes_in_area) &&
1474              (!ref_bit(GCmarkbits,dnode))) {
1475            /* Symbol is in GC area, not marked.
1476               Mark it if fboundp, boundp, or if
1477               it has a plist or another home package.
1478            */
1479           
1480            if (FBOUNDP(rawsym) ||
1481                BOUNDP(rawsym) ||
1482                (rawsym->flags != 0) || /* SPECIAL, etc. */
1483                (rawsym->plist != lisp_nil) ||
1484                ((rawsym->package_predicate != pkg) &&
1485                 (rawsym->package_predicate != lisp_nil))) {
1486              mark_root(sym);
1487            }
1488          }
1489        }
1490      }
1491    }
1492
1493    (void)markhtabvs();
1494
1495    if (itabvec) {
1496      natural
1497        i,
1498        n = header_element_count(header_of(itabvec));
1499      LispObj
1500        sym,
1501        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1502
1503      for (i = 0; i < n; i++, raw++) {
1504        sym = *raw;
1505        if (is_symbol_fulltag(sym)) {
1506          natural dnode = gc_area_dnode(sym);
1507
1508          if ((dnode < GCndnodes_in_area) &&
1509              (!ref_bit(GCmarkbits,dnode))) {
1510            *raw = unbound_marker;
1511          }
1512        }
1513      }
1514    }
1515 
1516    reap_gcable_ptrs();
1517
1518    preforward_weakvll();
1519
1520    GCrelocptr = global_reloctab;
1521    GCfirstunmarked = calculate_relocation();
1522
1523    if (!GCephemeral_low) {
1524      reclaim_static_dnodes();
1525    }
1526
1527    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1528
1529    other_tcr = tcr;
1530    do {
1531      forward_tcr_xframes(other_tcr);
1532      forward_tcr_tlb(other_tcr);
1533      other_tcr = other_tcr->next;
1534    } while (other_tcr != tcr);
1535
1536 
1537    forward_gcable_ptrs();
1538
1539
1540
1541    {
1542      area *next_area;
1543      area_code code;
1544
1545      /* Could make a jump table instead of the typecase */
1546
1547      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1548        switch (code) {
1549        case AREA_TSTACK:
1550          forward_tstack_area(next_area);
1551          break;
1552
1553        case AREA_VSTACK:
1554          forward_vstack_area(next_area);
1555          break;
1556
1557        case AREA_CSTACK:
1558          forward_cstack_area(next_area);
1559          break;
1560
1561        case AREA_STATIC:
1562        case AREA_WATCHED:
1563        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1564          if (next_area->younger == NULL) {
1565            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1566          }
1567          break;
1568
1569        default:
1570          break;
1571        }
1572      }
1573    }
1574
1575    if (GCephemeral_low) {
1576      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1577    }
1578 
1579    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1580
1581    forward_weakvll_links();
1582
1583    if (to) {
1584      tenure_to_area(to);
1585    }
1586
1587
1588    resize_dynamic_heap(a->active,
1589                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1590
1591    if (oldfree < a->high) {
1592      last_zeroed_addr = oldfree;
1593    } else {
1594      last_zeroed_addr = a->high;
1595    }
1596    zero_memory_range(a->active, last_zeroed_addr);
1597
1598    /*
1599      If the EGC is enabled: If there's no room for the youngest
1600      generation, untenure everything.  If this was a full GC and
1601      there's now room for the youngest generation, tenure everything.
1602    */
1603    if (a->older != NULL) {
1604      natural nfree = (a->high - a->active);
1605
1606
1607      if (nfree < a->threshold) {
1608        untenure_from_area(tenured_area);
1609      } else {
1610        if (GCephemeral_low == 0) {
1611          tenure_to_area(tenured_area);
1612        }
1613      }
1614    }
1615  }
1616  lisp_global(GC_NUM) += (1<<fixnumshift);
1617  if (note) {
1618    note->gccount += (1<<fixnumshift);
1619  }
1620
1621  if (GCDebug) {
1622    check_all_areas(tcr);
1623  }
1624
1625 
1626  lisp_global(IN_GC) = 0;
1627 
1628  protect_watched_areas();
1629
1630  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1631  get_time(stop);
1632
1633  {
1634    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1635    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1636    LispObj val;
1637    struct timeval *timeinfo, elapsed = {0, 0};
1638
1639    val = total_gc_microseconds->vcell;
1640    if ((fulltag_of(val) == fulltag_misc) &&
1641        (header_subtag(header_of(val)) == subtag_macptr)) {
1642      timersub(&stop, &start, &elapsed);
1643      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1644      timeradd(timeinfo,  &elapsed, timeinfo);
1645      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1646    }
1647
1648    val = total_bytes_freed->vcell;
1649    if ((fulltag_of(val) == fulltag_misc) &&
1650        (header_subtag(header_of(val)) == subtag_macptr)) {
1651      long long justfreed = oldfree - a->active;
1652      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1653      if (GCverbose) {
1654        char buf[16];
1655        paging_info paging_info_stop;
1656
1657        sample_paging_info(&paging_info_stop);
1658        if (justfreed <= heap_segment_size) {
1659          justfreed = 0;
1660        }
1661        comma_output_decimal(buf,16,justfreed);
1662        if (note == tenured_area) {
1663          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1664        } else {
1665          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1666                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1667                  buf, 
1668                  elapsed.tv_sec, elapsed.tv_usec);
1669        }
1670        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
1671      }
1672    }
1673  }
1674}
Note: See TracBrowser for help on using the repository browser.