source: branches/working-0711/ccl/lisp-kernel/gc-common.c @ 13070

Last change on this file since 13070 was 13070, checked in by gz, 11 years ago

r13066, r13067 from trunk: copyrights etc

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