1: /*
    2:  * weak.c - weak vectors and tables
    3:  *
    4:  *   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5:  * 
    6:  *   Redistribution and use in source and binary forms, with or without
    7:  *   modification, are permitted provided that the following conditions
    8:  *   are met:
    9:  * 
   10:  *   1. Redistributions of source code must retain the above copyright
   11:  *      notice, this list of conditions and the following disclaimer.
   12:  *
   13:  *   2. Redistributions in binary form must reproduce the above copyright
   14:  *      notice, this list of conditions and the following disclaimer in the
   15:  *      documentation and/or other materials provided with the distribution.
   16:  *
   17:  *   3. Neither the name of the authors nor the names of its contributors
   18:  *      may be used to endorse or promote products derived from this
   19:  *      software without specific prior written permission.
   20:  *
   21:  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22:  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23:  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24:  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25:  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26:  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27:  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28:  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29:  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30:  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31:  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32:  *
   33:  *  $Id: weak.c,v 1.16 2007/08/10 01:19:36 shirok Exp $
   34:  */
   35: 
   36: #define LIBGAUCHE_BODY
   37: #include "gauche.h"
   38: 
   39: /*=============================================================
   40:  * Weak vector
   41:  *
   42:  *  A weak vector is like a vector of Scheme objects, except
   43:  *  it doesn't prevent the referenced objects to be garbage-collected.
   44:  *  Internally, it is implemented using "disappearing link" feature
   45:  *  of Boehm GC; when the referenced object is collected, the pointer
   46:  *  in the vector is set to NULL.
   47:  *  It is important to keep track of whether the entry of the vector
   48:  *  is registered as a disappearing link or not, for you can't register
   49:  *  the same location more than once.
   50:  */
   51: 
   52: static void weakvector_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
   53: {
   54:     int i;
   55:     ScmWeakVector *v = SCM_WEAK_VECTOR(obj);
   56:     ScmObj *ptrs = (ScmObj*)v->pointers;
   57:     Scm_Printf(port, "#,(<weak-vector> %d", v->size);
   58:     for (i=0; i<v->size; i++) {
   59:         SCM_PUTC(' ', port);
   60:         if (ptrs[i]) Scm_Write(ptrs[i], SCM_OBJ(port), ctx->mode);
   61:         else         Scm_Write(SCM_FALSE, SCM_OBJ(port), ctx->mode);
   62:     }
   63:     SCM_PUTC(')', port);
   64: }
   65: 
   66: static void weakvector_finalize(ScmObj obj, void *data)
   67: {
   68:     int i;
   69:     ScmWeakVector *v = SCM_WEAK_VECTOR(obj);
   70:     ScmObj *p = (ScmObj*)v->pointers;
   71:     for (i=0; i<v->size; i++) {
   72:         if (p[i]==NULL || SCM_PTRP(p[i])) {
   73:             GC_unregister_disappearing_link((GC_PTR*)&p[i]);
   74:         }
   75:         p[i] = SCM_FALSE;       /* safety */
   76:     }
   77: }
   78: 
   79: SCM_DEFINE_BUILTIN_CLASS(Scm_WeakVectorClass, weakvector_print,
   80:                          NULL, NULL, NULL,
   81:                          SCM_CLASS_SEQUENCE_CPL);
   82: 
   83: ScmObj Scm_MakeWeakVector(int size)
   84: {
   85:     int i;
   86:     ScmObj *p;
   87:     ScmWeakVector *v = SCM_NEW(ScmWeakVector);
   88:     
   89:     SCM_SET_CLASS(v, SCM_CLASS_WEAK_VECTOR);
   90:     v->size = size;
   91:     /* Allocate pointer array by ATOMIC, so that GC won't trace the
   92:        pointers in it.  */
   93:     p = SCM_NEW_ATOMIC2(ScmObj*, size * sizeof(ScmObj));
   94:     for (i=0; i<size; i++) p[i] = SCM_FALSE;
   95:     v->pointers = (void*)p;
   96:     Scm_RegisterFinalizer(SCM_OBJ(v), weakvector_finalize, NULL);
   97:     return SCM_OBJ(v);
   98: }
   99: 
  100: ScmObj Scm_WeakVectorRef(ScmWeakVector *v, int index, ScmObj fallback)
  101: {
  102:     ScmObj *p;
  103:     if (index < 0 || index >= v->size) {
  104:         if (SCM_UNBOUNDP(fallback)) {
  105:             Scm_Error("argument out of range: %d", index);
  106:         } else {
  107:             return fallback;
  108:         }
  109:     }
  110:     p = (ScmObj*)v->pointers;
  111:     if (p[index] == NULL) {
  112:         if (SCM_UNBOUNDP(fallback)) return SCM_FALSE;
  113:         else return fallback;
  114:     } else {
  115:         return p[index];
  116:     }
  117: }
  118: 
  119: ScmObj Scm_WeakVectorSet(ScmWeakVector *v, int index, ScmObj value)
  120: {
  121:     ScmObj *p;
  122:     if (index < 0 || index >= v->size) {
  123:         Scm_Error("argument out of range: %d", index);
  124:     }
  125:     p = (ScmObj*)v->pointers;
  126: 
  127:     /* unregister the location if it was registered before */
  128:     if (p[index] == NULL || SCM_PTRP(p[index])) {
  129:         GC_unregister_disappearing_link((GC_PTR*)&p[index]);
  130:     }
  131: 
  132:     p[index] = value;
  133:     /* register the location if the value is a heap object */
  134:     if (SCM_PTRP(value)) {
  135:         GC_general_register_disappearing_link((GC_PTR*)&p[index], (GC_PTR)value);
  136:     }
  137:     return SCM_UNDEFINED;
  138: }
  139: 
  140: /*=============================================================
  141:  * Weak box
  142:  */
  143: 
  144: /* Weak box is not an ScmObj.  It provides a packaged 'weak pointer'
  145:    feature to C. */
  146: 
  147: /* ptr points to the target object weakly.
  148:    Registered flag becomes TRUE whenever ptr points to a GC_malloced object,
  149:    thus &wbox->ptr is registered as a disappearing link.
  150:    Note that we can distinguish a box that contaning NULL pointer, and
  151:    a box whose target has been GCed and hence ptr is cleared---in the
  152:    former case registered is FALSE, while in the latter case it is TRUE. */
  153: struct ScmWeakBoxRec {
  154:     void *ptr;
  155:     int registered;
  156: };
  157: 
  158: static void wbox_setvalue(ScmWeakBox *wbox, void *value)
  159: {
  160:     GC_PTR base = GC_base((GC_PTR)value);
  161:     wbox->ptr = value;
  162:     if (base != NULL) {
  163:         GC_general_register_disappearing_link((GC_PTR)&wbox->ptr, base);
  164:         wbox->registered = TRUE;
  165:     } else {
  166:         wbox->registered = FALSE;
  167:     }
  168: }
  169: 
  170: 
  171: ScmWeakBox *Scm_MakeWeakBox(void *value)
  172: {
  173:     ScmWeakBox *wbox = SCM_NEW_ATOMIC(ScmWeakBox);
  174:     wbox_setvalue(wbox, value);
  175:     return wbox;
  176: }
  177: 
  178: int Scm_WeakBoxEmptyP(ScmWeakBox *wbox)
  179: {
  180:     return (wbox->registered && wbox->ptr == NULL);
  181: }
  182: 
  183: void Scm_WeakBoxSet(ScmWeakBox *wbox, void *newvalue)
  184: {
  185:     if (wbox->registered) {
  186:         GC_unregister_disappearing_link((GC_PTR)&wbox->ptr);
  187:         wbox->registered = FALSE;
  188:     }
  189:     wbox_setvalue(wbox, newvalue);
  190: }
  191: 
  192: void *Scm_WeakBoxRef(ScmWeakBox *wbox)
  193: {
  194:     return wbox->ptr;           /* NB: if NULL is retured, you can't know
  195:                                    whether box has been containing NULL or
  196:                                    the target is GCed.  You have to call
  197:                                    Scm_WeakBoxEmptyP to check that.
  198:                                    IMPORTANT: If you call EmptyP before
  199:                                    calling Ref, there is a hazard that the
  200:                                    target is GCed between the two calls.
  201:                                    ALWAYS call Ref first and keep the
  202:                                    result in the register, so that it won't
  203:                                    be GCed. */
  204: }
  205: 
  206: /*=============================================================
  207:  * Weak Hash Table
  208:  */
  209: 
  210: /* The table can be created with weak key (key can be GC-ed), weak value
  211:  * (value can be GC-ed), or weak key&value (both key and value can be
  212:  * GC-ed).
  213:  *
  214:  * If a value is GC-ed, the entry returns the default value specified
  215:  * at the hash table creation time.
  216:  *
  217:  * If a key is GC-ed, the entry becomes inaccessible---from outside it
  218:  * looks as if the entry is deleted.  We don't immediately delete the entry
  219:  * at the time we found its key has been GC-ed, since the caller may not
  220:  * expect the table is modified.  Instead we flag the table and delete
  221:  * those entries when the table is modified.
  222:  */
  223: 
  224: #define MARK_GONE_ENTRY(ht, e)  (ht->goneEntries++)
  225: 
  226: 
  227: static void weakhash_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
  228: {
  229:     ScmWeakHashTable *ht = SCM_WEAK_HASH_TABLE(obj);
  230:     char *type = "";
  231: 
  232:     switch (ht->type) {
  233:     case SCM_HASH_EQ:      type = "eq?"; break;
  234:     case SCM_HASH_EQV:     type = "eqv?"; break;
  235:     case SCM_HASH_EQUAL:   type = "equal?"; break;
  236:     case SCM_HASH_STRING:  type = "string=?"; break;
  237:     case SCM_HASH_GENERAL: type = "general"; break;
  238:     default: Scm_Panic("something wrong with a hash table");
  239:     }
  240:     /* should we also print weakness info? */       
  241:     Scm_Printf(port, "#<weak-hash-table %s %p>", type, ht);
  242: }
  243: 
  244: SCM_DEFINE_BUILTIN_CLASS(Scm_WeakHashTableClass, weakhash_print,
  245:                          NULL, NULL, NULL,
  246:                          SCM_CLASS_DICTIONARY_CPL);
  247: 
  248: /* Custom hasher & comparer for key-weak table, in which we insert
  249:    one indirection to the real key via WeakBox. */
  250: static u_long weak_key_hash(const ScmHashCore *hc, intptr_t key)
  251: {
  252:     ScmWeakHashTable *wh = SCM_WEAK_HASH_TABLE(hc->data);
  253:     ScmWeakBox *box = (ScmWeakBox *)key;
  254:     intptr_t realkey = (intptr_t)Scm_WeakBoxRef(box);
  255:     if (Scm_WeakBoxEmptyP(box)) {
  256:         /* There IS a small possibility that the real key has already been
  257:            GCed.  We return an arbitrary value (0 here); the entry won't
  258:            match anyway. */
  259:         fprintf(stderr, "gong!\n");
  260:         return 0;
  261:     } else {
  262:         u_long k= wh->hashfn(hc, realkey);
  263:         Scm_Printf(SCM_CURERR, "%Hciuang %ul %S\n", k, realkey);
  264:         return k;
  265:     }
  266: }
  267:     
  268: 
  269: static int weak_key_compare(const ScmHashCore *hc, intptr_t key,
  270:                             intptr_t entrykey)
  271: {
  272:     ScmWeakHashTable *wh = SCM_WEAK_HASH_TABLE(hc->data);
  273:     ScmWeakBox *box = (ScmWeakBox *)entrykey;
  274:     intptr_t realkey = (intptr_t)Scm_WeakBoxRef(box);
  275:     if (Scm_WeakBoxEmptyP(box)) {
  276:         fprintf(stderr, "gang!\n");
  277:         return FALSE;
  278:     } else {
  279:         return wh->cmpfn(hc, key, realkey);
  280:     }
  281: }
  282: 
  283: /* Scan through  */
  284: #if 0
  285: static void weak_hash_cleanup(ScmWeakHashTable *wh)
  286: {
  287: }
  288: #endif
  289: 
  290: 
  291: ScmObj Scm_MakeWeakHashTableSimple(ScmHashType type,
  292:                                    ScmWeakness weakness,
  293:                                    int initSize,
  294:                                    ScmObj defaultValue)
  295: {
  296:     ScmWeakHashTable *wh = SCM_NEW(ScmWeakHashTable);
  297:     SCM_SET_CLASS(wh, SCM_CLASS_WEAK_HASH_TABLE);
  298:     wh->weakness = weakness;
  299:     wh->type = type;
  300:     wh->defaultValue = defaultValue;
  301:     wh->goneEntries = 0;
  302: 
  303:     if (weakness & SCM_WEAK_KEY) {
  304:         if (!Scm_HashCoreTypeToProcs(type, &wh->hashfn, &wh->cmpfn)) {
  305:             Scm_Error("[internal error] Scm_MakeWeakHashTableSimple: unsupported type: %d", type);
  306:         }
  307:         Scm_HashCoreInitGeneral(&wh->core, weak_key_hash, weak_key_compare,
  308:                                 initSize, wh);
  309:     } else {
  310:         Scm_HashCoreInitSimple(&wh->core, type, initSize, wh);
  311:     }
  312:     return SCM_OBJ(wh);
  313: }
  314: 
  315: ScmObj Scm_WeakHashTableCopy(ScmWeakHashTable *src)
  316: {
  317:     ScmWeakHashTable *wh = SCM_NEW(ScmWeakHashTable);
  318:     SCM_SET_CLASS(wh, SCM_CLASS_WEAK_HASH_TABLE);
  319: 
  320:     wh->weakness = src->weakness;
  321:     wh->type = src->type;
  322:     wh->defaultValue = src->defaultValue;
  323:     wh->hashfn = src->hashfn;
  324:     wh->cmpfn = src->cmpfn;
  325:     wh->goneEntries = 0;
  326:     Scm_HashCoreCopy(&wh->core, &src->core);
  327:     return SCM_OBJ(wh);
  328: }
  329: 
  330: ScmObj Scm_WeakHashTableRef(ScmWeakHashTable *ht, ScmObj key, ScmObj fallback)
  331: {
  332:     ScmDictEntry *e = Scm_HashCoreSearch(SCM_WEAK_HASH_TABLE_CORE(ht),
  333:                                          (intptr_t)key, SCM_DICT_GET);
  334:     if (!e) return fallback;
  335:     if (ht->weakness & SCM_WEAK_VALUE) {
  336:         void *val = Scm_WeakBoxRef((ScmWeakBox*)e->value);
  337:         if (Scm_WeakBoxEmptyP((ScmWeakBox*)e->value)) return ht->defaultValue;
  338:         SCM_ASSERT(val != NULL);
  339:         return SCM_OBJ(val);
  340:     } else {
  341:         return SCM_DICT_VALUE(e);
  342:     }
  343: }
  344: 
  345: ScmObj Scm_WeakHashTableSet(ScmWeakHashTable *ht, ScmObj key, ScmObj value,
  346:                             int flags)
  347: {
  348:     ScmDictEntry *e;
  349:     intptr_t proxy;
  350: 
  351:     if (ht->weakness&SCM_WEAK_KEY) {
  352:         proxy = (intptr_t)Scm_MakeWeakBox(key);
  353:     } else {
  354:         proxy = (intptr_t)key;
  355:     }
  356:     
  357:     e = Scm_HashCoreSearch(SCM_WEAK_HASH_TABLE_CORE(ht), proxy,
  358:                            (flags&SCM_DICT_NO_CREATE)?SCM_DICT_GET:SCM_DICT_CREATE);
  359:     if (!e) return SCM_UNBOUND;
  360:     if (ht->weakness&SCM_WEAK_VALUE) {
  361:         if (flags&SCM_DICT_NO_OVERWRITE) {
  362:             if (e->value) {
  363:                 void *val = Scm_WeakBoxRef((ScmWeakBox*)e->value);
  364:                 if (!Scm_WeakBoxEmptyP((ScmWeakBox*)e->value))
  365:                     return SCM_OBJ(val);
  366:             }
  367:         }
  368:         e->value = (intptr_t)Scm_MakeWeakBox(value);
  369:         return value;
  370:     } else {
  371:         if (flags&SCM_DICT_NO_OVERWRITE && e->value) {
  372:             return SCM_DICT_VALUE(e);
  373:         }
  374:         (void)SCM_DICT_SET_VALUE(e, value);
  375:         return value;
  376:     }
  377: }
  378: 
  379: ScmObj Scm_WeakHashTableDelete(ScmWeakHashTable *ht, ScmObj key)
  380: {
  381:     ScmDictEntry *e = Scm_HashCoreSearch(SCM_WEAK_HASH_TABLE_CORE(ht),
  382:                                          (intptr_t)key, SCM_DICT_DELETE);
  383:     if (e && e->value) {
  384:         if (ht->weakness&SCM_WEAK_VALUE) {
  385:             void *val = Scm_WeakBoxRef((ScmWeakBox*)e->value);
  386:             if (!Scm_WeakBoxEmptyP((ScmWeakBox*)e->value))
  387:                 return SCM_OBJ(val);
  388:             else
  389:                 return SCM_UNBOUND;
  390:         } else {
  391:             return SCM_DICT_VALUE(e);
  392:         }
  393:     } else {
  394:         return SCM_UNBOUND;
  395:     }
  396: }
  397: 
  398: void Scm_WeakHashIterInit(ScmWeakHashIter *iter, ScmWeakHashTable *ht)
  399: {
  400:     Scm_HashIterInit(&iter->iter, SCM_WEAK_HASH_TABLE_CORE(ht));
  401:     iter->table = ht;
  402: }
  403: 
  404: int Scm_WeakHashIterNext(ScmWeakHashIter *iter, ScmObj *key, ScmObj *value)
  405: {
  406:     for (;;) {
  407:         ScmDictEntry *e = Scm_HashIterNext(&iter->iter);
  408:         if (e == NULL) return FALSE;
  409:         if (iter->table->weakness & SCM_WEAK_KEY) {
  410:             ScmWeakBox *box = (ScmWeakBox*)e->key;
  411:             ScmObj realkey = SCM_OBJ(Scm_WeakBoxRef(box));
  412:             if (Scm_WeakBoxEmptyP(box)) {
  413:                 MARK_GONE_ENTRY(iter->table, e);
  414:                 continue;
  415:             }
  416:             *key = realkey;
  417:         } else {
  418:             *key = (ScmObj)e->key;
  419:         }
  420:         
  421:         if (iter->table->weakness & SCM_WEAK_VALUE) {
  422:             ScmWeakBox *box = (ScmWeakBox*)e->value;
  423:             ScmObj realval = SCM_OBJ(Scm_WeakBoxRef(box));
  424:             if (Scm_WeakBoxEmptyP(box)) {
  425:                 *value = iter->table->defaultValue;
  426:             } else {
  427:                 *value = realval;
  428:             }
  429:         } else {
  430:             *value = (ScmObj)e->value;
  431:         }
  432:         return TRUE;
  433:     }
  434: }
  435: 
  436: ScmObj Scm_WeakHashTableKeys(ScmWeakHashTable *table)
  437: {
  438:     ScmWeakHashIter iter;
  439:     ScmObj h = SCM_NIL, t = SCM_NIL, k, v;
  440:     Scm_WeakHashIterInit(&iter, table);
  441:     while (Scm_WeakHashIterNext(&iter, &k, &v)) {
  442:         SCM_APPEND1(h, t, k);
  443:     }
  444:     return h;
  445: }
  446: 
  447: ScmObj Scm_WeakHashTableValues(ScmWeakHashTable *table)
  448: {
  449:     ScmWeakHashIter iter;
  450:     ScmObj h = SCM_NIL, t = SCM_NIL, k, v;
  451:     Scm_WeakHashIterInit(&iter, table);
  452:     while (Scm_WeakHashIterNext(&iter, &k, &v)) {
  453:         SCM_APPEND1(h, t, v);
  454:     }
  455:     return h;
  456: }
  457: