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

Last change on this file since 10173 was 10173, checked in by gb, 11 years ago

Add a comment in forward_memoized_area, which claims that 'hashp' can
never be NULL when hashp->flags is written to.

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