root/trunk/thune/context.c

/*============================================================================
    Thune Interpreter
    Copyright (C) 2005-2007  Karl Robillard

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
===========================================================================*/


#include "internal.h"


#define SEARCH_LEN      5

#define LOWERCASE(c)    if(c >= 'A' && c <= 'Z') c -= 'A' - 'a'


/*
   UrlanEnv::atoms & UrlanEnv::atomNames can be made thread safe through one
   of the following:

   1. Use LOCK_ATOMS in or around these functions:
        ur_internT()
        ur_atomStrT()
        ur_atomCStrT() (and all use of returned pointer)
        ur_atomHash()
        dumpAtoms()

   2. Fix size of atom arrays and throw error/assert when full.
      Must still lock these functions to access head/chain AtomRec members:
        ur_internT()
        dumpAtoms()

   Option #2 is currently being used.
*/


/**
  Appends atom name to string.
*/
void ur_atomStrT( UThread* ut, UAtom atom, UString* str )
{
    AtomRec* rec = ((AtomRec*) ut->env->atoms.ptr.v) + atom;

    ur_arrayReserve( str, sizeof(char), str->used + rec->nameLen );
    memCpy( str->ptr.c + str->used,
            ut->env->atomNames.ptr.c + rec->nameIndex,
            rec->nameLen );
    str->used += rec->nameLen;
}


uint32_t ur_atomHash( UrlanEnv* env, UAtom atom )
{
    return ((AtomRec*) env->atoms.ptr.v)[ atom ].hash;
}


const char* ur_atomCStrT( UThread* ut, UAtom atom, int* plen )
{
    AtomRec* rec = ((AtomRec*) ut->env->atoms.ptr.v) + atom;
    if( plen )
        *plen = rec->nameLen;
    return ut->env->atomNames.ptr.c + rec->nameIndex;
}


uint32_t ur_hash( const uint8_t* str, const uint8_t* end )
{
    int c;
    uint32_t hashval = 0;

    while( str != end )
    {
        c = *str++;
        LOWERCASE( c );
        hashval = (33 * hashval) + 720 + c;
    }

    return hashval;
}


#define HASH_INSERT( atoms, table, node, hash, index ) \
    node = table + (hash % atoms->avail); \
    if( node->head == 0xffff ) \
        node->head = index; \
    else { \
        node = table + node->head; \
        while( node->chain != 0xffff ) \
            node = table + node->chain; \
        node->chain = index; \
    }


void ur_rebuildAtomHash( UArray* arr )
{
    AtomRec* table;
    AtomRec* node;
    AtomRec* it;
    AtomRec* end;

    table = (AtomRec*) arr->ptr.v;

    // Clear lookup table.

    it  = table;
    end = table + arr->avail;
    while( it != end )
    {
        it->head  = 0xffff;
        it->chain = 0xffff;
        ++it;
    }

    // Re-insert existing entries.

    it  = table;
    end = table + arr->used;
    while( it != end )
    {
        HASH_INSERT( arr, table, node, it->hash, it - table )
        ++it;
    }
}


#ifdef DEBUG
void dumpAtoms( UThread* ut )
{
    LOCK_ATOMS
    {
    const char* names = ut->env->atomNames.ptr.c;
    AtomRec* table = (AtomRec*) ut->env->atoms.ptr.v;
    AtomRec* it  = table;
    AtomRec* end = table + ut->env->atoms.used;

#if __WORDSIZE == 64
#define OFFINT  "%4ld"
#else
#define OFFINT  "%4d"
#endif

    while( it != end )
    {
        dprint( OFFINT " %08x %5d %5d %s\n", it - table, it->hash,
                it->head, it->chain,
                names + it->nameIndex );
        ++it;
    }

    end = table + ut->env->atoms.avail;
    while( it != end )
    {
        dprint( OFFINT " %08x %5d %5d none\n", it - table, it->hash,
                it->head, it->chain );
        ++it;
    }
    }
    UNLOCK_ATOMS
}
#endif


