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

Last change on this file since 8561 was 8561, checked in by andreas, 12 years ago
  • no pid_t on native Windows
  • not gettimeofday either
  • C calling conventions are different: short documentation, and one implementation
File size: 34.5 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp_globals.h"
19#include "bits.h"
20#include "gc.h"
21#include "area.h"
22#include "Threads.h"
23#include <stddef.h>
24#include <stdlib.h>
25#include <string.h>
26
27#ifndef WINDOWS
28#include <sys/time.h>
29#endif
30
31#ifndef timeradd
32# define timeradd(a, b, result)                                               \
33  do {                                                                        \
34    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
35    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
36    if ((result)->tv_usec >= 1000000)                                         \
37      {                                                                       \
38        ++(result)->tv_sec;                                                   \
39        (result)->tv_usec -= 1000000;                                         \
40      }                                                                       \
41  } while (0)
42#endif
43#ifndef timersub
44# define timersub(a, b, result)                                               \
45  do {                                                                        \
46    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
47    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
48    if ((result)->tv_usec < 0) {                                              \
49      --(result)->tv_sec;                                                     \
50      (result)->tv_usec += 1000000;                                           \
51    }                                                                         \
52  } while (0)
53#endif
54
55void
56comma_output_decimal(char *buf, int len, natural n) 
57{
58  int nout = 0;
59
60  buf[--len] = 0;
61  do {
62    buf[--len] = n%10+'0';
63    n = n/10;
64    if (n == 0) {
65      while (len) {
66        buf[--len] = ' ';
67      }
68      return;
69    }
70    if (len == 0) return;
71    nout ++;
72    if (nout == 3) {
73      buf[--len] = ',';
74      nout = 0;
75    }
76  } while (len >= 0);
77}
78
79
80natural
81static_dnodes_for_area(area *a)
82{
83  if (a->low == tenured_area->low) {
84    return tenured_area->static_dnodes;
85  }
86  return 0;
87}
88
89Boolean GCDebug = false, GCverbose = false;
90bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
91LispObj GCarealow = 0, GCareadynamiclow = 0;
92natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0;
93LispObj GCweakvll = (LispObj)NULL;
94LispObj GCdwsweakvll = (LispObj)NULL;
95LispObj GCephemeral_low = 0;
96natural GCn_ephemeral_dnodes = 0;
97natural GCstack_limit = 0;
98
99
100void
101reapweakv(LispObj weakv)
102{
103  /*
104    element 2 of the weak vector should be tagged as a cons: if it
105    isn't, just mark it as a root.  if it is, cdr through it until a
106    "marked" cons is encountered.  If the car of any unmarked cons is
107    marked, mark the cons which contains it; otherwise, splice the
108    cons out of the list.  N.B. : elements 0 and 1 are already marked
109    (or are immediate, etc.)
110  */
111  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
112  LispObj termination_list = lisp_nil;
113  natural weak_type = (natural) deref(weakv,2);
114  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
115    terminatablep = ((weak_type >> population_termination_bit) != 0);
116  Boolean done = false;
117  cons *rawcons;
118  natural dnode, car_dnode;
119  bitvector markbits = GCmarkbits;
120
121  if (terminatablep) {
122    termination_list = deref(weakv,1+3);
123  }
124
125  if (fulltag_of(cell) != fulltag_cons) {
126    mark_root(cell);
127  } else if (alistp) {
128    /* weak alist */
129    while (! done) {
130      dnode = gc_area_dnode(cell);
131      if ((dnode >= GCndnodes_in_area) ||
132          (ref_bit(markbits, dnode))) {
133        done = true;
134      } else {
135        /* Cons cell is unmarked. */
136        LispObj alist_cell, thecar;
137        unsigned cell_tag;
138
139        rawcons = (cons *) ptr_from_lispobj(untag(cell));
140        alist_cell = rawcons->car;
141        cell_tag = fulltag_of(alist_cell);
142
143        if ((cell_tag == fulltag_cons) &&
144            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
145            (! ref_bit(markbits, car_dnode)) &&
146            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
147            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
148            (! ref_bit(markbits, car_dnode))) {
149          *prev = rawcons->cdr;
150          if (terminatablep) {
151            rawcons->cdr = termination_list;
152            termination_list = cell;
153          }
154        } else {
155          set_bit(markbits, dnode);
156          prev = (LispObj *)(&(rawcons->cdr));
157          mark_root(alist_cell);
158        }
159        cell = *prev;
160      }
161    }
162  } else {
163    /* weak list */
164    while (! done) {
165      dnode = gc_area_dnode(cell);
166      if ((dnode >= GCndnodes_in_area) ||
167          (ref_bit(markbits, dnode))) {
168        done = true;
169      } else {
170        /* Cons cell is unmarked. */
171        LispObj thecar;
172        unsigned cartag;
173
174        rawcons = (cons *) ptr_from_lispobj(untag(cell));
175        thecar = rawcons->car;
176        cartag = fulltag_of(thecar);
177
178        if (is_node_fulltag(cartag) &&
179            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
180            (! ref_bit(markbits, car_dnode))) {
181          *prev = rawcons->cdr;
182          if (terminatablep) {
183            rawcons->cdr = termination_list;
184            termination_list = cell;
185          }
186        } else {
187          set_bit(markbits, dnode);
188          prev = (LispObj *)(&(rawcons->cdr));
189        }
190        cell = *prev;
191      }
192    }
193  }
194
195  if (terminatablep) {
196    deref(weakv,1+3) = termination_list;
197    if (termination_list != lisp_nil) {
198      deref(weakv,1) = GCweakvll;
199      GCweakvll = weakv;
200    }
201  }
202}
203
204/*
205  Screw: doesn't deal with finalization.
206  */
207
208void
209reaphashv(LispObj hashv)
210{
211  hash_table_vector_header
212    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
213  natural
214    dnode,
215    npairs = (header_element_count(hashp->header) - 
216              (hash_table_vector_header_count -1)) >> 1;
217  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
218  Boolean
219    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
220  bitvector markbits = GCmarkbits;
221  int tag;
222
223  while (npairs--) {
224    if (weak_on_value) {
225      weakelement = pairp[1];
226    } else {
227      weakelement = pairp[0];
228    }
229    tag = fulltag_of(weakelement);
230    if (is_node_fulltag(tag)) {
231      dnode = gc_area_dnode(weakelement);
232      if ((dnode < GCndnodes_in_area) && 
233          ! ref_bit(markbits, dnode)) {
234        pairp[0] = slot_unbound;
235        pairp[1] = lisp_nil;
236        hashp->weak_deletions_count += (1<<fixnumshift);
237      }
238    }
239    pairp += 2;
240  }
241}
242
243void
244traditional_dws_mark_htabv(LispObj htabv)
245{
246  /* Do nothing, just add htabv to GCweakvll */
247  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
248 
249  deref(base,1) = GCweakvll;
250  GCweakvll = htabv;
251}
252
253void
254ncircle_dws_mark_htabv(LispObj htabv)
255{
256  /* Do nothing, just add htabv to GCdwsweakvll */
257  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
258 
259  deref(base,1) = GCdwsweakvll;
260  GCdwsweakvll = htabv;
261}
262
263void
264traditional_mark_weak_htabv(LispObj htabv)
265{
266  int i, skip = hash_table_vector_header_count;;
267
268  for (i = 2; i <= skip; i++) {
269    rmark(deref(htabv,i));
270  }
271
272  deref(htabv,1) = GCweakvll;
273  GCweakvll = htabv;
274}
275
276void
277ncircle_mark_weak_htabv(LispObj htabv)
278{
279  int i, skip = hash_table_vector_header_count;
280  hash_table_vector_header *hashp = (hash_table_vector_header *)(untag(htabv));
281  natural
282    dnode,
283    npairs = (header_element_count(hashp->header) - 
284              (hash_table_vector_header_count - 1)) >> 1;
285  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
286  Boolean
287    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
288  bitvector markbits = GCmarkbits;
289  int tag;
290
291  for (i = 2; i <= skip; i++) {
292    rmark(deref(htabv,i));
293  }
294 
295  if (!weak_on_value) {
296    pairp++;
297  }
298  /* unconditionally mark the non-weak element of each pair */
299  while (npairs--) {
300    rmark(*pairp);
301    pairp += 2;
302  }
303
304  deref(htabv,1) = GCweakvll;
305  GCweakvll = htabv;
306}
307
308
309Boolean
310mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
311{
312  natural flags = hashp->flags, key_dnode, val_dnode;
313  Boolean
314    marked_new = false, 
315    key_marked,
316    val_marked,
317    weak_value = ((flags & nhash_weak_value_mask) != 0);
318  int 
319    skip = hash_table_vector_header_count-1,
320    key_tag,
321    val_tag,
322    i;
323  LispObj
324    *pairp = (LispObj*) (hashp+1),
325    key,
326    val;
327
328  /* Mark everything in the header */
329 
330  for (i = 2; i<= skip; i++) {
331    mark_root(deref(ptr_to_lispobj(hashp),i));
332  }
333
334  elements -= skip;
335
336  for (i = 0; i<elements; i+=2, pairp+=2) {
337    key = pairp[0];
338    val = pairp[1];
339    key_marked = val_marked = true;
340    key_tag = fulltag_of(key);
341    val_tag = fulltag_of(val);
342    if (is_node_fulltag(key_tag)) {
343      key_dnode = gc_area_dnode(key);
344      if ((key_dnode < GCndnodes_in_area) &&
345          ! ref_bit(GCmarkbits,key_dnode)) {
346        key_marked = false;
347      }
348    }
349    if (is_node_fulltag(val_tag)) {
350      val_dnode = gc_area_dnode(val);
351      if ((val_dnode < GCndnodes_in_area) &&
352          ! ref_bit(GCmarkbits,val_dnode)) {
353        val_marked = false;
354      }
355    }
356
357    if (weak_value) {
358      if (val_marked & !key_marked) {
359        mark_root(key);
360        marked_new = true;
361      }
362    } else {
363      if (key_marked & !val_marked) {
364        mark_root(val);
365        marked_new = true;
366      }
367    }
368  }
369  return marked_new;
370}
371
372
373Boolean
374mark_weak_alist(LispObj weak_alist, int weak_type)
375{
376  natural
377    elements = header_element_count(header_of(weak_alist)),
378    dnode;
379  int pair_tag;
380  Boolean marked_new = false;
381  LispObj alist, pair, key, value;
382  bitvector markbits = GCmarkbits;
383
384  if (weak_type >> population_termination_bit) {
385    elements -= 1;
386  }
387  for(alist = deref(weak_alist, elements);
388      (fulltag_of(alist) == fulltag_cons) &&
389      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
390      (! ref_bit(markbits,dnode));
391      alist = cdr(alist)) {
392    pair = car(alist);
393    pair_tag = fulltag_of(pair);
394    if ((is_node_fulltag(pair_tag)) &&
395        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
396        (! ref_bit(markbits,dnode))) {
397      if (pair_tag == fulltag_cons) {
398        key = car(pair);
399        if ((! is_node_fulltag(fulltag_of(key))) ||
400            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
401            ref_bit(markbits,dnode)) {
402          /* key is marked, mark value if necessary */
403          value = cdr(pair);
404          if (is_node_fulltag(fulltag_of(value)) &&
405              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
406              (! ref_bit(markbits,dnode))) {
407            mark_root(value);
408            marked_new = true;
409          }
410        }
411      } else {
412          mark_root(pair);
413          marked_new = true;
414      }
415    }
416  }
417  return marked_new;
418}
419 
420void
421traditional_markhtabvs()
422{
423  LispObj this, header, pending;
424  int subtag;
425  bitvector markbits = GCmarkbits;
426  hash_table_vector_header *hashp;
427  Boolean marked_new;
428
429  do {
430    pending = (LispObj) NULL;
431    marked_new = false;
432   
433    while (GCweakvll) {
434      this = GCweakvll;
435      GCweakvll = deref(this,1);
436     
437      header = header_of(this);
438      subtag = header_subtag(header);
439     
440      if (subtag == subtag_weak) {
441        natural weak_type = deref(this,2);
442        deref(this,1) = pending;
443        pending = this;
444        if ((weak_type & population_type_mask) == population_weak_alist) {
445          if (mark_weak_alist(this, weak_type)) {
446            marked_new = true;
447          }
448        }
449      } else if (subtag == subtag_hash_vector) {
450        natural elements = header_element_count(header), i;
451
452        hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this));
453        if (hashp->flags & nhash_weak_mask) {
454          deref(this,1) = pending;
455          pending = this;
456          if (mark_weak_hash_vector(hashp, elements)) {
457            marked_new = true;
458          }
459        } 
460      } else {
461        Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this);
462      }
463    }
464
465    if (marked_new) {
466      GCweakvll = pending;
467    }
468  } while (marked_new);
469
470  /* Now, everything's marked that's going to be,  and "pending" is a list
471     of populations and weak hash tables.  CDR down that list and free
472     anything that isn't marked.
473     */
474
475  while (pending) {
476    this = pending;
477    pending = deref(this,1);
478    deref(this,1) = (LispObj)NULL;
479
480    subtag = header_subtag(header_of(this));
481    if (subtag == subtag_weak) {
482      reapweakv(this);
483    } else {
484      reaphashv(this);
485    }
486  }
487
488  /* Finally, mark the termination lists in all terminatable weak vectors
489     They are now linked together on GCweakvll.
490     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
491     but it will force terminatable popualations to hold on to each other
492     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
493     */
494  pending = GCweakvll;
495  GCweakvll = (LispObj)NULL;
496  while (pending) {
497    this = pending;
498    pending = deref(this,1);
499    deref(this,1) = (LispObj)NULL;
500    mark_root(deref(this,1+3));
501  }
502}
503
504void
505ncircle_markhtabvs()
506{
507  LispObj this, header, pending = 0;
508  int subtag;
509  bitvector markbits = GCmarkbits;
510  hash_table_vector_header *hashp;
511  Boolean marked_new;
512
513  /* First, process any weak hash tables that may have
514     been encountered by the link-inverting marker; we
515     should have more stack space now. */
516
517  while (GCdwsweakvll) {
518    this = GCdwsweakvll;
519    GCdwsweakvll = deref(this,1);
520    ncircle_mark_weak_htabv(this);
521  }
522
523  while (GCweakvll) {
524    this = GCweakvll;
525    GCweakvll = deref(this,1);
526     
527    header = header_of(this);
528    subtag = header_subtag(header);
529     
530    if (subtag == subtag_weak) {
531      natural weak_type = deref(this,2);
532      deref(this,1) = pending;
533      pending = this;
534      if ((weak_type & population_type_mask) == population_weak_alist) {
535        if (mark_weak_alist(this, weak_type)) {
536          marked_new = true;
537          }
538      }
539    } else if (subtag == subtag_hash_vector) {
540      reaphashv(this);
541    }
542  }
543
544  /* Now, everything's marked that's going to be,  and "pending" is a list
545     of populations.  CDR down that list and free
546     anything that isn't marked.
547     */
548
549  while (pending) {
550    this = pending;
551    pending = deref(this,1);
552    deref(this,1) = (LispObj)NULL;
553
554    subtag = header_subtag(header_of(this));
555    if (subtag == subtag_weak) {
556      reapweakv(this);
557    } else {
558      Bug(NULL, "Bad object on pending list: %s\n", this);
559    }
560  }
561
562  /* Finally, mark the termination lists in all terminatable weak vectors
563     They are now linked together on GCweakvll.
564     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
565     but it will force terminatable popualations to hold on to each other
566     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
567     */
568  pending = GCweakvll;
569  GCweakvll = (LispObj)NULL;
570  while (pending) {
571    this = pending;
572    pending = deref(this,1);
573    deref(this,1) = (LispObj)NULL;
574    mark_root(deref(this,1+3));
575  }
576}
577
578void
579mark_tcr_tlb(TCR *tcr)
580{
581  natural n = tcr->tlb_limit;
582  LispObj
583    *start = tcr->tlb_pointer,
584    *end = (LispObj *) ((BytePtr)start+n),
585    node;
586
587  while (start < end) {
588    node = *start;
589    if (node != no_thread_local_binding_marker) {
590      mark_root(node);
591    }
592    start++;
593  }
594}
595
596/*
597  Mark things that're only reachable through some (suspended) TCR.
598  (This basically means the tcr's gc_context and the exception
599  frames on its xframe_list.)
600*/
601
602void
603mark_tcr_xframes(TCR *tcr)
604{
605  xframe_list *xframes;
606  ExceptionInformation *xp;
607
608  xp = tcr->gc_context;
609  if (xp) {
610    mark_xp(xp);
611  }
612 
613  for (xframes = (xframe_list *) tcr->xframe; 
614       xframes; 
615       xframes = xframes->prev) {
616      mark_xp(xframes->curr);
617  }
618}
619     
620
621void *postGCptrs = NULL;
622
623void
624postGCfree(void *p)
625{
626  *(void **)p = postGCptrs;
627  postGCptrs = p;
628}
629
630void
631freeGCptrs()
632{
633  void *p, *next;
634
635  for (p = postGCptrs; p; p = next) {
636    next = *((void **)p);
637    free(p);
638  }
639  postGCptrs = NULL;
640}
641
642void
643reap_gcable_ptrs()
644{
645  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
646  xmacptr_flag flag;
647  natural dnode;
648  xmacptr *x;
649
650  while((next = *prev) != (LispObj)NULL) {
651    dnode = gc_area_dnode(next);
652    x = (xmacptr *) ptr_from_lispobj(untag(next));
653
654    if ((dnode >= GCndnodes_in_area) ||
655        (ref_bit(GCmarkbits,dnode))) {
656      prev = &(x->link);
657    } else {
658      *prev = x->link;
659      flag = (xmacptr_flag)(x->flags);
660      ptr = x->address;
661
662      if (ptr) {
663        switch (flag) {
664        case xmacptr_flag_recursive_lock:
665          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
666          break;
667
668        case xmacptr_flag_ptr:
669          postGCfree((void *)ptr_from_lispobj(ptr));
670          break;
671
672        case xmacptr_flag_rwlock:
673          rwlock_destroy((rwlock *)ptr_from_lispobj(ptr));
674          break;
675
676        case xmacptr_flag_semaphore:
677          destroy_semaphore((void**)&(x->address));
678          break;
679
680        default:
681          /* (warn "unknown xmacptr_flag: ~s" flag) */
682          /* Unknowd, and perhaps unknowdable. */
683          /* Fall in: */
684        case xmacptr_flag_none:
685          break;
686        }
687      }
688    }
689  }
690}
691
692
693
694#if  WORD_SIZE == 64
695unsigned short *_one_bits = NULL;
696
697unsigned short
698logcount16(unsigned short n)
699{
700  unsigned short c=0;
701 
702  while(n) {
703    n = n & (n-1);
704    c++;
705  }
706  return c;
707}
708
709void
710gc_init()
711{
712  int i;
713 
714  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
715
716  for (i = 0; i < (1<<16); i++) {
717    _one_bits[i] = dnode_size*logcount16(i);
718  }
719}
720
721
722#else
723const unsigned char _one_bits[256] = {
724    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,
725    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,
726    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,
727    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,
728    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,
729    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,
730    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,
731    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,
732    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,
733    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,
734    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,
735    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,
736    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,
737    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,
738    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,
739    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
740};
741
742
743void
744gc_init()
745{
746}
747
748#endif
749
750
751weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv;
752weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv;
753weak_process_fun markhtabvs = traditional_markhtabvs;
754
755void
756install_weak_mark_functions(natural set) {
757  switch(set) {
758  case 0:
759  default:
760    dws_mark_weak_htabv = traditional_dws_mark_htabv;
761    mark_weak_htabv = traditional_mark_weak_htabv;
762    markhtabvs = traditional_markhtabvs;
763    break;
764  case 1:
765    dws_mark_weak_htabv = ncircle_dws_mark_htabv;
766    mark_weak_htabv = ncircle_mark_weak_htabv;
767    markhtabvs = ncircle_markhtabvs;
768    break;
769  }
770}
771
772LispObj
773node_forwarding_address(LispObj node)
774{
775  int tag_n;
776  natural dnode = gc_dynamic_area_dnode(node);
777
778  if ((dnode >= GCndynamic_dnodes_in_area) ||
779      (node < GCfirstunmarked)) {
780    return node;
781  }
782
783  tag_n = fulltag_of(node);
784  if (!is_node_fulltag(tag_n)) {
785    return node;
786  }
787
788  return dnode_forwarding_address(dnode, tag_n);
789}
790
791Boolean
792update_noderef(LispObj *noderef)
793{
794  LispObj
795    node = *noderef,
796    new = node_forwarding_address(node);
797
798  if (new != node) {
799    *noderef = new;
800    return true;
801  }
802  return false;
803}
804
805void
806update_locref(LispObj *locref)
807{
808  LispObj
809    obj = *locref,
810    new = locative_forwarding_address(obj);
811
812  if (new != obj) {
813    *locref = new;
814  }
815}
816
817void
818forward_gcable_ptrs()
819{
820  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new;
821
822  while ((next = *prev) != (LispObj)NULL) {
823    new = node_forwarding_address(next);
824    if (new != next) {
825      *prev = new;
826    }
827    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
828  }
829}
830
831void
832forward_memoized_area(area *a, natural num_memo_dnodes)
833{
834  bitvector refbits = a->refbits;
835  LispObj *p = (LispObj *) a->low, x1, x2, new;
836  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
837  int tag_x1;
838  hash_table_vector_header *hashp = NULL;
839  Boolean header_p;
840
841  if (GCDebug) {
842    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
843  }
844
845  /* This is pretty straightforward, but we have to note
846     when we move a key in a hash table vector that wants
847     us to tell it about that. */
848
849  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
850  while (memo_dnode < num_memo_dnodes) {
851    if (bits == 0) {
852      int remain = nbits_in_word - bitidx;
853      memo_dnode += remain;
854      p += (remain+remain);
855      bits = *++bitsp;
856      bitidx = 0;
857    } else {
858      nextbit = count_leading_zeros(bits);
859      if ((diff = (nextbit - bitidx)) != 0) {
860        memo_dnode += diff;
861        bitidx = nextbit;
862        p += (diff+diff);
863      }
864      x1 = p[0];
865      x2 = p[1];
866      tag_x1 = fulltag_of(x1);
867      bits &= ~(BIT0_MASK >> bitidx);
868      header_p = (nodeheader_tag_p(tag_x1));
869
870      if (header_p &&
871          (header_subtag(x1) == subtag_hash_vector)) {
872        hashp = (hash_table_vector_header *) p;
873        if (hashp->flags & nhash_track_keys_mask) {
874          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
875        } else {
876          hashp = NULL;
877        }
878      }
879
880
881      if (! header_p) {
882        new = node_forwarding_address(x1);
883        if (new != x1) {
884          *p = new;
885        }
886      }
887      p++;
888
889      new = node_forwarding_address(x2);
890      if (new != x2) {
891        *p = new;
892        if (memo_dnode < hash_dnode_limit) {
893          hashp->flags |= nhash_key_moved_mask;
894          hash_dnode_limit = 0;
895          hashp = NULL;
896        }
897      }
898      p++;
899      memo_dnode++;
900      bitidx++;
901
902    }
903  }
904}
905
906void
907forward_tcr_tlb(TCR *tcr)
908{
909  natural n = tcr->tlb_limit;
910  LispObj
911    *start = tcr->tlb_pointer, 
912    *end = (LispObj *) ((BytePtr)start+n),
913    node;
914
915  while (start < end) {
916    node = *start;
917    if (node != no_thread_local_binding_marker) {
918      update_noderef(start);
919    }
920    start++;
921  }
922}
923
924void
925reclaim_static_dnodes()
926{
927  natural nstatic = tenured_area->static_dnodes, i, bits, mask, bitnum;
928  cons *c = (cons *)tenured_area->low, *d;
929  bitvector bitsp = GCmarkbits;
930  LispObj head = lisp_global(STATIC_CONSES);
931
932  if (nstatic) {
933    if (head) {
934      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
935        bits = *bitsp++;
936        if (bits != ALL_ONES) {
937          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
938            if (! (bits & (BIT0_MASK>>bitnum))) {
939              d = c + bitnum;
940              d->car = 0;
941              d->cdr = head;
942              head = ((LispObj)d)+fulltag_cons;
943            }
944          }
945        }
946      }
947      lisp_global(STATIC_CONSES) = head;
948    } else {
949      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
950        bits = *bitsp++;
951        if (bits != ALL_ONES) {
952          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
953            if (! (bits & (BIT0_MASK>>bitnum))) {
954              d = c + bitnum;
955              d->car = 0;
956              d->cdr = 0;
957            }
958          }
959        }
960      }
961    }
962  }
963}
964
965Boolean
966youngest_non_null_area_p (area *a)
967{
968  if (a->active == a->high) {
969    return false;
970  } else {
971    for (a = a->younger; a; a = a->younger) {
972      if (a->active != a->high) {
973        return false;
974      }
975    }
976  };
977  return true;
978}
979
980Boolean just_purified_p = false;
981
982/*
983  All thread's stack areas have been "normalized", as
984  has the dynamic heap.  (The "active" pointer in these areas
985  matches the stack pointer/freeptr value at the time that
986  the exception occurred.)
987*/
988
989#ifdef WINDOWS
990#define get_time(when) /* FIXME */
991#else
992#define get_time(when) gettimeofday(&when, NULL)
993#endif
994
995
996#ifdef FORCE_DWS_MARK
997#warning recursive marker disabled for testing; remember to re-enable it
998#endif
999
1000
1001void 
1002gc(TCR *tcr, signed_natural param)
1003{
1004  xframe_list *xframes = (tcr->xframe);
1005  struct timeval start, stop;
1006  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1007  unsigned timeidx = 1;
1008  paging_info paging_info_start;
1009  xframe_list *x;
1010  LispObj
1011    pkg,
1012    itabvec = 0;
1013  BytePtr oldfree = a->active;
1014  TCR *other_tcr;
1015  natural static_dnodes;
1016
1017  install_weak_mark_functions(lisp_global(WEAK_GC_METHOD) >> fixnumshift);
1018
1019
1020
1021#ifndef FORCE_DWS_MARK
1022  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1023    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1024  } else {
1025    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1026  }
1027#else
1028  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1029#endif
1030
1031  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1032  if (GCephemeral_low) {
1033    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1034  } else {
1035    GCn_ephemeral_dnodes = 0;
1036  }
1037 
1038  if (GCn_ephemeral_dnodes) {
1039    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1040  } else {
1041    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1042  }
1043
1044  if (GCephemeral_low) {
1045    if ((oldfree-g1_area->low) < g1_area->threshold) {
1046      to = g1_area;
1047      note = a;
1048      timeidx = 4;
1049    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1050      to = g2_area;
1051      from = g1_area;
1052      note = g1_area;
1053      timeidx = 3;
1054    } else {
1055      to = tenured_area;
1056      from = g2_area;
1057      note = g2_area;
1058      timeidx = 2;
1059    } 
1060  } else {
1061    note = tenured_area;
1062  }
1063
1064  if (GCverbose) {
1065    char buf[16];
1066
1067    sample_paging_info(&paging_info_start);
1068    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1069    if (GCephemeral_low) {
1070      fprintf(stderr,
1071              "\n\n;;; Starting Ephemeral GC of generation %d",
1072              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1073    } else {
1074      fprintf(stderr,"\n\n;;; Starting full GC");
1075    }
1076    fprintf(stderr, ", %s bytes allocated.\n", buf);
1077  }
1078
1079  get_time(start);
1080  lisp_global(IN_GC) = (1<<fixnumshift);
1081
1082  if (just_purified_p) {
1083    just_purified_p = false;
1084    GCDebug = false;
1085  } else {
1086    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1087    if (GCDebug) {
1088      check_all_areas();
1089    }
1090  }
1091
1092  if (from) {
1093    untenure_from_area(from);
1094  }
1095  static_dnodes = static_dnodes_for_area(a);
1096  GCmarkbits = a->markbits;
1097  GCarealow = ptr_to_lispobj(a->low);
1098  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1099  GCndnodes_in_area = gc_area_dnode(oldfree);
1100
1101  if (GCndnodes_in_area) {
1102    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1103    GCdynamic_markbits = 
1104      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1105
1106    zero_bits(GCmarkbits, GCndnodes_in_area);
1107    GCweakvll = (LispObj)NULL;
1108
1109    if (GCn_ephemeral_dnodes == 0) {
1110      /* For GCTWA, mark the internal package hash table vector of
1111       *PACKAGE*, but don't mark its contents. */
1112      {
1113        LispObj
1114          itab;
1115        natural
1116          dnode, ndnodes;
1117     
1118        pkg = nrs_PACKAGE.vcell;
1119        if ((fulltag_of(pkg) == fulltag_misc) &&
1120            (header_subtag(header_of(pkg)) == subtag_package)) {
1121          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1122          itabvec = car(itab);
1123          dnode = gc_area_dnode(itabvec);
1124          if (dnode < GCndnodes_in_area) {
1125            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1126            set_n_bits(GCmarkbits, dnode, ndnodes);
1127          }
1128        }
1129      }
1130    }
1131
1132    mark_root(lisp_global(STATIC_CONSES));
1133
1134    {
1135      area *next_area;
1136      area_code code;
1137
1138      /* Could make a jump table instead of the typecase */
1139
1140      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1141        switch (code) {
1142        case AREA_TSTACK:
1143          mark_tstack_area(next_area);
1144          break;
1145
1146        case AREA_VSTACK:
1147          mark_vstack_area(next_area);
1148          break;
1149         
1150        case AREA_CSTACK:
1151          mark_cstack_area(next_area);
1152          break;
1153
1154        case AREA_STATIC:
1155        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1156          /* In both of these cases, we -could- use the area's "markbits"
1157             bitvector as a reference map.  It's safe (but slower) to
1158             ignore that map and process the entire area.
1159          */
1160          if (next_area->younger == NULL) {
1161            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1162          }
1163          break;
1164
1165        default:
1166          break;
1167        }
1168      }
1169    }
1170 
1171    if (lisp_global(OLDEST_EPHEMERAL)) {
1172      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1173    }
1174
1175    other_tcr = tcr;
1176    do {
1177      mark_tcr_xframes(other_tcr);
1178      mark_tcr_tlb(other_tcr);
1179      other_tcr = other_tcr->next;
1180    } while (other_tcr != tcr);
1181
1182
1183
1184
1185    /* Go back through *package*'s internal symbols, marking
1186       any that aren't worthless.
1187    */
1188   
1189    if (itabvec) {
1190      natural
1191        i,
1192        n = header_element_count(header_of(itabvec));
1193      LispObj
1194        sym,
1195        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1196
1197      for (i = 0; i < n; i++) {
1198        sym = *raw++;
1199        if (is_symbol_fulltag(sym)) {
1200          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1201          natural dnode = gc_area_dnode(sym);
1202         
1203          if ((dnode < GCndnodes_in_area) &&
1204              (!ref_bit(GCmarkbits,dnode))) {
1205            /* Symbol is in GC area, not marked.
1206               Mark it if fboundp, boundp, or if
1207               it has a plist or another home package.
1208            */
1209           
1210            if (FBOUNDP(rawsym) ||
1211                BOUNDP(rawsym) ||
1212                (rawsym->flags != 0) || /* SPECIAL, etc. */
1213                (rawsym->plist != lisp_nil) ||
1214                ((rawsym->package_predicate != pkg) &&
1215                 (rawsym->package_predicate != lisp_nil))) {
1216              mark_root(sym);
1217            }
1218          }
1219        }
1220      }
1221    }
1222
1223    (void)markhtabvs();
1224
1225    if (itabvec) {
1226      natural
1227        i,
1228        n = header_element_count(header_of(itabvec));
1229      LispObj
1230        sym,
1231        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1232
1233      for (i = 0; i < n; i++, raw++) {
1234        sym = *raw;
1235        if (is_symbol_fulltag(sym)) {
1236          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1237          natural dnode = gc_area_dnode(sym);
1238
1239          if ((dnode < GCndnodes_in_area) &&
1240              (!ref_bit(GCmarkbits,dnode))) {
1241            *raw = unbound_marker;
1242          }
1243        }
1244      }
1245    }
1246 
1247    reap_gcable_ptrs();
1248
1249    GCrelocptr = global_reloctab;
1250    GCfirstunmarked = calculate_relocation();
1251
1252    if (!GCephemeral_low) {
1253      reclaim_static_dnodes();
1254    }
1255
1256    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1257
1258    other_tcr = tcr;
1259    do {
1260      forward_tcr_xframes(other_tcr);
1261      forward_tcr_tlb(other_tcr);
1262      other_tcr = other_tcr->next;
1263    } while (other_tcr != tcr);
1264
1265 
1266    forward_gcable_ptrs();
1267
1268
1269
1270    {
1271      area *next_area;
1272      area_code code;
1273
1274      /* Could make a jump table instead of the typecase */
1275
1276      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1277        switch (code) {
1278        case AREA_TSTACK:
1279          forward_tstack_area(next_area);
1280          break;
1281
1282        case AREA_VSTACK:
1283          forward_vstack_area(next_area);
1284          break;
1285
1286        case AREA_CSTACK:
1287          forward_cstack_area(next_area);
1288          break;
1289
1290        case AREA_STATIC:
1291        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1292          if (next_area->younger == NULL) {
1293            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1294          }
1295          break;
1296
1297        default:
1298          break;
1299        }
1300      }
1301    }
1302 
1303    if (GCephemeral_low) {
1304      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1305    }
1306 
1307    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1308    if (to) {
1309      tenure_to_area(to);
1310    }
1311
1312    zero_memory_range(a->active, oldfree);
1313
1314    resize_dynamic_heap(a->active,
1315                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1316
1317    /*
1318      If the EGC is enabled: If there's no room for the youngest
1319      generation, untenure everything.  If this was a full GC and
1320      there's now room for the youngest generation, tenure everything.
1321    */
1322    if (a->older != NULL) {
1323      natural nfree = (a->high - a->active);
1324
1325
1326      if (nfree < a->threshold) {
1327        untenure_from_area(tenured_area);
1328      } else {
1329        if (GCephemeral_low == 0) {
1330          tenure_to_area(tenured_area);
1331        }
1332      }
1333    }
1334  }
1335  lisp_global(GC_NUM) += (1<<fixnumshift);
1336  if (note) {
1337    note->gccount += (1<<fixnumshift);
1338  }
1339
1340  if (GCDebug) {
1341    check_all_areas();
1342  }
1343
1344 
1345  lisp_global(IN_GC) = 0;
1346
1347  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1348  get_time(stop);
1349
1350  {
1351    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1352    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1353    LispObj val;
1354    struct timeval *timeinfo, elapsed;
1355
1356    val = total_gc_microseconds->vcell;
1357    if ((fulltag_of(val) == fulltag_misc) &&
1358        (header_subtag(header_of(val)) == subtag_macptr)) {
1359      timersub(&stop, &start, &elapsed);
1360      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1361      timeradd(timeinfo,  &elapsed, timeinfo);
1362      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1363    }
1364
1365    val = total_bytes_freed->vcell;
1366    if ((fulltag_of(val) == fulltag_misc) &&
1367        (header_subtag(header_of(val)) == subtag_macptr)) {
1368      long long justfreed = oldfree - a->active;
1369      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1370      if (GCverbose) {
1371        char buf[16];
1372        paging_info paging_info_stop;
1373
1374        sample_paging_info(&paging_info_stop);
1375        if (justfreed <= heap_segment_size) {
1376          justfreed = 0;
1377        }
1378        comma_output_decimal(buf,16,justfreed);
1379        if (note == tenured_area) {
1380          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1381        } else {
1382          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1383                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1384                  buf, 
1385                  elapsed.tv_sec, elapsed.tv_usec);
1386        }
1387        report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
1388      }
1389    }
1390  }
1391}
Note: See TracBrowser for help on using the repository browser.