source: release/1.9/source/lisp-kernel/gc-common.c @ 16083

Last change on this file since 16083 was 15606, checked in by gb, 6 years ago

This is a work-in-progress; there will need to be new binaries
and similar changes for other architectures.

compiler/nx2.lisp: do late constant-folding on comparisons. (This depends

on being able to use operators for T and NIL in the backend; since backends
don't necessarily support that, check first.)

compiler/optimizers.lisp: bind temporaries for 3-arg numeric comparisons.

compiler/vinsn.lisp: do dead-code elimination at the vinsn level. Because

of the way that "aligned labels" work on x86, introduce an :align vinsn
attribute. Add/change some utilities for finding next/previous vinsn, etc.

compiler/X86/x862.lisp: Handle operators for T/NIL. Peephole optimize

things like (if (let ...)) where the LET returns a constant value and
we need to discard some words from the stack.

compiler/X86/X8632/x8632-arch.lisp:
compiler/X86/X8664/x8664-arch.lisp: Bump image version

compiler/X86/X8632/x8632-vinsns.lisp:
compiler/X86/X8664/x8664-vinsns.lisp: EMIT-ALIGNED-LABEL has :align

attribute

level-0/l0-hash.lisp: Don't assume that GC maintains weak-deletions; do

assume that it maintains count/deleted-count, so lock-based code adjusts
those slots atomically.

level-0/l0-misc.lisp: We don't want to use futexes (at least not instead

of spinlocks.)

level-0/X86/x86-misc.lisp: %ATOMIC-INCF-NODE needs to pause while spinning.

(Note that a locked ADD may be faster on x86, but wouldn't return a
meaningful value and some callers expect it to.)

level-1/l1-clos-boot.lisp: no more DESTRUCTURE-STATE.
level-1/l1-files.lisp: indentation change
level-1/l1-utils.lisp: no more DESTRUCTURE-STATE.
level-1/linux-files.lisp: UNSETENV

lib/hash.lisp: no need to %NORMALIZE-HASH-TABLE-COUNT.
lib/macros.lisp: no more DESTRUCTURE-STATE.

library/lispequ.lisp: no more DESTRUCTURE-STATE.

lisp-kernel/gc-common.c: decrement count when removing weak key from

hash vector; increment deleted-count if not lock-free.

lisp-kernel/x86-constants32.h:
lisp-kernel/x86-constants64.h: bump current, max image versions

lisp-kernel/linuxx8632/Makefile:
lisp-kernel/linuxx8664/Makefile: don't define USE_FUTEX.

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