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

Last change on this file since 12810 was 12810, checked in by rme, 10 years ago

unprotect_watched_areas() doesn't take any parameters now.

File size: 36.8 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#ifndef FORCE_DWS_MARK
1105  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1106    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1107  } else {
1108    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1109  }
1110#else
1111  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1112#endif
1113
1114  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1115  if (GCephemeral_low) {
1116    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1117  } else {
1118    GCn_ephemeral_dnodes = 0;
1119  }
1120 
1121  if (GCn_ephemeral_dnodes) {
1122    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1123  } else {
1124    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1125  }
1126
1127  if (GCephemeral_low) {
1128    if ((oldfree-g1_area->low) < g1_area->threshold) {
1129      to = g1_area;
1130      note = a;
1131      timeidx = 4;
1132    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1133      to = g2_area;
1134      from = g1_area;
1135      note = g1_area;
1136      timeidx = 3;
1137    } else {
1138      to = tenured_area;
1139      from = g2_area;
1140      note = g2_area;
1141      timeidx = 2;
1142    } 
1143  } else {
1144    note = tenured_area;
1145  }
1146
1147  if (GCverbose) {
1148    char buf[16];
1149
1150    sample_paging_info(&paging_info_start);
1151    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1152    if (GCephemeral_low) {
1153      fprintf(dbgout,
1154              "\n\n;;; Starting Ephemeral GC of generation %d",
1155              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1156    } else {
1157      fprintf(dbgout,"\n\n;;; Starting full GC");
1158    }
1159    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1160  }
1161
1162  get_time(start);
1163
1164  /* The link-inverting marker might need to write to watched areas */
1165  unprotect_watched_areas();
1166
1167  lisp_global(IN_GC) = (1<<fixnumshift);
1168
1169  if (just_purified_p) {
1170    just_purified_p = false;
1171    GCDebug = false;
1172  } else {
1173    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1174    if (GCDebug) {
1175      check_all_areas(tcr);
1176    }
1177  }
1178
1179  if (from) {
1180    untenure_from_area(from);
1181  }
1182  static_dnodes = static_dnodes_for_area(a);
1183  GCmarkbits = a->markbits;
1184  GCarealow = ptr_to_lispobj(a->low);
1185  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1186  GCndnodes_in_area = gc_area_dnode(oldfree);
1187
1188  if (GCndnodes_in_area) {
1189    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1190    GCdynamic_markbits = 
1191      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1192
1193    zero_bits(GCmarkbits, GCndnodes_in_area);
1194    GCweakvll = (LispObj)NULL;
1195
1196    if (GCn_ephemeral_dnodes == 0) {
1197      /* For GCTWA, mark the internal package hash table vector of
1198       *PACKAGE*, but don't mark its contents. */
1199      {
1200        LispObj
1201          itab;
1202        natural
1203          dnode, ndnodes;
1204     
1205        pkg = nrs_PACKAGE.vcell;
1206        if ((fulltag_of(pkg) == fulltag_misc) &&
1207            (header_subtag(header_of(pkg)) == subtag_package)) {
1208          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1209          itabvec = car(itab);
1210          dnode = gc_area_dnode(itabvec);
1211          if (dnode < GCndnodes_in_area) {
1212            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1213            set_n_bits(GCmarkbits, dnode, ndnodes);
1214          }
1215        }
1216      }
1217    }
1218
1219    mark_root(lisp_global(STATIC_CONSES));
1220
1221    {
1222      area *next_area;
1223      area_code code;
1224
1225      /* Could make a jump table instead of the typecase */
1226
1227      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1228        switch (code) {
1229        case AREA_TSTACK:
1230          mark_tstack_area(next_area);
1231          break;
1232
1233        case AREA_VSTACK:
1234          mark_vstack_area(next_area);
1235          break;
1236         
1237        case AREA_CSTACK:
1238          mark_cstack_area(next_area);
1239          break;
1240
1241        case AREA_STATIC:
1242        case AREA_WATCHED:
1243        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1244          /* In both of these cases, we -could- use the area's "markbits"
1245             bitvector as a reference map.  It's safe (but slower) to
1246             ignore that map and process the entire area.
1247          */
1248          if (next_area->younger == NULL) {
1249            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1250          }
1251          break;
1252
1253        default:
1254          break;
1255        }
1256      }
1257    }
1258 
1259    if (lisp_global(OLDEST_EPHEMERAL)) {
1260      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1261    }
1262
1263    other_tcr = tcr;
1264    do {
1265      mark_tcr_xframes(other_tcr);
1266      mark_tcr_tlb(other_tcr);
1267      other_tcr = other_tcr->next;
1268    } while (other_tcr != tcr);
1269
1270
1271
1272
1273    /* Go back through *package*'s internal symbols, marking
1274       any that aren't worthless.
1275    */
1276   
1277    if (itabvec) {
1278      natural
1279        i,
1280        n = header_element_count(header_of(itabvec));
1281      LispObj
1282        sym,
1283        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1284
1285      for (i = 0; i < n; i++) {
1286        sym = *raw++;
1287        if (is_symbol_fulltag(sym)) {
1288          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1289          natural dnode = gc_area_dnode(sym);
1290         
1291          if ((dnode < GCndnodes_in_area) &&
1292              (!ref_bit(GCmarkbits,dnode))) {
1293            /* Symbol is in GC area, not marked.
1294               Mark it if fboundp, boundp, or if
1295               it has a plist or another home package.
1296            */
1297           
1298            if (FBOUNDP(rawsym) ||
1299                BOUNDP(rawsym) ||
1300                (rawsym->flags != 0) || /* SPECIAL, etc. */
1301                (rawsym->plist != lisp_nil) ||
1302                ((rawsym->package_predicate != pkg) &&
1303                 (rawsym->package_predicate != lisp_nil))) {
1304              mark_root(sym);
1305            }
1306          }
1307        }
1308      }
1309    }
1310
1311    (void)markhtabvs();
1312
1313    if (itabvec) {
1314      natural
1315        i,
1316        n = header_element_count(header_of(itabvec));
1317      LispObj
1318        sym,
1319        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1320
1321      for (i = 0; i < n; i++, raw++) {
1322        sym = *raw;
1323        if (is_symbol_fulltag(sym)) {
1324          natural dnode = gc_area_dnode(sym);
1325
1326          if ((dnode < GCndnodes_in_area) &&
1327              (!ref_bit(GCmarkbits,dnode))) {
1328            *raw = unbound_marker;
1329          }
1330        }
1331      }
1332    }
1333 
1334    reap_gcable_ptrs();
1335
1336    GCrelocptr = global_reloctab;
1337    GCfirstunmarked = calculate_relocation();
1338
1339    if (!GCephemeral_low) {
1340      reclaim_static_dnodes();
1341    }
1342
1343    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1344
1345    other_tcr = tcr;
1346    do {
1347      forward_tcr_xframes(other_tcr);
1348      forward_tcr_tlb(other_tcr);
1349      other_tcr = other_tcr->next;
1350    } while (other_tcr != tcr);
1351
1352 
1353    forward_gcable_ptrs();
1354
1355
1356
1357    {
1358      area *next_area;
1359      area_code code;
1360
1361      /* Could make a jump table instead of the typecase */
1362
1363      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1364        switch (code) {
1365        case AREA_TSTACK:
1366          forward_tstack_area(next_area);
1367          break;
1368
1369        case AREA_VSTACK:
1370          forward_vstack_area(next_area);
1371          break;
1372
1373        case AREA_CSTACK:
1374          forward_cstack_area(next_area);
1375          break;
1376
1377        case AREA_STATIC:
1378        case AREA_WATCHED:
1379        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1380          if (next_area->younger == NULL) {
1381            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1382          }
1383          break;
1384
1385        default:
1386          break;
1387        }
1388      }
1389    }
1390
1391    if (GCephemeral_low) {
1392      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1393    }
1394 
1395    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1396    if (to) {
1397      tenure_to_area(to);
1398    }
1399
1400    zero_memory_range(a->active, oldfree);
1401
1402    resize_dynamic_heap(a->active,
1403                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1404
1405    /*
1406      If the EGC is enabled: If there's no room for the youngest
1407      generation, untenure everything.  If this was a full GC and
1408      there's now room for the youngest generation, tenure everything.
1409    */
1410    if (a->older != NULL) {
1411      natural nfree = (a->high - a->active);
1412
1413
1414      if (nfree < a->threshold) {
1415        untenure_from_area(tenured_area);
1416      } else {
1417        if (GCephemeral_low == 0) {
1418          tenure_to_area(tenured_area);
1419        }
1420      }
1421    }
1422  }
1423  lisp_global(GC_NUM) += (1<<fixnumshift);
1424  if (note) {
1425    note->gccount += (1<<fixnumshift);
1426  }
1427
1428  if (GCDebug) {
1429    check_all_areas(tcr);
1430  }
1431
1432 
1433  lisp_global(IN_GC) = 0;
1434 
1435  protect_watched_areas();
1436
1437  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1438  get_time(stop);
1439
1440  {
1441    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1442    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1443    LispObj val;
1444    struct timeval *timeinfo, elapsed = {0, 0};
1445
1446    val = total_gc_microseconds->vcell;
1447    if ((fulltag_of(val) == fulltag_misc) &&
1448        (header_subtag(header_of(val)) == subtag_macptr)) {
1449      timersub(&stop, &start, &elapsed);
1450      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1451      timeradd(timeinfo,  &elapsed, timeinfo);
1452      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1453    }
1454
1455    val = total_bytes_freed->vcell;
1456    if ((fulltag_of(val) == fulltag_misc) &&
1457        (header_subtag(header_of(val)) == subtag_macptr)) {
1458      long long justfreed = oldfree - a->active;
1459      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1460      if (GCverbose) {
1461        char buf[16];
1462        paging_info paging_info_stop;
1463
1464        sample_paging_info(&paging_info_stop);
1465        if (justfreed <= heap_segment_size) {
1466          justfreed = 0;
1467        }
1468        comma_output_decimal(buf,16,justfreed);
1469        if (note == tenured_area) {
1470          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1471        } else {
1472          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1473                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1474                  buf, 
1475                  elapsed.tv_sec, elapsed.tv_usec);
1476        }
1477        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
1478      }
1479    }
1480  }
1481}
Note: See TracBrowser for help on using the repository browser.