source: release/1.7/source/lisp-kernel/gc-common.c @ 15267

Last change on this file since 15267 was 14619, checked in by rme, 8 years ago

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

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