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

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

mark_tcr_xframes(): Pollute file with x8632 conditionalization.

File size: 34.5 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp_globals.h"
19#include "bits.h"
20#include "gc.h"
21#include "area.h"
22#include "Threads.h"
23#include <stddef.h>
24#include <stdlib.h>
25#include <string.h>
26
27#ifndef WINDOWS
28#include <sys/time.h>
29#endif
30
31#ifndef timeradd
32# define timeradd(a, b, result)                                               \
33  do {                                                                        \
34    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
35    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
36    if ((result)->tv_usec >= 1000000)                                         \
37      {                                                                       \
38        ++(result)->tv_sec;                                                   \
39        (result)->tv_usec -= 1000000;                                         \
40      }                                                                       \
41  } while (0)
42#endif
43#ifndef timersub
44# define timersub(a, b, result)                                               \
45  do {                                                                        \
46    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
47    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
48    if ((result)->tv_usec < 0) {                                              \
49      --(result)->tv_sec;                                                     \
50      (result)->tv_usec += 1000000;                                           \
51    }                                                                         \
52  } while (0)
53#endif
54
55void
56comma_output_decimal(char *buf, int len, natural n) 
57{
58  int nout = 0;
59
60  buf[--len] = 0;
61  do {
62    buf[--len] = n%10+'0';
63    n = n/10;
64    if (n == 0) {
65      while (len) {
66        buf[--len] = ' ';
67      }
68      return;
69    }
70    if (len == 0) return;
71    nout ++;
72    if (nout == 3) {
73      buf[--len] = ',';
74      nout = 0;
75    }
76  } while (len >= 0);
77}
78
79
80natural
81static_dnodes_for_area(area *a)
82{
83  if (a->low == tenured_area->low) {
84    return tenured_area->static_dnodes;
85  }
86  return 0;
87}
88
89Boolean GCDebug = false, GCverbose = false;
90bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
91LispObj GCarealow = 0, GCareadynamiclow = 0;
92natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0;
93LispObj GCweakvll = (LispObj)NULL;
94LispObj GCdwsweakvll = (LispObj)NULL;
95LispObj GCephemeral_low = 0;
96natural GCn_ephemeral_dnodes = 0;
97natural GCstack_limit = 0;
98
99
100void
101reapweakv(LispObj weakv)
102{
103  /*
104    element 2 of the weak vector should be tagged as a cons: if it
105    isn't, just mark it as a root.  if it is, cdr through it until a
106    "marked" cons is encountered.  If the car of any unmarked cons is
107    marked, mark the cons which contains it; otherwise, splice the
108    cons out of the list.  N.B. : elements 0 and 1 are already marked
109    (or are immediate, etc.)
110  */
111  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
112  LispObj termination_list = lisp_nil;
113  natural weak_type = (natural) deref(weakv,2);
114  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
115    terminatablep = ((weak_type >> population_termination_bit) != 0);
116  Boolean done = false;
117  cons *rawcons;
118  natural dnode, car_dnode;
119  bitvector markbits = GCmarkbits;
120
121  if (terminatablep) {
122    termination_list = deref(weakv,1+3);
123  }
124
125  if (fulltag_of(cell) != fulltag_cons) {
126    mark_root(cell);
127  } else if (alistp) {
128    /* weak alist */
129    while (! done) {
130      dnode = gc_area_dnode(cell);
131      if ((dnode >= GCndnodes_in_area) ||
132          (ref_bit(markbits, dnode))) {
133        done = true;
134      } else {
135        /* Cons cell is unmarked. */
136        LispObj alist_cell, thecar;
137        unsigned cell_tag;
138
139        rawcons = (cons *) ptr_from_lispobj(untag(cell));
140        alist_cell = rawcons->car;
141        cell_tag = fulltag_of(alist_cell);
142
143        if ((cell_tag == fulltag_cons) &&
144            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
145            (! ref_bit(markbits, car_dnode)) &&
146            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
147            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
148            (! ref_bit(markbits, car_dnode))) {
149          *prev = rawcons->cdr;
150          if (terminatablep) {
151            rawcons->cdr = termination_list;
152            termination_list = cell;
153          }
154        } else {
155          set_bit(markbits, dnode);
156          prev = (LispObj *)(&(rawcons->cdr));
157          mark_root(alist_cell);
158        }
159        cell = *prev;
160      }
161    }
162  } else {
163    /* weak list */
164    while (! done) {
165      dnode = gc_area_dnode(cell);
166      if ((dnode >= GCndnodes_in_area) ||
167          (ref_bit(markbits, dnode))) {
168        done = true;
169      } else {
170        /* Cons cell is unmarked. */
171        LispObj thecar;
172        unsigned cartag;
173
174        rawcons = (cons *) ptr_from_lispobj(untag(cell));
175        thecar = rawcons->car;
176        cartag = fulltag_of(thecar);
177
178        if (is_node_fulltag(cartag) &&
179            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
180            (! ref_bit(markbits, car_dnode))) {
181          *prev = rawcons->cdr;
182          if (terminatablep) {
183            rawcons->cdr = termination_list;
184            termination_list = cell;
185          }
186        } else {
187          set_bit(markbits, dnode);
188          prev = (LispObj *)(&(rawcons->cdr));
189        }
190        cell = *prev;
191      }
192    }
193  }
194
195  if (terminatablep) {
196    deref(weakv,1+3) = termination_list;
197    if (termination_list != lisp_nil) {
198      deref(weakv,1) = GCweakvll;
199      GCweakvll = weakv;
200    }
201  }
202}
203
204/*
205  Screw: doesn't deal with finalization.
206  */
207
208void
209reaphashv(LispObj hashv)
210{
211  hash_table_vector_header
212    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
213  natural
214    dnode,
215    npairs = (header_element_count(hashp->header) - 
216              (hash_table_vector_header_count -1)) >> 1;
217  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
218  Boolean
219    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
220  bitvector markbits = GCmarkbits;
221  int tag;
222
223  while (npairs--) {
224    if (weak_on_value) {
225      weakelement = pairp[1];
226    } else {
227      weakelement = pairp[0];
228    }
229    tag = fulltag_of(weakelement);
230    if (is_node_fulltag(tag)) {
231      dnode = gc_area_dnode(weakelement);
232      if ((dnode < GCndnodes_in_area) && 
233          ! ref_bit(markbits, dnode)) {
234        pairp[0] = slot_unbound;
235        pairp[1] = lisp_nil;
236        hashp->weak_deletions_count += (1<<fixnumshift);
237      }
238    }
239    pairp += 2;
240  }
241}
242
243void
244traditional_dws_mark_htabv(LispObj htabv)
245{
246  /* Do nothing, just add htabv to GCweakvll */
247  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
248 
249  deref(base,1) = GCweakvll;
250  GCweakvll = htabv;
251}
252
253void
254ncircle_dws_mark_htabv(LispObj htabv)
255{
256  /* Do nothing, just add htabv to GCdwsweakvll */
257  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
258 
259  deref(base,1) = GCdwsweakvll;
260  GCdwsweakvll = htabv;
261}
262
263void
264traditional_mark_weak_htabv(LispObj htabv)
265{
266  int i, skip = hash_table_vector_header_count;;
267
268  for (i = 2; i <= skip; i++) {
269    rmark(deref(htabv,i));
270  }
271
272  deref(htabv,1) = GCweakvll;
273  GCweakvll = htabv;
274}
275
276void
277ncircle_mark_weak_htabv(LispObj htabv)
278{
279  int i, skip = hash_table_vector_header_count;
280  hash_table_vector_header *hashp = (hash_table_vector_header *)(untag(htabv));
281  natural
282    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          hashp->flags |= nhash_key_moved_mask;
904          hash_dnode_limit = 0;
905          hashp = NULL;
906        }
907      }
908      p++;
909      memo_dnode++;
910      bitidx++;
911
912    }
913  }
914}
915
916void
917forward_tcr_tlb(TCR *tcr)
918{
919  natural n = tcr->tlb_limit;
920  LispObj
921    *start = tcr->tlb_pointer, 
922    *end = (LispObj *) ((BytePtr)start+n),
923    node;
924
925  while (start < end) {
926    node = *start;
927    if (node != no_thread_local_binding_marker) {
928      update_noderef(start);
929    }
930    start++;
931  }
932}
933
934void
935reclaim_static_dnodes()
936{
937  natural nstatic = tenured_area->static_dnodes, i, bits, bitnum;
938  cons *c = (cons *)tenured_area->low, *d;
939  bitvector bitsp = GCmarkbits;
940  LispObj head = lisp_global(STATIC_CONSES);
941
942  if (nstatic) {
943    if (head) {
944      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
945        bits = *bitsp++;
946        if (bits != ALL_ONES) {
947          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
948            if (! (bits & (BIT0_MASK>>bitnum))) {
949              d = c + bitnum;
950              d->car = 0;
951              d->cdr = head;
952              head = ((LispObj)d)+fulltag_cons;
953            }
954          }
955        }
956      }
957      lisp_global(STATIC_CONSES) = head;
958    } else {
959      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
960        bits = *bitsp++;
961        if (bits != ALL_ONES) {
962          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
963            if (! (bits & (BIT0_MASK>>bitnum))) {
964              d = c + bitnum;
965              d->car = 0;
966              d->cdr = 0;
967            }
968          }
969        }
970      }
971    }
972  }
973}
974
975Boolean
976youngest_non_null_area_p (area *a)
977{
978  if (a->active == a->high) {
979    return false;
980  } else {
981    for (a = a->younger; a; a = a->younger) {
982      if (a->active != a->high) {
983        return false;
984      }
985    }
986  };
987  return true;
988}
989
990Boolean just_purified_p = false;
991
992/*
993  All thread's stack areas have been "normalized", as
994  has the dynamic heap.  (The "active" pointer in these areas
995  matches the stack pointer/freeptr value at the time that
996  the exception occurred.)
997*/
998
999#ifdef WINDOWS
1000#define get_time(when) /* FIXME */
1001#else
1002#define get_time(when) gettimeofday(&when, NULL)
1003#endif
1004
1005
1006#ifdef FORCE_DWS_MARK
1007#warning recursive marker disabled for testing; remember to re-enable it
1008#endif
1009
1010
1011void 
1012gc(TCR *tcr, signed_natural param)
1013{
1014  struct timeval start, stop;
1015  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1016  unsigned timeidx = 1;
1017  paging_info paging_info_start;
1018  LispObj
1019    pkg = 0,
1020    itabvec = 0;
1021  BytePtr oldfree = a->active;
1022  TCR *other_tcr;
1023  natural static_dnodes;
1024
1025  install_weak_mark_functions(lisp_global(WEAK_GC_METHOD) >> fixnumshift);
1026
1027
1028
1029#ifndef FORCE_DWS_MARK
1030  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1031    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1032  } else {
1033    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1034  }
1035#else
1036  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1037#endif
1038
1039  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1040  if (GCephemeral_low) {
1041    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1042  } else {
1043    GCn_ephemeral_dnodes = 0;
1044  }
1045 
1046  if (GCn_ephemeral_dnodes) {
1047    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1048  } else {
1049    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1050  }
1051
1052  if (GCephemeral_low) {
1053    if ((oldfree-g1_area->low) < g1_area->threshold) {
1054      to = g1_area;
1055      note = a;
1056      timeidx = 4;
1057    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1058      to = g2_area;
1059      from = g1_area;
1060      note = g1_area;
1061      timeidx = 3;
1062    } else {
1063      to = tenured_area;
1064      from = g2_area;
1065      note = g2_area;
1066      timeidx = 2;
1067    } 
1068  } else {
1069    note = tenured_area;
1070  }
1071
1072  if (GCverbose) {
1073    char buf[16];
1074
1075    sample_paging_info(&paging_info_start);
1076    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1077    if (GCephemeral_low) {
1078      fprintf(stderr,
1079              "\n\n;;; Starting Ephemeral GC of generation %d",
1080              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1081    } else {
1082      fprintf(stderr,"\n\n;;; Starting full GC");
1083    }
1084    fprintf(stderr, ", %s bytes allocated.\n", buf);
1085  }
1086
1087  get_time(start);
1088  lisp_global(IN_GC) = (1<<fixnumshift);
1089
1090  if (just_purified_p) {
1091    just_purified_p = false;
1092    GCDebug = false;
1093  } else {
1094    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1095    if (GCDebug) {
1096      check_all_areas();
1097    }
1098  }
1099
1100  if (from) {
1101    untenure_from_area(from);
1102  }
1103  static_dnodes = static_dnodes_for_area(a);
1104  GCmarkbits = a->markbits;
1105  GCarealow = ptr_to_lispobj(a->low);
1106  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1107  GCndnodes_in_area = gc_area_dnode(oldfree);
1108
1109  if (GCndnodes_in_area) {
1110    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1111    GCdynamic_markbits = 
1112      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1113
1114    zero_bits(GCmarkbits, GCndnodes_in_area);
1115    GCweakvll = (LispObj)NULL;
1116
1117    if (GCn_ephemeral_dnodes == 0) {
1118      /* For GCTWA, mark the internal package hash table vector of
1119       *PACKAGE*, but don't mark its contents. */
1120      {
1121        LispObj
1122          itab;
1123        natural
1124          dnode, ndnodes;
1125     
1126        pkg = nrs_PACKAGE.vcell;
1127        if ((fulltag_of(pkg) == fulltag_misc) &&
1128            (header_subtag(header_of(pkg)) == subtag_package)) {
1129          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1130          itabvec = car(itab);
1131          dnode = gc_area_dnode(itabvec);
1132          if (dnode < GCndnodes_in_area) {
1133            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1134            set_n_bits(GCmarkbits, dnode, ndnodes);
1135          }
1136        }
1137      }
1138    }
1139
1140    mark_root(lisp_global(STATIC_CONSES));
1141
1142    {
1143      area *next_area;
1144      area_code code;
1145
1146      /* Could make a jump table instead of the typecase */
1147
1148      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1149        switch (code) {
1150        case AREA_TSTACK:
1151          mark_tstack_area(next_area);
1152          break;
1153
1154        case AREA_VSTACK:
1155          mark_vstack_area(next_area);
1156          break;
1157         
1158        case AREA_CSTACK:
1159          mark_cstack_area(next_area);
1160          break;
1161
1162        case AREA_STATIC:
1163        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1164          /* In both of these cases, we -could- use the area's "markbits"
1165             bitvector as a reference map.  It's safe (but slower) to
1166             ignore that map and process the entire area.
1167          */
1168          if (next_area->younger == NULL) {
1169            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1170          }
1171          break;
1172
1173        default:
1174          break;
1175        }
1176      }
1177    }
1178 
1179    if (lisp_global(OLDEST_EPHEMERAL)) {
1180      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1181    }
1182
1183    other_tcr = tcr;
1184    do {
1185      mark_tcr_xframes(other_tcr);
1186      mark_tcr_tlb(other_tcr);
1187      other_tcr = other_tcr->next;
1188    } while (other_tcr != tcr);
1189
1190
1191
1192
1193    /* Go back through *package*'s internal symbols, marking
1194       any that aren't worthless.
1195    */
1196   
1197    if (itabvec) {
1198      natural
1199        i,
1200        n = header_element_count(header_of(itabvec));
1201      LispObj
1202        sym,
1203        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1204
1205      for (i = 0; i < n; i++) {
1206        sym = *raw++;
1207        if (is_symbol_fulltag(sym)) {
1208          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1209          natural dnode = gc_area_dnode(sym);
1210         
1211          if ((dnode < GCndnodes_in_area) &&
1212              (!ref_bit(GCmarkbits,dnode))) {
1213            /* Symbol is in GC area, not marked.
1214               Mark it if fboundp, boundp, or if
1215               it has a plist or another home package.
1216            */
1217           
1218            if (FBOUNDP(rawsym) ||
1219                BOUNDP(rawsym) ||
1220                (rawsym->flags != 0) || /* SPECIAL, etc. */
1221                (rawsym->plist != lisp_nil) ||
1222                ((rawsym->package_predicate != pkg) &&
1223                 (rawsym->package_predicate != lisp_nil))) {
1224              mark_root(sym);
1225            }
1226          }
1227        }
1228      }
1229    }
1230
1231    (void)markhtabvs();
1232
1233    if (itabvec) {
1234      natural
1235        i,
1236        n = header_element_count(header_of(itabvec));
1237      LispObj
1238        sym,
1239        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1240
1241      for (i = 0; i < n; i++, raw++) {
1242        sym = *raw;
1243        if (is_symbol_fulltag(sym)) {
1244          natural dnode = gc_area_dnode(sym);
1245
1246          if ((dnode < GCndnodes_in_area) &&
1247              (!ref_bit(GCmarkbits,dnode))) {
1248            *raw = unbound_marker;
1249          }
1250        }
1251      }
1252    }
1253 
1254    reap_gcable_ptrs();
1255
1256    GCrelocptr = global_reloctab;
1257    GCfirstunmarked = calculate_relocation();
1258
1259    if (!GCephemeral_low) {
1260      reclaim_static_dnodes();
1261    }
1262
1263    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1264
1265    other_tcr = tcr;
1266    do {
1267      forward_tcr_xframes(other_tcr);
1268      forward_tcr_tlb(other_tcr);
1269      other_tcr = other_tcr->next;
1270    } while (other_tcr != tcr);
1271
1272 
1273    forward_gcable_ptrs();
1274
1275
1276
1277    {
1278      area *next_area;
1279      area_code code;
1280
1281      /* Could make a jump table instead of the typecase */
1282
1283      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1284        switch (code) {
1285        case AREA_TSTACK:
1286          forward_tstack_area(next_area);
1287          break;
1288
1289        case AREA_VSTACK:
1290          forward_vstack_area(next_area);
1291          break;
1292
1293        case AREA_CSTACK:
1294          forward_cstack_area(next_area);
1295          break;
1296
1297        case AREA_STATIC:
1298        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1299          if (next_area->younger == NULL) {
1300            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1301          }
1302          break;
1303
1304        default:
1305          break;
1306        }
1307      }
1308    }
1309 
1310    if (GCephemeral_low) {
1311      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1312    }
1313 
1314    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1315    if (to) {
1316      tenure_to_area(to);
1317    }
1318
1319    zero_memory_range(a->active, oldfree);
1320
1321    resize_dynamic_heap(a->active,
1322                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1323
1324    /*
1325      If the EGC is enabled: If there's no room for the youngest
1326      generation, untenure everything.  If this was a full GC and
1327      there's now room for the youngest generation, tenure everything.
1328    */
1329    if (a->older != NULL) {
1330      natural nfree = (a->high - a->active);
1331
1332
1333      if (nfree < a->threshold) {
1334        untenure_from_area(tenured_area);
1335      } else {
1336        if (GCephemeral_low == 0) {
1337          tenure_to_area(tenured_area);
1338        }
1339      }
1340    }
1341  }
1342  lisp_global(GC_NUM) += (1<<fixnumshift);
1343  if (note) {
1344    note->gccount += (1<<fixnumshift);
1345  }
1346
1347  if (GCDebug) {
1348    check_all_areas();
1349  }
1350
1351 
1352  lisp_global(IN_GC) = 0;
1353
1354  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1355  get_time(stop);
1356
1357  {
1358    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1359    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1360    LispObj val;
1361    struct timeval *timeinfo, elapsed = {0, 0};
1362
1363    val = total_gc_microseconds->vcell;
1364    if ((fulltag_of(val) == fulltag_misc) &&
1365        (header_subtag(header_of(val)) == subtag_macptr)) {
1366      timersub(&stop, &start, &elapsed);
1367      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1368      timeradd(timeinfo,  &elapsed, timeinfo);
1369      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1370    }
1371
1372    val = total_bytes_freed->vcell;
1373    if ((fulltag_of(val) == fulltag_misc) &&
1374        (header_subtag(header_of(val)) == subtag_macptr)) {
1375      long long justfreed = oldfree - a->active;
1376      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1377      if (GCverbose) {
1378        char buf[16];
1379        paging_info paging_info_stop;
1380
1381        sample_paging_info(&paging_info_stop);
1382        if (justfreed <= heap_segment_size) {
1383          justfreed = 0;
1384        }
1385        comma_output_decimal(buf,16,justfreed);
1386        if (note == tenured_area) {
1387          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1388        } else {
1389          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1390                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1391                  buf, 
1392                  elapsed.tv_sec, elapsed.tv_usec);
1393        }
1394        report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
1395      }
1396    }
1397  }
1398}
Note: See TracBrowser for help on using the repository browser.