/**
  Add atom to environment.

  \param str  Name of atom.
  \param len  Number of characters.

  \return  Atom 
*/
UAtom ur_internT( UThread* ut, const char* str, int len )
{
    char* cp;
    const char* ep;
    const char* sp;
    UArray* atoms;
    UString* names;
    int c;
    uint32_t hash;
    AtomRec* table;
    AtomRec* node;

    assert( len > 0 );


    // Check if atom already exists.

    hash = ur_hash( (uint8_t*) str, (uint8_t*) str + len );

    LOCK_ATOMS

    atoms = &ut->env->atoms;
    table = (AtomRec*) atoms->ptr.v;
    names = &ut->env->atomNames;

    node = table + (hash % atoms->avail);
    if( node->head == 0xffff )
    {
        node->head = atoms->used;
    }
    else
    {
        node = table + node->head;
        while( 1 )
        {
#if 0
            if( node->nameLen == len )
                goto done;
#else
            if( node->nameLen == len )
            {
                const char* it;
                sp = names->ptr.c + node->nameIndex;
                it = str;
                ep = str + len;
                while( it != ep )
                {
                    c = *it++;
                    LOWERCASE( c );
                    if( *sp++ != c )
                        break;
                }

                if( it == ep )
                    goto done;
            }
#endif

            if( node->chain == 0xffff )
            {
                node->chain = atoms->used;
                break;
            }
            node = table + node->chain;
        }
    }


    // Nope, add new atom.

    if( atoms->used == atoms->avail )
    {
#if 1
        // Atom table size is fixed so read only access does not need to be
        // locked.  When the table is full, we are finished.
        assert( 0 && "Atom table is full" );
        return 0;       // TODO: Report fatal error
#else
        ur_arrayReserve( atoms, sizeof(AtomRec), atoms->used + 1 );
        ur_rebuildAtomHash( atoms );
        table = (AtomRec*) atoms->ptr.v;

        HASH_INSERT( atoms, table, node, hash, atoms->used )
#endif
    }
    node = table + atoms->used;
    ++atoms->used;

    node->hash      = hash;
    node->nameIndex = names->used;
    node->nameLen   = len;

#if 1
    if( (names->used + len + 1) > names->avail )
    {
        assert( 0 && "Atom name buffer is full" );
        return 0;       // TODO: Report fatal error
    }
#else
    ur_arrayReserve( names, sizeof(char), names->used + len + 1 );
#endif

    cp = names->ptr.c + names->used;
    ep = cp + len;
    names->used += len + 1;
    while( cp != ep )
    {
        c = *str++;
        LOWERCASE( c );
        *cp++ = c;
    }
    *cp = '\0';

done:

    c = node - table;

    UNLOCK_ATOMS

    return c;
}


static int _binarySearch( UCell* words, int count, UAtom atom );


/**
  Find word in context by atom.
  \return  Word index or -1 if not found.
*/
static int _lookupNoSort( UThread* ut, const UContext* ctx, UAtom atom )
{
    UBlock* wblk;
    UCell* it;
    UCell* end;

    wblk = ur_blockPtr( ctx->ctx.wordBlk );
    it = wblk->ptr.cells;

    if( (wblk->used < SEARCH_LEN) || (it->word.sel == UR_CTX_UNORDERED) )
    {
        end = it + wblk->used;
        while( it != end )
        {
            if( it->word.atom == atom )
                return it - wblk->ptr.cells;
            ++it;
        }
        return -1;
    }
    else
    {
        return _binarySearch( it, wblk->used, atom );
    }
}


static int _internWord( UThread* ut, const UContext* ctx, UAtom atom )
{
    int wrdN;
    UBlock* vblk;
    UBlock* wblk;
    UCell* it;

    wblk = ur_blockPtr( ctx->ctx.wordBlk );
    wrdN = wblk->used;
    UR_EXPAND_1( UCell, wblk, it );

    ur_initType( it, UT_WORD );
    it->word.atom    = atom;
    it->word.wordBlk = 0;
    it->word.valBlk  = ctx->ctx.valBlk;
    it->word.index   = 0;
    it->word.sel     = 0;

    wblk->ptr.cells->word.sel = UR_CTX_UNORDERED;

    vblk = ur_blockPtr( ctx->ctx.valBlk );
    if( vblk->used < wblk->used )
    {
        ur_arrayReserve( vblk, sizeof(UCell), wblk->used );
        vblk->used = wblk->used;

        it = vblk->ptr.cells + wrdN;
        ur_initType( it, UT_UNSET );
    }

    return wrdN;
}


/**
  Add word to context if it does not already exist.
  If added, the word is initialied as unset.

  \return  Index of word in context.
*/
int ur_internWordT( UThread* ut, const UContext* ctx, UAtom atom )
{
    int wrdN;

    wrdN = _lookupNoSort( ut, ctx, atom );
    if( wrdN > -1 )
        return wrdN;

    // Not found - add new word.
    return _internWord( ut, ctx, atom );
}


