source: release/1.3/source/lisp-kernel/gc-common.c @ 11698

Last change on this file since 11698 was 11698, checked in by rme, 11 years ago

Really merge r11694 from trunk.

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