Back to index

plt-scheme  4.2.1
fnls.c
Go to the documentation of this file.
00001 
00002 /* 
00003    Provides:
00004       struct finalizer { ... } Fnl
00005       GC_set_finalizer
00006       reset_finalizer_tree
00007       finalizers
00008       num_fnls
00009    Requires:
00010       is_finalizable_page(gc, p)
00011       park
00012 */
00013 
00014 #define Tree Fnl
00015 #define Splay_Item(t) ((unsigned long)t->p)
00016 #define Set_Splay_Item(t, v) (t)->p = (void *)v
00017 #define splay fnl_splay
00018 #define splay_insert fnl_splay_insert
00019 #define splay_delete fnl_splay_delete
00020 #include "../utils/splay.c"
00021 #undef splay
00022 #undef splay_insert
00023 #undef splay_delete
00024 
00025 void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *data), 
00026     void *data, void (**oldf)(void *p, void *data), 
00027     void **olddata)
00028 {
00029   GCTYPE *gc = GC_get_GC();
00030   Fnl *fnl;
00031 
00032   if (!is_finalizable_page(gc, p)) {
00033     /* Never collected. Don't finalize it. */
00034     if (oldf) *oldf = NULL;
00035     if (olddata) *olddata = NULL;
00036     return;
00037   }
00038 
00039   gc->splayed_finalizers = fnl_splay((unsigned long)p, gc->splayed_finalizers);
00040   fnl = gc->splayed_finalizers;
00041   if (fnl && (fnl->p == p)) {
00042     if (oldf) *oldf = fnl->f;
00043     if (olddata) *olddata = fnl->data;
00044     if (f) {
00045       fnl->f = f;
00046       fnl->data = data;
00047       fnl->eager_level = level;
00048     } else {
00049       /* remove finalizer */
00050       if (fnl->prev)
00051         fnl->prev->next = fnl->next;
00052       else
00053         gc->finalizers = fnl->next;
00054       if (fnl->next)
00055         fnl->next->prev = fnl->prev;
00056 
00057       --gc->num_fnls;
00058       gc->splayed_finalizers = fnl_splay_delete((unsigned long)p, gc->splayed_finalizers);
00059     }
00060     return;
00061   }
00062 
00063   if (oldf) *oldf = NULL;
00064   if (olddata) *olddata = NULL;
00065 
00066   if (!f)
00067     return;
00068 
00069   /* Allcation might trigger GC, so we use park: */
00070   gc->park[0] = p;
00071   gc->park[1] = data;
00072 
00073   fnl = (Fnl *)GC_malloc_atomic(sizeof(Fnl));
00074   memset(fnl, 0, sizeof(Fnl));
00075 
00076   p = gc->park[0];
00077   data = gc->park[1];
00078   gc->park[0] = NULL;
00079   gc->park[1] = NULL;
00080 
00081 
00082   fnl->p = p;
00083   fnl->f = f;
00084   fnl->data = data;
00085   fnl->eager_level = level;
00086   fnl->tagged = tagged;
00087 
00088 #if CHECKS
00089   {
00090     MPage *m;
00091 
00092     m = find_page(p);
00093 
00094     if (tagged) {
00095       if (m->type != MTYPE_TAGGED) {
00096         GCPRINT(GCOUTF, "Not tagged: %lx (%d)\n", 
00097             (long)p, m->type);
00098         CRASH(4);
00099       }
00100     } else {
00101       if (m->type != MTYPE_XTAGGED) {
00102         GCPRINT(GCOUTF, "Not xtagged: %lx (%d)\n", 
00103             (long)p, m->type);
00104         CRASH(5);
00105       }
00106       if (m->flags & MFLAG_BIGBLOCK)
00107         fnl->size = m->u.size;
00108       else
00109         fnl->size = ((long *)p)[-1];
00110     }
00111   }
00112 #endif
00113 
00114   /* push finalizer */
00115   fnl->next = gc->finalizers;
00116   fnl->prev = NULL;
00117   if (gc->finalizers) {
00118     gc->finalizers->prev = fnl;
00119   }
00120   gc->finalizers = fnl;
00121 
00122   gc->splayed_finalizers = fnl_splay_insert((unsigned long)p, fnl, gc->splayed_finalizers);
00123 
00124   gc->num_fnls++;
00125 }
00126 
00127 static void reset_finalizer_tree(GCTYPE *gc)
00128   /* After a GC, rebuild the splay tree, since object addresses
00129      have moved. */
00130 {
00131   Fnl *fnl;
00132   Fnl *prev = NULL;
00133 
00134   gc->splayed_finalizers = NULL;
00135 
00136   for (fnl = gc->finalizers; fnl; fnl = fnl->next) {
00137     fnl->prev = prev;
00138     gc->splayed_finalizers = fnl_splay_insert((unsigned long)fnl->p, fnl, gc->splayed_finalizers);
00139     prev = fnl;
00140   }
00141 }
00142