#define QS_VAL(a)   cells[a].word.sel

// Using series.end to swap word.index & word.sel together.
#define QS_SWAP(a,b) \
    stmp = cells[a].series.end; \
    cells[a].series.end = cells[b].series.end; \
    cells[b].series.end = stmp

static void _quickSort( UCell* cells, int low, int high )
{
    int i, j;
    UAtom val;
    UIndex stmp;

    if( low >= high )
        return;

    val = QS_VAL(low);
    i = low;
    j = high+1;
    for(;;)
    {
        do i++; while( i <= high && QS_VAL(i) < val );
        do j--; while( QS_VAL(j) > val );
        if( i > j )
            break;
        QS_SWAP( i, j );
    }
    QS_SWAP( low, j );
    _quickSort( cells, low, j-1 );
    _quickSort( cells, j+1, high );
}


static void _orderWords( UCell* words, int count )
{
    UCell* it;
    UCell* end;
    int index = 0;

    it  = words;
    end = words + count;

    while( it != end )
    {
        it->word.index = index++;
        it->word.sel   = ur_atom(it);
        ++it;
    }

    _quickSort( words, 0, count - 1 );
}


/*
   Returns index of atom in word block or -1 if not found.
*/
static int _binarySearch( UCell* words, int count, UAtom atom )
{
    int sAtom;
    int mid;
    int low = 0;
    int high = count - 1;

    while( low <= high )
    {
        mid = ((unsigned int) (low + high)) >> 1;
        sAtom = words[ mid ].word.sel;

        if( sAtom < atom )
            low = mid + 1;
        else if( sAtom > atom )
            high = mid - 1;
        else
            return words[ mid ].word.index;
    }

    // Atom not found.
    return -1;
}


/**
  Find word in context by atom.
  \return  Word index or -1 if not found.
*/
int ur_lookupT( UThread* ut, const UContext* ctx, UAtom atom )
{
    UBlock* wblk;
    UCell* it;
    UCell* end;

    wblk = ur_blockPtr( ctx->ctx.wordBlk );
    it = wblk->ptr.cells;

    if( wblk->used < SEARCH_LEN )
    {
        end = it + wblk->used;
        while( it != end )
        {
            if( it->word.atom == atom )
                return it - wblk->ptr.cells;
            ++it;
        }
        return -1;
    }
    else
    {
        if( it->word.sel == UR_CTX_UNORDERED )
        {
            _orderWords( it, wblk->used );
        }
        return _binarySearch( it, wblk->used, atom );
    }
}


// Atom remains the same.

#define _bindWord(cell) \
    wrdN = ur_lookup( ctx, cell->word.atom ); \
    if( wrdN > -1 ) { \
        if( ur_bindType(cell) != btype ) \
            ur_setBindType(cell,btype); \
        cell->word.wordBlk = ctx->ctx.wordBlk; \
        cell->word.valBlk  = ctx->ctx.valBlk; \
        cell->word.index   = wrdN; }


UBlock* ur_bindT( UThread* ut, UIndex blkN, const UContext* ctx, int btype )
{
    int wrdN;
    UBlock* blk = ur_blockPtr( blkN );
    UCell* it  = blk->ptr.cells;
    UCell* end = it + blk->used;

    if( ur_isGlobal(blkN) )
        return 0;       // Cannot bind global blocks.

    while( it != end )
    {
        switch( ur_type(it) )
        {
            case UT_WORD:
            case UT_SETWORD:
            case UT_GETWORD:
            case UT_LITWORD:
            case UT_SELECT:
            case UT_SETSELECT:
            case UT_LITSELECT:
            case UT_OPCODE:
                _bindWord( it );
                break;

            case UT_PATH:
            case UT_SETPATH:
            {
                UCell* path1 = ur_blockPtr( it->series.n )->ptr.cells;
                if( ur_isAWord(path1) )
                {
                    _bindWord( path1 );
                }
            }
                break;

            case UT_BLOCK:
            case UT_PAREN:
                ur_bindT( ut, it->series.n, ctx, btype );
                break;

            case UT_FUNCTION:
                ur_bindT( ut, it->func.bodyN, ctx, btype );

                // NOTE: Will probably need to rebind to local func context in
                // case ctx contains the same words. 
                //orBind( orBlockPtr( it->func.bodyBlk ), it->func.context );
                break;
        }

        ++it;
    }

    return blk;
}


extern UContext ur_envGlobal;

/*
   wc->flags, wc->word wordBlk, valBlk, & index are set.
   ctop must be greater than cbot.
*/
void ur_internDefault( UThread* ut, UCell* wc, UAtom atom,
                       UCell* cbot, UCell* ctop )
{
    UCell* cit;
    int wrdN;

    // Look for atom in module context stack.
    cit = ctop;
    do
    {
        --cit;
        wrdN = _lookupNoSort( ut, cit, atom );
        if( wrdN > -1 )
            goto assign;
    }
    while( cit != cbot );


    // Now try the shared global context.
    if( ut->env->blocks.arr.used )
    {
        wrdN = ur_lookup( &ur_envGlobal, atom );
        if( wrdN > -1 )
        {
            ur_setBindType( wc, UR_BIND_GLOBAL );
            wc->word.wordBlk = ur_envGlobal.ctx.wordBlk;
            wc->word.valBlk  = ur_envGlobal.ctx.valBlk;
            wc->word.index   = wrdN;
            return;
        }
    }

    // Word not found, so intern into current module (top of context stack).
    cit = ctop - 1;
    wrdN = _internWord( ut, cit, atom );

assign:

    ur_setBindType( wc, UR_BIND_THREAD );
    wc->word.wordBlk = cit->ctx.wordBlk;
    wc->word.valBlk  = cit->ctx.valBlk;
    wc->word.index   = wrdN;
}


static
UBlock* _bindDefault( UThread* ut, UIndex blkN, UCell* cbot, UCell* ctop )
{
    UBlock* blk;
    UCell* it;
    UCell* end;

    if( ur_isGlobal(blkN) )
        return 0;       // Cannot bind global blocks.

    blk = ur_blockPtr( blkN );
    it  = blk->ptr.cells;
    end = it + blk->used;

    while( it != end )
    {
        switch( ur_type(it) )
        {
            case UT_WORD:
            case UT_SETWORD:
            case UT_GETWORD:
            case UT_LITWORD:
            case UT_SELECT:
            case UT_SETSELECT:
            case UT_LITSELECT:
            case UT_OPCODE:
                ur_internDefault( ut, it, ur_atom(it), cbot, ctop );
                break;

            case UT_PATH:
            case UT_SETPATH:
            {
                UCell* path1 = ur_blockPtr( it->series.n )->ptr.cells;
                if( ur_isAWord(path1) )
                {
                    ur_internDefault( ut, path1, ur_atom(path1), cbot, ctop );
                }
            }
                break;

            case UT_BLOCK:
            case UT_PAREN:
                _bindDefault( ut, it->series.n, cbot, ctop );
                break;

            case UT_FUNCTION:
                _bindDefault( ut, it->func.bodyN, cbot, ctop );
                break;
        }

        ++it;
    }

    return blk;
}


void ur_bindDefault( UThread* ut, UIndex blkN )
{
    UBlock* blk;
    UBlock* cblk;
    UCell* ctx;
    UCell* it;
    UCell* end;

    cblk = tBlockPtr( BLK_CTX_STACK );
    ctx = cblk->ptr.cells + (cblk->used - 1);

    // Intern all set-words found in block to the top context.
    blk = ur_blockPtr( blkN );
    it  = blk->ptr.cells;
    end = it + blk->used;
    while( it != end )
    {
        if( ur_is(it, UT_SETWORD) )
            ur_internWord( ctx, it->word.atom );
        ++it;
    }

    _bindDefault( ut, blkN, cblk->ptr.cells,
                            cblk->ptr.cells + cblk->used );
}


#if 0
/**
   Intern all set-words found in block to the top context.
*/
void ur_internSetWords( UThread* ut, UIndex blkN )
{
    UBlock* blk;
    UBlock* cblk;
    UCell* ctx;
    UCell* it;
    UCell* end;

    cblk = tBlockPtr( BLK_CTX_STACK );
    ctx = cblk->ptr.cells + (cblk->used - 1);

    blk = ur_blockPtr( blkN );
    it  = blk->ptr.cells;
    end = it + blk->used;
    while( it != end )
    {
        if( ur_is(it, UT_SETWORD) )
            ur_internWord( ctx, it->word.atom );
        ++it;
    }
}
#endif


/*EOF*/