/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2016-2024, VU University Amsterdam
			      CWI, Amsterdam
			      SWI-Prolog Solutions b.v.
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

#define NO_TRIE_GEN_HELPERS 1
#include "pl-incl.h"
#include "pl-comp.h"
#include "pl-trie.h"
#include "pl-tabling.h"
#include "pl-indirect.h"
#include "pl-proc.h"
#include "pl-prims.h"
#include "pl-wam.h"
#include "pl-gc.h"
#include "pl-fli.h"
#include "pl-rec.h"
#include "pl-util.h"
#include "pl-attvar.h"
#include "pl-pro.h"
#define NO_AC_TERM_WALK 1
#define AC_TERM_WALK_POP 1
#include "pl-termwalk.c"
#include "pl-dbref.h"

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This file implements tries of  terms.  The   trie  itself  lives  in the
program space and is represented by a (symbol) handle. This implies that
tries are subject to garbage collection.

A path through a trie represents a  sequence of tokens. For representing
terms, these tokens are functor symbols,   variables  and atomic values.
The _value_ associated with a  term  always   appears  in  a _leaf_ node
because a sequence that represents a term   is  _never_ the prefix of of
the sequence of another term.

TODO
  - Limit size of the tries
  - Avoid using a hash-table for small number of branches
  - Thread safe reclaiming
    - Reclaim single-child node after moving to a hash
    - Make pruning the trie thread-safe
  - Provide deletion from a trie
  - Make trie_gen/3 take the known prefix into account
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define RESERVED_TRIE_VAL(n) (((word)((uintptr_t)n)<<LMASK_BITS) | \
			      TAG_VAR|STG_LOCAL)
#define TRIE_ERROR_VAL       RESERVED_TRIE_VAL(1)
#define TRIE_KEY_POP(n)      RESERVED_TRIE_VAL(10+(n))

#define IS_TRIE_KEY_POP(w)   ((size_t)((tagex(w) == (TAG_VAR|STG_LOCAL) && \
					((w)>>LMASK_BITS) > 10) ? ((w)>>LMASK_BITS) - 10 \
								: 0))

#define NVARS_FAST 100

/* Will eventually be shared in pl-wam.c */
typedef enum
{ uread = 0,				/* Unification in read-mode */
  uwrite				/* Unification in write mode */
} unify_mode;

typedef struct ukey_state
{ trie	       *trie;			/* Trie for indirects */
  Word		ptr;			/* current location */
  unify_mode	umode;			/* unification mode */
  size_t	max_var_seen;
  size_t	vars_allocated;		/* # variables allocated */
  Word*		vars;
  size_t        a_offset;		/* For resetting the argument stack */
  Word		var_buf[NVARS_FAST];	/* quick var buffer */
} ukey_state;

#if USE_LD_MACROS
#define	unify_key(state, key)			LDFUNC(unify_key, state, key)
#define	init_ukey_state(state, trie, p)		LDFUNC(init_ukey_state, state, trie, p)
#define	destroy_ukey_state(state)		LDFUNC(destroy_ukey_state, state)
#endif /*USE_LD_MACROS*/

#define LDFUNC_DECLARATIONS

static int	unify_key(ukey_state *state, word key);
static void	init_ukey_state(ukey_state *state, trie *trie, Word p);
static void	destroy_ukey_state(ukey_state *state);
static void	set_trie_clause_general_undefined(Clause cl);
static void	trie_destroy(trie *trie);

#undef LDFUNC_DECLARATIONS


		 /*******************************
		 *	       SYMBOL		*
		 *******************************/

typedef struct tref
{ trie *trie;				/* represented trie */
} tref;

static int
write_trie_ref(IOSTREAM *s, atom_t aref, int flags)
{ tref *ref = PL_blob_data(aref, NULL, NULL);
  (void)flags;

  Sfprintf(s, "<trie>(%p)", ref->trie);
  return TRUE;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
GC a trie. Note that the  Prolog predicate trie_destroy/1 merely empties
the trie, leaving its destruction to   the  atom garbage collector. This
function is also called from pl-tabling.c   when  we accidentally create
the same variant trie concurrently and  need   to  dispose  of one. As a
result, this must be public and thread-safe.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

int
release_trie_ref(atom_t aref)
{ tref *ref = PL_blob_data(aref, NULL, NULL);
  trie *t = ref->trie;

  if ( t && COMPARE_AND_SWAP_PTR(&ref->trie, t, NULL) )
    trie_destroy(t);			/* can be called twice */

  return TRUE;
}


static int
save_trie(atom_t aref, IOSTREAM *fd)
{ tref *ref = PL_blob_data(aref, NULL, NULL);
  (void)fd;

  return PL_warning("Cannot save reference to <trie>(%p)", ref->trie);
}


static atom_t
load_trie(IOSTREAM *fd)
{ (void)fd;

  return PL_new_atom("<saved-trie-ref>");
}


static PL_blob_t trie_blob =
{ PL_BLOB_MAGIC,
  0,
  "trie",
  release_trie_ref,
  NULL,
  write_trie_ref,
  NULL,
  save_trie,
  load_trie
};

		 /*******************************
		 *	     THE TRIE		*
		 *******************************/

static trie_node       *new_trie_node(trie *trie, word key);
static void		destroy_node(trie *trie, trie_node *n);
static void		clear_node(trie *trie, trie_node *n, int dealloc);
static inline void	release_value(word value);


static inline void
acquire_key(word key)
{ if ( isAtom(key) )
    PL_register_atom(word2atom(key));
}

static inline void
release_key(word key)
{ if ( isAtom(key) )
    PL_unregister_atom(word2atom(key));
}


trie *
trie_create(alloc_pool *pool)
{ trie *trie;

  if ( (trie = alloc_from_pool(pool, sizeof(*trie))) )
  { memset(trie, 0, sizeof(*trie));
    trie->magic = TRIE_MAGIC;
    trie->node_count = 1;		/* the root */
    trie->alloc_pool = pool;
  }

  return trie;
}


static void
trie_destroy(trie *trie)
{ DEBUG(MSG_TRIE_GC, Sdprintf("Destroying trie %p\n", trie));
  trie->magic = TRIE_CMAGIC;
  trie_empty(trie);
  free_to_pool(trie->alloc_pool, trie, sizeof(*trie));
}


void
trie_discard_clause(trie *trie)
{ atom_t dbref;

  if ( (dbref=trie->clause) )
  { if ( COMPARE_AND_SWAP_ATOM(&trie->clause, dbref, 0) &&
	 GD->cleaning == CLN_NORMAL )		/* otherwise reclaims clause */
    { ClauseRef cref = clause_clref(dbref);	/* from two ends */

      if ( cref )
      { Clause cl = cref->value.clause;
	set_trie_clause_general_undefined(cl);	/* TBD: only if undefined */
	retractClauseDefinition(cl->predicate, cl, FALSE);
      }
      PL_unregister_atom(dbref);
    }
  }
}


void
trie_empty(trie *trie)
{ trie_discard_clause(trie);

  if ( !trie->references )
  { indirect_table *it = trie->indirects;

    clear_node(trie, &trie->root, FALSE);	/* TBD: verify not accessed */
    if ( it && COMPARE_AND_SWAP_PTR(&trie->indirects, it, NULL) )
      destroy_indirect_table(it);
    trie->node_count = 1;
    trie->value_count = 0;
  }
}


void
trie_clean(trie *trie)
{ if ( trie->magic == TRIE_CMAGIC )
    trie_empty(trie);
}


#define get_child(n, key) LDFUNC(get_child, n, key)
static trie_node *
get_child(DECL_LD trie_node *n, word key)
{ trie_children children = n->children;

  if ( children.any )
  { switch( children.any->type )
    { case TN_KEY:
	if ( children.key->key == key )
	  return children.key->child;
        return NULL;
      case TN_HASHED:
	return lookupHTableWP(children.hash->table, key);
      default:
	assert(0);
    }
  }

  return NULL;
}


int
is_leaf_trie_node(trie_node *n)
{ trie_children children = n->children;

  if ( children.any )
  { switch( children.any->type )
    { case TN_KEY:
	return FALSE;
      case TN_HASHED:
	return children.hash->table->size == 0;
      default:
	assert(0);
    }
  }

  return TRUE;
}


static trie_node *
new_trie_node(trie *trie, word key)
{ trie_node *n;

  if ( (n = alloc_from_pool(trie->alloc_pool, sizeof(*n))) )
  { ATOMIC_INC(&trie->node_count);
    memset(n, 0, sizeof(*n));
    acquire_key(key);
    n->key = key;
  }

  return n;
}


static void
clear_node(trie *trie, trie_node *n, int dealloc)
{ trie_children children;

next:
  children = n->children;

  if ( trie->release_node )
    (*trie->release_node)(trie, n);

  release_key(n->key);
  if ( n->value )
    release_value(n->value);

  if ( dealloc )
  { ATOMIC_DEC(&trie->node_count);
    free_to_pool(trie->alloc_pool, n, sizeof(trie_node));
  } else
  { n->children.any = NULL;
    clear(n, TN_PRIMARY|TN_SECONDARY);
  }

  if ( children.any )
  { switch( children.any->type )
    { case TN_KEY:
      { n = children.key->child;
	free_to_pool(trie->alloc_pool, children.key, sizeof(*children.key));
	dealloc = TRUE;
	goto next;
      }
      case TN_HASHED:
      { TableWP table = children.hash->table;
	TableEnum e = newTableEnumWP(table);
	trie_children_key *os;

	if ( (os=children.hash->old_single) )	/* see insert_child() (*) note */
	  free_to_pool(trie->alloc_pool, os, sizeof(*os));
	free_to_pool(trie->alloc_pool, children.hash, sizeof(*children.hash));

	table_value_t tv;
	while(advanceTableEnum(e, NULL, &tv))
	  clear_node(trie, val2ptr(tv), TRUE);

	freeTableEnum(e);
	destroyHTableWP(table);
	break;
      }
    }
  }
}

static void
destroy_node(trie *trie, trie_node *n)
{ clear_node(trie, n, TRUE);
}


/*
 * Prune a branch of the trie that does not end in a node.  This should
 * be used after deletion or unsuccessful insertion, e.g., by trying to
 * insert a cyclic term
 *
 * TBD: Need to think about concurrency here.
 */

void
prune_node(trie *trie, trie_node *n)
{ trie_node *p;
  int empty = TRUE;

  for(; empty && n->parent && false(n, TN_PRIMARY|TN_SECONDARY); n = p)
  { trie_children children;

    p = n->parent;
    children = p->children;

    if ( children.any )
    { switch( children.any->type )
      { case TN_KEY:
	  if ( COMPARE_AND_SWAP_PTR(&p->children.any, children.any, NULL) )
	  { if ( !trie )
	      trie = get_trie_from_node(n);
	    free_to_pool(trie->alloc_pool, children.key, sizeof(*children.key));
	  }
	  break;
	case TN_HASHED:
	  deleteHTableWP(children.hash->table, n->key);
	  empty = children.hash->table->size == 0;
	  break;
      }
    }

    if ( !trie )
      trie = get_trie_from_node(n);
    destroy_node(trie, n);
  }
}

/** Prune all branches below `root` that do not end in a value.
 *
 * @param `free` is called for each removed _leaf_ node.
*/

typedef struct prune_state
{ TableEnum  e;
  trie_node *n;
} prune_state;

void
prune_trie(trie *trie, trie_node *root,
	   void (*free)(trie_node *node, void *ctx), void *ctx)
{ segstack stack;
  prune_state buffer[64];
  trie_children children;
  trie_node *n = root;
  trie_node *p;
  prune_state ps = { .e = NULL };

  initSegStack(&stack, sizeof(prune_state), sizeof(buffer), buffer);

  for(;;)
  { children = n->children;

    if ( children.any )
    { switch( children.any->type )
      { case TN_KEY:
	{ n = children.key->child;
	  continue;
	}
	case TN_HASHED:
	{ TableWP table = children.hash->table;
	  TableEnum e = newTableEnumWP(table);
	  table_value_t v;

	  if ( advanceTableEnum(e, NULL, &v) )
	  { if ( !pushSegStack(&stack, ps, prune_state) )
	      outOfCore();
	    ps.e = e;
	    ps.n = n;

	    n = val2ptr(v);
	    continue;
	  } else
	  { freeTableEnum(e);
	    break;
	  }
	}
      }
    } else
    { if ( free )
	(*free)(n, ctx);
    }

  prune:
    for(; n != root && false(n, TN_PRIMARY|TN_SECONDARY); n = p)
    { trie_children children;
      int choice = FALSE;

      p = n->parent;
      children = p->children;

      if ( children.any )
      { switch( children.any->type )
	{ case TN_KEY:
	    if ( COMPARE_AND_SWAP_PTR(&p->children.any, children.any, NULL) )
	      free_to_pool(trie->alloc_pool, children.key, sizeof(*children.key));
	    break;
	  case TN_HASHED:
	    deleteHTableWP(children.hash->table, n->key);
	    choice = TRUE;
	    break;
	}
      }

      destroy_node(trie, n);
      if ( choice )
	break;
    }

  next_choice:
    if ( ps.e )
    { table_value_t v;

      if ( advanceTableEnum(ps.e, NULL, &v) )
      { n = val2ptr(v);
	continue;
      } else
      { n = ps.n;
	freeTableEnum(ps.e);
	popSegStack(&stack, &ps, prune_state);
	assert(n->children.any->type == TN_HASHED);
	if ( n->children.hash->table->size == 0 )
	  goto prune;
	goto next_choice;
      }
    } else
    { break;
    }
  }

  clearSegStack(&stack);
}


#define VMASKBITS  (sizeof(unsigned)*8)
#define VMASK_SCAN (0x1U<<(VMASKBITS-1))

static inline void
update_var_mask(trie_children_hashed *hnode, word key)
{ if ( tagex(key) == TAG_VAR )
  { size_t vn = (size_t)(key>>LMASK_BITS); /* 1.. */
    unsigned mask;

    if ( vn < VMASKBITS )
      mask = 0x1U<<(vn-1);
    else
      mask = VMASK_SCAN;

    ATOMIC_OR(&hnode->var_mask, mask);
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(*) The single node may be  in  use   with  another  thread. We have two
options:

  - Use one of the LD _active_ pointers to acquire/release access to the
    trie nodes and use safe delayed release.
  - Add the ond _single_ node to the new hash node and delete it along
    with the hash node when we clean the table.  We have opted for this
    option as it is simple and the single key is neglectable in size
    compared to the hash table anyway.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define insert_child(trie, n, key) LDFUNC(insert_child, trie, n, key)
static trie_node *
insert_child(DECL_LD trie *trie, trie_node *n, word key)
{ for(;;)
  { trie_children children = n->children;
    trie_node *new = new_trie_node(trie, key);

    if ( !new )
      return NULL;			/* resource error */

    if ( children.any )
    { switch( children.any->type )
      { case TN_KEY:
	{ if ( children.key->key == key )
	  { destroy_node(trie, new);	/* someone else did this */
	    return children.key->child;
	  } else
	  { trie_children_hashed *hnode;

	    if ( !(hnode=alloc_from_pool(trie->alloc_pool, sizeof(*hnode))) )
	    { destroy_node(trie, new);
	      return NULL;
	    }

	    hnode->type     = TN_HASHED;
	    hnode->table    = newHTableWP(4);
	    hnode->var_mask = 0;
	    addHTableWP(hnode->table, children.key->key, children.key->child);
	    addHTableWP(hnode->table, key, new);
	    update_var_mask(hnode, children.key->key);
	    update_var_mask(hnode, new->key);
	    new->parent = n;

	    if ( COMPARE_AND_SWAP_PTR(&n->children.hash, children.hash, hnode) )
	    { hnode->old_single = children.key;			/* See (*) */
	      return new;
	    } else
	    { hnode->old_single = NULL;
	      destroy_node(trie, new);
	      destroyHTableWP(hnode->table);
	      free_to_pool(trie->alloc_pool, hnode, sizeof(*hnode));
	      continue;
	    }
	  }
	}
	case TN_HASHED:
	{ trie_node *old = addHTableWP(children.hash->table, key, new);

	  if ( new == old )
	  { new->parent = n;
	    update_var_mask(children.hash, new->key);
	  } else
	  { destroy_node(trie, new);
	  }
	  return old;
	}
	default:
	  assert(0);
      }
    } else
    { trie_children_key *child;

      if ( !(child=alloc_from_pool(trie->alloc_pool, sizeof(*child))) )
      { destroy_node(trie, new);
	return NULL;
      }

      child->type  = TN_KEY;
      child->key   = key;
      child->child = new;

      if ( COMPARE_AND_SWAP_PTR(&n->children.key, NULL, child) )
      { child->child->parent = n;
	return child->child;
      }
      destroy_node(trie, new);
      free_to_pool(trie->alloc_pool, child, sizeof(*child));
    }
  }
}


#define follow_node(trie, n, value, add) LDFUNC(follow_node, trie, n, value, add)
static trie_node *
follow_node(DECL_LD trie *trie, trie_node *n, word value, int add)
{ trie_node *child;

  if ( (child=get_child(n, value)) )
    return child;

  if ( add )
    return insert_child(trie, n, value);
  else
    return NULL;
}


#define trie_intern_indirect(trie, w, add) LDFUNC(trie_intern_indirect, trie, w, add)
static word
trie_intern_indirect(DECL_LD trie *trie, word w, int add)
{ for(;;)
  { if ( trie->indirects )
    { return intern_indirect(trie->indirects, w, add);
    } else if ( add )
    { indirect_table *newtab = new_indirect_table();

      if ( !COMPARE_AND_SWAP_PTR(&trie->indirects, NULL, newtab) )
	destroy_indirect_table(newtab);
    } else
    { return 0;
    }
  }
}


/* If there is an error, we prune the part that we have created.
 * We should only start the prune from a new node though.  To be sure
 * we do so we first add a new node.  As this is for exception handling
 * only, the performance loss is not vital.
 */

#define prune_error(trie, node) LDFUNC(prune_error, trie, node)
static void
prune_error(DECL_LD trie *trie, trie_node *node)
{ prune_node(trie, follow_node(trie, node, TRIE_ERROR_VAL, TRUE));
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Lookup `k` in `trie` and on  success   fill  `nodep`  with the leaf node
under which `k` is represented in the trie.  If `add` is `TRUE`, add `k`
to the trie if it is not already in the true.

`vars` is either NULL or a _buffer_ In the latter case it is filled with
pointers to the variables found  in  `k`.   This  is  used by tabling to
create the `ret` term.

Return:

  - FALSE
    Could not find term while `add` is FALSE or exception
  - TRUE
    Ok (found or inserted)
  - TRIE_ABSTRACTED
    Ok, but abstracted
  - TRIE_LOOKUP_CONTAINS_ATTVAR
  - TRIE_LOOKUP_CYCLIC

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

int
trie_lookup_abstract(DECL_LD trie *trie, trie_node *node, trie_node **nodep,
		     Word k, int add, size_abstract *abstract,
		     TmpBuffer vars)
{ term_agenda_P agenda;
  size_t var_number = 0;
  int rc = TRUE;
  size_t compounds = 0;
  tmp_buffer varb;
  size_abstract sa = {.from_depth = 1, .size = (size_t)-1};
  size_t aleft = (size_t)-1;

  TRIE_STAT_INC(trie, lookups);
  if ( !node )
    node = &trie->root;
  if ( abstract )
    sa = *abstract;

  initTermAgenda_P(&agenda, 1, k);
  while( node )
  { Word p;
    word w;
    size_t popn;

    if ( !(p=nextTermAgenda_P(&agenda)) )
      break;
    if ( (popn = IS_AC_TERM_POP(p)) )
    { compounds -= popn;
      if ( compounds > 0 )
      { if ( !(node = follow_node(trie, node, TRIE_KEY_POP(popn), add)) )
	  break;
	continue;
      } else
	break;				/* finished toplevel */
    }

    if ( compounds == sa.from_depth )
      aleft = sa.size;

    w = *p;
    switch( tag(w) )
    { case TAG_VAR:
	if ( isVar(w) )
	{ word w2;

	add_var:
	  if ( var_number++ == 0 && !vars )
	  { vars = &varb;
	    initBuffer(vars);
	  }
	  addBuffer(vars, p, Word);
	  w2 = ((((word)var_number))<<LMASK_BITS)|TAG_VAR;
	  if ( tag(w) == TAG_VAR )
	    *p = w2;
	  w = w2;
	}
        node = follow_node(trie, node, w, add);
	break;
      case TAG_ATTVAR:
	rc = TRIE_LOOKUP_CONTAINS_ATTVAR;

        prune_error(trie, node);
        node = NULL;
        break;
      case TAG_COMPOUND:
      { if ( unlikely(aleft == 0) )
	{ rc = TRIE_ABSTRACTED;
	  goto add_var;
	} else
	{ Functor f = valueTerm(w);
	  size_t arity = arityFunctor(f->definition);

	  if ( aleft != (size_t)-1 )
	    aleft--;
	  if ( ++compounds == 1000 && add && !is_acyclic(p) )
	  { rc = TRIE_LOOKUP_CYCLIC;
	    prune_error(trie, node);
	    node = NULL;
	  } else
	  { node = follow_node(trie, node, f->definition, add);
	    pushWorkAgenda_P(&agenda, arity, f->arguments);
	  }
	}
	break;
      }
      default:
      { if ( !isIndirect(w) )
	{ node = follow_node(trie, node, w, add);
	} else
	{ word i = trie_intern_indirect(trie, w, add);

	  if ( i )
	    node = follow_node(trie, node, i, add);
	  else
	    node = NULL;
	}
      }
    }
  }
  clearTermAgenda_P(&agenda);

  if ( var_number )
  { Word *pp = baseBuffer(vars, Word);
    Word *ep = topBuffer(vars, Word);

    for(; pp < ep; pp++)
    { Word vp = *pp;
      if ( tag(*vp) == TAG_VAR )
	setVar(*vp);
    }
    if ( vars == &varb )
      discardBuffer(vars);
  }

  if ( rc > 0 )
  { if ( node )
      *nodep = node;
    else
      rc = FALSE;
  }

  return rc;
}


trie *
get_trie_from_node(trie_node *node)
{ trie *trie_ptr;

  for( ; node->parent; node = node->parent )
    ;
  trie_ptr = (trie *)((char*)node - offsetof(trie, root));
  assert(trie_ptr->magic == TRIE_MAGIC || trie_ptr->magic == TRIE_CMAGIC);

  return trie_ptr;
}


int
is_ground_trie_node(trie_node *node)
{ for( ; node->parent; node = node->parent )
  { if ( tagex(node->key) == TAG_VAR )
      return FALSE;
  }

  return TRUE;
}


		 /*******************************
		 *    BUILD TERM FROM PATH	*
		 *******************************/

#if 0					/* debugging help */
static int
print_key(word k)
{ size_t pop;

  if ( (pop = IS_TRIE_KEY_POP(k)) )
  { Sdprintf("POP(%zd)\n", pop);
  } else
  { char buf[64];

    Sdprintf("%s\n", print_val(k, buf));
  }

  return TRUE;
}

static int
print_keys(Word k, size_t kc)
{ size_t i;

  for(i=kc; i-->0; )
    print_key(k[i]);

  return TRUE;
}
#endif


#define MAX_FAST 256

int
unify_trie_term(DECL_LD trie_node *node, trie_node **parent, term_t term)
{ word fast[MAX_FAST];
  Word keys = fast;
  size_t keys_allocated = MAX_FAST;
  size_t kc = 0;
  int rc = TRUE;
  trie *trie_ptr;
  mark m;
  int is_secondary = true(node, TN_SECONDARY);
						/* get the keys */
  for( ; node->parent; node = node->parent )
  { if ( is_secondary && true(node, TN_PRIMARY) )
    { if ( parent )
	*parent = node;
      break;
    }
    if ( kc == keys_allocated )
    { keys_allocated *= 2;
      if ( keys == fast )
      { if ( (keys = malloc(sizeof(*keys)*keys_allocated)) )
	  memcpy(keys, fast, sizeof(fast));
	else
	  return PL_resource_error("memory");
      } else
      { Word newkeys;
	if ( !(newkeys=realloc(keys, sizeof(*keys)*keys_allocated)) )
	{ free(keys);
	  return PL_resource_error("memory");
	}
	keys = newkeys;
      }
    }

    keys[kc++] = node->key;
  }
  for( ; node->parent; node = node->parent )
    ;
  trie_ptr = (trie *)((char*)node - offsetof(trie, root));
  assert(trie_ptr->magic == TRIE_MAGIC);

  for(;;)
  { ukey_state ustate;
    size_t i;

  retry:
    Mark(m);
    init_ukey_state(&ustate, trie_ptr, valTermRef(term));
    for(i=kc; i-- > 0; )
    { if ( (rc=unify_key(&ustate, keys[i])) != TRUE )
      { destroy_ukey_state(&ustate);
	if ( rc == FALSE )
	  goto out;
	Undo(m);
	if ( (rc=makeMoreStackSpace(rc, ALLOW_GC)) )
	  goto retry;
	else
	  goto out;
      }
    }
    destroy_ukey_state(&ustate);
    break;
  }

out:
  if ( keys != fast )
    free(keys);

  return rc;
}


void *
map_trie_node(trie_node *n,
	      void* (*map)(trie_node *n, void *ctx), void *ctx)
{ trie_children children;
  void *rc;

next:
  children = n->children;

  if ( (rc=(*map)(n, ctx)) != NULL )
    return rc;

  if ( children.any  )
  { switch( children.any->type )
    { case TN_KEY:
      { n = children.key->child;
	goto next;
      }
      case TN_HASHED:
      { TableWP table = children.hash->table;
	TableEnum e = newTableEnumWP(table);
	table_value_t v;

	while(advanceTableEnum(e, NULL, &v))
	{ trie_node *n2 = val2ptr(v);

	  if ( (rc=map_trie_node(n2, map, ctx)) != NULL )
	  { freeTableEnum(e);
	    return rc;
	  }
	}

	freeTableEnum(e);
	break;
      }
    }
  }

  return NULL;
}


typedef struct trie_stats
{ size_t bytes;
  size_t nodes;
  size_t hashes;
  size_t values;
} trie_stats;


static void *
stat_node(trie_node *n, void *ctx)
{ trie_stats *stats = ctx;
  trie_children children = n->children;

  stats->nodes++;
  stats->bytes += sizeof(*n);
  if ( n->value && true(n, TN_PRIMARY) )
    stats->values++;

  if ( children.any )
  { switch( children.any->type )
    { case TN_KEY:
	stats->bytes += sizeof(*children.key);
        break;
      case TN_HASHED:
	stats->bytes += sizeofTableWP(children.hash->table);
	stats->hashes++;
	break;
      default:
	assert(0);
    }
  }

  return NULL;
}


static void
stat_trie(trie *t, trie_stats *stats)
{ stats->bytes  = sizeof(*t) - sizeof(t->root);
  stats->nodes  = 0;
  stats->hashes = 0;
  stats->values = 0;

  acquire_trie(t);
  map_trie_node(&t->root, stat_node, stats);
  release_trie(t);
}




		 /*******************************
		 *	  PROLOG BINDING	*
		 *******************************/

atom_t
trie_symbol(trie *trie)
{ if ( !trie->symbol )
  { tref ref;
    int new;

    ref.trie = trie;
    trie->symbol = lookupBlob((void*)&ref, sizeof(ref),
			      &trie_blob, &new);
  }

  return trie->symbol;
}


trie *
symbol_trie(atom_t symbol)
{ void *data;
  PL_blob_t *type;

  if ( (data = PL_blob_data(symbol, NULL, &type)) && type == &trie_blob )
  { tref *ref = data;

    if ( ref->trie->magic == TRIE_MAGIC )
      return ref->trie;
  }

  return NULL;
}



#define unify_trie(t, trie) LDFUNC(unify_trie, t, trie)
static int
unify_trie(DECL_LD term_t t, trie *trie)
{ return PL_unify_atom(t, trie->symbol);
}

int
get_trie(term_t t, trie **tp)
{ void *data;
  PL_blob_t *type;

  if ( PL_get_blob(t, &data, NULL, &type) && type == &trie_blob )
  { tref *ref = data;

    if ( ref->trie->magic == TRIE_MAGIC )
    { *tp = ref->trie;
      return TRUE;
    }

    PL_existence_error("trie", t);
  } else
    PL_type_error("trie", t);

  return FALSE;
}


int
get_trie_noex(term_t t, trie **tp)
{ void *data;
  PL_blob_t *type;

  if ( PL_get_blob(t, &data, NULL, &type) && type == &trie_blob )
  { tref *ref = data;

    *tp = ref->trie;
    return TRUE;
  }

  return FALSE;
}


int
trie_error(int rc, term_t culprit)
{ switch(rc)
  { case TRIE_LOOKUP_CONTAINS_ATTVAR:
      return PL_type_error("free_of_attvar", culprit);
    case TRIE_LOOKUP_CYCLIC:
      return PL_type_error("acyclic_term", culprit);
    default:
      return FALSE;
  }
}

int
trie_trie_error(int rc, trie *trie)
{ GET_LD
  term_t t;

  return ( (t= PL_new_term_ref()) &&
	   PL_put_atom(t, trie->symbol) &&
	   trie_error(rc, t) );
}


static
PRED_IMPL("trie_new", 1, trie_new, 0)
{ PRED_LD
  trie *trie;

  if ( (trie = trie_create(NULL)) )
  { atom_t symbol = trie_symbol(trie);
    int rc;

    rc = unify_trie(A1, trie);
    PL_unregister_atom(symbol);

    return rc;
  }

  return FALSE;
}


static
PRED_IMPL("is_trie", 1, is_trie, 0)
{ void *data;
  PL_blob_t *type;

  if ( PL_get_blob(A1, &data, NULL, &type) && type == &trie_blob )
  { tref *ref = data;

    if ( ref->trie->magic == TRIE_MAGIC )
      return TRUE;
  }

  return FALSE;
}


static
PRED_IMPL("trie_destroy", 1, trie_destroy, 0)
{ trie *trie;

  if ( get_trie(A1, &trie) )
  { trie->magic = TRIE_CMAGIC;
    trie_empty(trie);

    return TRUE;
  }

  return FALSE;
}


#define isRecord(w) (((w)&0x3) == 0)

#define intern_value(value) LDFUNC(intern_value, value)
static word
intern_value(DECL_LD term_t value)
{ if ( value )
  { Word vp = valTermRef(value);

    DEBUG(0, assert((TAG_INTEGER&0x3) && (TAG_ATOM&0x3)));

    deRef(vp);
    if ( isAtom(*vp) || isTaggedInt(*vp) )
      return *vp;

    return ptr2word(PL_record(value));
  } else
  { return ATOM_trienode;
  }
}


static inline void
release_value(word value)
{ if ( isAtom(value) )
    PL_unregister_atom(word2atom(value));
  else if ( isRecord(value) )
    PL_erase(word2ptr(record_t, value));
}


static int
equal_value(word v1, word v2)
{ if ( v1 == v2 )
    return TRUE;

  if ( isRecord(v1) && isRecord(v2) )
    return variantRecords(word2ptr(record_t, v1), word2ptr(record_t, v2));

  return FALSE;
}


#define unify_value(t, value) LDFUNC(unify_value, t, value)
static int
unify_value(DECL_LD term_t t, word value)
{ if ( !isRecord(value) )
  { return PL_unify_atomic(t, value);
  } else
  { term_t t2;

    return ( (t2=PL_new_term_ref()) &&
	     PL_recorded(word2ptr(record_t, value), t2) &&
	     PL_unify(t, t2)
	   );
  }
}


int
put_trie_value(DECL_LD term_t t, trie_node *node)
{ if ( !isRecord(node->value) )
  { *valTermRef(t) = node->value;
    return TRUE;
  } else
  { return PL_recorded(word2ptr(record_t, node->value), t);
  }
}


int
set_trie_value_word(trie *trie, trie_node *node, word val)
{ if ( node->value )
  { if ( !equal_value(node->value, val) )
    { word old = node->value;

      acquire_key(val);
      node->value = val;
      set(node, TN_PRIMARY);
      release_value(old);
      trie_discard_clause(trie);

      return TRUE;
    } else
    { return FALSE;
    }
  } else
  { acquire_key(val);
    node->value = val;
    set(node, TN_PRIMARY);
    ATOMIC_INC(&trie->value_count);
    trie_discard_clause(trie);

    return TRUE;
  }
}

int
set_trie_value(DECL_LD trie *trie, trie_node *node, term_t value)
{ word val = intern_value(value);

  if ( !set_trie_value_word(trie, node, val) &&
       isRecord(val) )
    PL_erase(word2ptr(record_t, val));

  return TRUE;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Delete a node from the trie. There are   two options: (1) simply set the
value to 0 or (2), prune the branch   leading to this cell upwards until
we find another existing node.

TBD: create some sort of  lingering   mechanism  to allow for concurrent
delete and gen_trie(). More modest: link up the deleted nodes and remove
them after the references drop to 0.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

void
trie_delete(trie *trie, trie_node *node, int prune)
{ if ( node->value )
  { if ( true(node, TN_PRIMARY) )
      ATOMIC_DEC(&trie->value_count);

    clear(node, (TN_PRIMARY|TN_SECONDARY));
    if ( prune && trie->references == 0 )
    { prune_node(trie, node);
    } else
    { word v;

      if ( trie->release_node )
	(*trie->release_node)(trie, node);

      if ( (v=node->value) )
      { node->value = 0;
	release_value(v);
      }
    }
    trie_discard_clause(trie);
  }
}


/**
 * trie_insert(+Trie, +Key, +Value) is semidet.
 *
 * True if Key was added as a new   key  to the trie and associated with
 * Value. False if Key was already in the trie with Value
 *
 * @error permission_error if Key was associated with a different value
 */

#define trie_insert(Trie, Key, Value, nodep, update, abstract) LDFUNC(trie_insert, Trie, Key, Value, nodep, update, abstract)
static int
trie_insert(DECL_LD term_t Trie, term_t Key, term_t Value, trie_node **nodep,
	    int update, size_abstract *abstract)
{ trie *trie;

  if ( get_trie(Trie, &trie) )
  { Word kp;
    trie_node *node;
    int rc;

    if ( false(trie, TRIE_ISMAP|TRIE_ISSET) )
    { if ( Value )
	set(trie, TRIE_ISMAP);
      else
	set(trie, TRIE_ISSET);
    } else
    { if ( (Value  && false(trie, TRIE_ISMAP)) ||
	   (!Value && false(trie, TRIE_ISSET)) )
      { return PL_permission_error("insert", "trie", Trie);
      }
    }

    kp	= valTermRef(Key);

    if ( (rc=trie_lookup_abstract(trie, NULL, &node, kp,
				  TRUE, abstract, NULL)) == TRUE )
    { word val = intern_value(Value);

      if ( nodep )
	*nodep = node;

      if ( node->value )
      { if ( update )
	{ if ( !equal_value(node->value, val) )
	  { word old = node->value;

	    acquire_key(val);
	    node->value = val;
	    set(node, TN_PRIMARY);
	    release_value(old);
	    trie_discard_clause(trie);
	  } else if ( isRecord(val) )
	  { PL_erase(word2ptr(record_t, val));
	  }

	  return TRUE;
	} else
	{ if ( !equal_value(node->value, val) )
	    PL_permission_error("modify", "trie_key", Key);
	  if ( isRecord(val) )
	    PL_erase(word2ptr(record_t, val));

	  return FALSE;
	}
      }
      acquire_key(val);
      node->value = val;
      set(node, TN_PRIMARY);
      ATOMIC_INC(&trie->value_count);
      trie_discard_clause(trie);

      return TRUE;
    }

    return trie_error(rc, Key);
  }

  return FALSE;
}


/**
 * trie_insert(+Trie, +Key, +Value) is semidet.
 *
 * True if Key was added as a new   key  to the trie and associated with
 * Value. False if Key was already in the trie with Value
 *
 * @error permission_error if Key was associated with a different value
 */

static
PRED_IMPL("trie_insert", 3, trie_insert, 0)
{ PRED_LD

  return trie_insert(A1, A2, A3, NULL, FALSE, NULL);
}

/**
 * trie_insert(+Trie, +Key) is semidet.
 *
 * True if Key was added as a new key to the trie.  False if Key was
 * already in the trie.
 *
 * @error permission_error if Key was associated with a different value
 */

static
PRED_IMPL("trie_insert", 2, trie_insert, 0)
{ PRED_LD

  return trie_insert(A1, A2, 0, NULL, FALSE, NULL);
}


/**
 * trie_insert_abstract(+Trie, +Size, +Key) is semidet.
 *
 * Insert size-abstracted version of Key
 */

static
PRED_IMPL("$trie_insert_abstract", 3, trie_insert_abstract, 0)
{ PRED_LD
  size_abstract sa = {.from_depth = 1};

  return ( PL_get_size_ex(A2, &sa.size ) &&
	   trie_insert(A1, A3, 0, NULL, FALSE, &sa) > 0 );
}


/**
 * trie_update(+Trie, +Key, +Value) is semidet.
 *
 * Similar to trie_insert/3, but updates the associated value rather
 * then failing or raising an error.
 *
 * @error permission_error if Key was associated with a different value
 */

static
PRED_IMPL("trie_update", 3, trie_update, 0)
{ PRED_LD

  return trie_insert(A1, A2, A3, NULL, TRUE, NULL);
}


/**
 * trie_insert(+Trie, +Term, +Value, -Handle) is semidet.
 *
 * Add Term to Trie and unify Handle with a handle to the term.
 * Fails if Term is already in Trie.
 *
 * @bug Handle is currently a pointer.  In future versions we will
 * use a dynamic array for the trie nodes and return an integer to
 * guarantee safe lookup.
 */

static
PRED_IMPL("trie_insert", 4, trie_insert, 0)
{ PRED_LD
  trie_node *node;

  return ( trie_insert(A1, A2, A3, &node, FALSE, NULL) &&
	   PL_unify_pointer(A4, node) );
}


static
PRED_IMPL("trie_delete", 3, trie_delete, 0)
{ PRED_LD
  trie *trie;

  if ( get_trie(A1, &trie) )
  { Word kp;
    trie_node *node;
    int rc;

    kp = valTermRef(A2);

    if ( (rc=trie_lookup(trie, NULL, &node, kp, FALSE, NULL)) == TRUE )
    { if ( node->value )
      { if ( unify_value(A3, node->value) )
	{ trie_delete(trie, node, TRUE);
	  return TRUE;
	}
      }
      return FALSE;
    }

    return trie_error(rc, A2);
  }

  return FALSE;
}


static
PRED_IMPL("trie_lookup", 3, trie_lookup, 0)
{ PRED_LD
  trie *trie;

  if ( get_trie(A1, &trie) )
  { Word kp;
    trie_node *node;
    int rc;

    kp = valTermRef(A2);

    if ( (rc=trie_lookup(trie, NULL, &node, kp, FALSE, NULL)) == TRUE )
    { if ( node->value )
	return unify_value(A3, node->value);
      return FALSE;
    }

    return trie_error(rc, A2);
  }

  return FALSE;
}


/**
 * trie_term(+Handle, -Term) is det.
 *
 * Retrieve a term for a handle returned by trie_insert/4.
 */

static
PRED_IMPL("trie_term", 2, trie_term, 0)
{ PRED_LD
  void *ptr;

  return ( PL_get_pointer_ex(A1, &ptr) &&
	   unify_trie_term(ptr, NULL, A2)
	 );
}


/**
 * trie_gen(+Trie, ?Key, -Value) is nondet.
 *
 * True when Key-Value appears in Trie.
 *
 * This needs to keep  a  list  of   choice  points  for  each node with
 * multiple children. Eventually, this is probably going to be a virtual
 * machine extension, using real choice points.
 */

static void
init_ukey_state(DECL_LD ukey_state *state, trie *trie, Word p)
{ state->trie = trie;
  state->ptr  = p;
  state->umode = uread;
  state->max_var_seen = 0;
  state->a_offset = aTop-aBase;
}

static void
destroy_ukey_state(DECL_LD ukey_state *state)
{ if ( state->max_var_seen && state->vars != state->var_buf )
    PL_free(state->vars);
  aTop = aBase + state->a_offset;
}

static Word*
find_var(ukey_state *state, size_t index)
{ if ( index > state->max_var_seen )
  { assert(index == state->max_var_seen+1);

    if ( !state->max_var_seen )
    { state->vars_allocated = NVARS_FAST;
      state->vars = state->var_buf;
    } else if ( index >= state->vars_allocated )
    { if ( state->vars == state->var_buf )
      { state->vars = PL_malloc(sizeof(*state->vars)*NVARS_FAST*2);
	memcpy(state->vars, state->var_buf, sizeof(*state->vars)*NVARS_FAST);
      } else
      { state->vars = PL_realloc(state->vars,
				 sizeof(*state->vars)*state->vars_allocated*2);
      }
      state->vars_allocated *= 2;
    }
    state->vars[index] = NULL;
    state->max_var_seen = index;
  }

  return &state->vars[index];
}


static int
unify_key(DECL_LD ukey_state *state, word key)
{ Word p = state->ptr;

  switch(tagex(key))
  { case TAG_VAR|STG_LOCAL:			/* RESERVED_TRIE_VAL */
    { size_t popn = IS_TRIE_KEY_POP(key);
      Word wp;

      assert(popn);
      aTop -= popn;
      wp = *aTop;
      state->umode = ((int)(uintptr_t)wp & uwrite);
      state->ptr   = (Word)((intptr_t)wp&~uwrite);

      DEBUG(MSG_TRIE_PUT_TERM,
	    Sdprintf("U Popped(%zd) %zd, mode=%d\n",
		     popn, state->ptr-gBase, state->umode));
      return TRUE;
    }
    case TAG_ATOM|STG_GLOBAL:			/* functor */
    { size_t arity = arityFunctor(key);

      DEBUG(MSG_TRIE_PUT_TERM,
	    Sdprintf("U Pushed %s %zd, mode=%d\n",
		     functorName(word2functor(key)), state->ptr+1-gBase, state->umode));
      pushArgumentStack((Word)((intptr_t)(p + 1)|state->umode));

      if ( state->umode == uwrite )
      { Word t;

	if ( (t=allocGlobalNoShift(arity+1)) )
	{ t[0] = key;
	  *p = consPtr(t, TAG_COMPOUND|STG_GLOBAL);
	  state->ptr = &t[1];
	  return TRUE;
	} else
	  return GLOBAL_OVERFLOW;
      } else
      { deRef(p);

	if ( canBind(*p) )
	{ state->umode = uwrite;

	  if ( isAttVar(*p) )
	  { Word t;
	    word w;
	    size_t i;

	    if ( (t=allocGlobalNoShift(arity+1)) )
	    { if ( !hasGlobalSpace(0) )
		return overflowCode(0);
	      w = consPtr(&t[0], TAG_COMPOUND|STG_GLOBAL);
	      t[0] = key;
	      for(i=0; i<arity; i++)
		setVar(t[i+1]);
	      assignAttVar(p, &w);
	      state->ptr = &t[1];
	      return TRUE;
	    } else
	      return GLOBAL_OVERFLOW;
	  } else
	  { Word t;
	    size_t i;

	    if ( (t=allocGlobalNoShift(arity+1)) )
	    { if ( unlikely(tTop+1 >= tMax) )
		return  TRAIL_OVERFLOW;
	      t[0] = key;
	      for(i=0; i<arity; i++)
		setVar(t[i+1]);
	      Trail(p, consPtr(t, TAG_COMPOUND|STG_GLOBAL));
	      state->ptr = &t[1];
	      return TRUE;
	    } else
	      return GLOBAL_OVERFLOW;
	  }
	} else if ( isTerm(*p) )
	{ Functor f = valueTerm(*p);

	  if ( f->definition == key )
	  { state->ptr = &f->arguments[0];
	    return TRUE;
	  } else
	    return FALSE;
	} else
	{ return FALSE;
	}
      } /*uread*/
    }
    assert(0);
    case TAG_VAR:
    { size_t index = (size_t)(key>>LMASK_BITS);
      Word *v = find_var(state, index);

      DEBUG(MSG_TRIE_PUT_TERM,
	    { char b1[64]; char b2[64];
	      Sdprintf("var %zd at %s (v=%p, *v=%s)\n",
		       index,
		       print_addr(state->ptr,b1),
		       v, print_addr(*v,b2));
	    });

      if ( state->umode == uwrite )
      { if ( !*v )
	{ setVar(*state->ptr);
	  *v = state->ptr;
	} else
	{ *state->ptr = makeRefG(*v);
	}
      } else
      { deRef(p);

	if ( !*v )
	{ *v = state->ptr;
	} else
	{ int rc;

	  if ( (rc=unify_ptrs(state->ptr, *v, ALLOW_RETCODE)) != TRUE )
	    return rc;
	}
      }

      break;
    }
    assert(0);
    case STG_GLOBAL|TAG_INTEGER:		/* indirect data */
    case STG_GLOBAL|TAG_STRING:
    case STG_GLOBAL|TAG_FLOAT:
    { word w;

      w = extern_indirect_no_shift(state->trie->indirects, key);
      if ( !w )
	return GLOBAL_OVERFLOW;

      if ( state->umode == uwrite )
      { *p = w;
      } else
      { deRef(p);

	if ( canBind(*p) )
	{ if ( hasGlobalSpace(0) )
	    bindConst(p, w);
	  else
	    return overflowCode(0);
	} else if ( tag(w) == tag(*p) && isIndirect(*p) )
	{ if ( !equalIndirect(w, *p) )
	    return FALSE;
	} else
	{ return FALSE;
	}
      }

      break;
    }
    case TAG_ATOM:
      pushVolatileAtom(word2atom(key));
      /*FALLTHROUGH*/
    case TAG_INTEGER:
    { if ( state->umode == uwrite )
      { *p = key;
      } else
      { deRef(p);

	if ( canBind(*p) )
	{ if ( hasGlobalSpace(0) )
	    bindConst(p, key);
	  else
	    return overflowCode(0);
	} else
	{ if ( *p != key )
	    return FALSE;
	}
      }
      break;
    }
    default:
      assert(0);
  }

  state->ptr++;

  return TRUE;
}


typedef struct trie_choice
{ TableEnum  table_enum;
  TableWP    table;
  unsigned   var_mask;
  unsigned   var_index;
  word       novar;
  word       key;
  trie_node *child;
} trie_choice;

typedef struct
{ trie	      *trie;		/* trie we operate on */
  int	       allocated;	/* If TRUE, the state is persistent */
  unsigned     vflags;		/* TN_PRIMARY or TN_SECONDARY */
  tmp_buffer   choicepoints;	/* Stack of trie state choicepoints */
} trie_gen_state;

typedef struct desc_tstate
{ Word  term;
  size_t size;
} desc_tstate;

typedef struct
{ Word	       term;		/* Term we are descending */
  size_t       size;		/* Size of the current node */
  int	       compound;	/* Initialized for compound */
  int	       prune;		/* Use for pruning */
  segstack     stack;		/* Stack for argument handling */
  desc_tstate  buffer[64];	/* Quick buffer for stack */
} descent_state;

#define advance_node(ch) LDFUNC(advance_node, ch)
static int	advance_node(DECL_LD trie_choice *ch);

static void
init_trie_state(trie_gen_state *state, trie *trie, const trie_node *root)
{ state->trie = trie;
  state->allocated = FALSE;
  state->vflags = root == &trie->root ? TN_PRIMARY : TN_SECONDARY;
  initBuffer(&state->choicepoints);
}


#define base_choice(state) baseBuffer(&state->choicepoints, trie_choice)
#define top_choice(state) topBuffer(&state->choicepoints, trie_choice)


static void
clear_trie_state(trie_gen_state *state)
{ trie_choice *chp = base_choice(state);
  trie_choice *top = top_choice(state);

  for(; chp < top; chp++)
  { if ( chp->table_enum )
      freeTableEnum(chp->table_enum);
  }

  discardBuffer(&state->choicepoints);

  release_trie(state->trie);

  if ( state->allocated )
    freeForeignState(state, sizeof(*state));
}

foreign_t
clear_trie_gen_state(void *ctx)
{ trie_gen_state *state = ctx;

  clear_trie_state(state);
  return TRUE;
}

static void
clear_descent_state(descent_state *dstate)
{ if ( dstate->compound )
    clearSegStack(&dstate->stack);
}

#define get_key(state, dstate, key) LDFUNC(get_key, state, dstate, key)
static int
get_key(DECL_LD trie_gen_state *state, descent_state *dstate, word *key)
{ Word p;

  if ( dstate->size == 0 )
  { *key = TRIE_KEY_POP(0);
    return TRUE;
  }

  deRef2(dstate->term, p);
  DEBUG(CHK_SECURE, checkData(p));

  if ( canBind(*p) )
  { return FALSE;
  } else if ( isTerm(*p) )
  { Functor f = valueTerm(*p);
    desc_tstate dts;

    DEBUG(MSG_TRIE_GEN,
	  Sdprintf("get_key() for %s\n", functorName(word2functor(f->definition))));

    *key = f->definition;
    if ( dstate->size > 1 )
    { if ( !dstate->compound )
      { dstate->compound = TRUE;
	initSegStack(&dstate->stack, sizeof(desc_tstate),
		     sizeof(dstate->buffer), dstate->buffer);
      }
      dts.term = dstate->term+1;
      dts.size = dstate->size-1;
      if ( !pushSegStack(&dstate->stack, dts, desc_tstate) )
	outOfCore();
      DEBUG(MSG_TRIE_GEN,
	    Sdprintf("Pushed %p, size %zd\n", dts.term, dts.size));
    }
    dstate->term = &f->arguments[0];
    dstate->size = arityFunctor(f->definition);
    return TRUE;
  } else
  { dstate->term++;
    dstate->size--;

    if ( isIndirect(*p) )
    { *key = trie_intern_indirect(state->trie, *p, FALSE);
      return *key != 0;
    } else
    { *key = *p;
      return TRUE;
    }
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Walk a step down the trie, adding  a   node  to the choice stack. If the
term we are walking is instantiated and   the trie node does not contain
variables we walk deterministically. Once we have a variable in the term
we unify against or find a variable in  the trie dstate->prune is set to
FALSE, indicating we must create a real choice.

If a known input value is matched against   a  trie choice node and this
node contains variables we create a choice   from the value and variable
mask such that  we  perform  a  couple   of  hash  lookups  rather  than
enumerating the entire table.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define add_choice(state, dstate, node) LDFUNC(add_choice, state, dstate, node)
static trie_choice *
add_choice(DECL_LD trie_gen_state *state, descent_state *dstate, trie_node *node)
{ trie_children children = node->children;
  trie_choice *ch;
  int has_key;
  word k=0;

  if ( dstate->prune )
  { DEBUG(MSG_TRIE_GEN,
	  if ( dstate->size > 0 )
	  { Word p;
	    deRef2(dstate->term, p);
	    Sdprintf("add_choice() for %s\n", print_val(*p, NULL));
	  });
    if ( !(has_key = get_key(state, dstate, &k)) )
      dstate->prune = FALSE;
  } else
    has_key = FALSE;

  if ( children.any && false(node, state->vflags) )
  { switch( children.any->type )
    { case TN_KEY:
	if ( !has_key ||
	     k == children.key->key ||
	     tagex(children.key->key) == TAG_VAR ||
	     IS_TRIE_KEY_POP(children.key->key) )
	{ word key = children.key->key;

	  if ( tagex(children.key->key) == TAG_VAR )
	    dstate->prune = FALSE;

	  ch = allocFromBuffer(&state->choicepoints, sizeof(*ch));
	  ch->key        = key;
	  ch->child      = children.key->child;
	  ch->table_enum = NULL;
	  ch->table      = NULL;

	  if ( IS_TRIE_KEY_POP(children.key->key) && dstate->compound )
	  { desc_tstate dts;
	    popSegStack(&dstate->stack, &dts, desc_tstate);
	    dstate->term = dts.term;
	    dstate->size = dts.size;
	    DEBUG(MSG_TRIE_GEN,
		  Sdprintf("Popped %p, left %zd\n", dstate->term, dstate->size));
	  }
	  break;
	} else
	{ DEBUG(MSG_TRIE_GEN, Sdprintf("Failed\n"));
	  return NULL;
	}
      case TN_HASHED:
      { if ( has_key )
	{ if ( children.hash->var_mask == 0 )
	  { trie_node *child;

	    if ( (child = lookupHTableWP(children.hash->table, k)) )
	    { ch = allocFromBuffer(&state->choicepoints, sizeof(*ch));
	      ch->key        = k;
	      ch->child	     = child;
	      ch->table_enum = NULL;
	      ch->table      = NULL;

	      return ch;
	    } else
	      return NULL;
	  } else if ( children.hash->var_mask != VMASK_SCAN )
	  { dstate->prune = FALSE;

	    DEBUG(MSG_TRIE_GEN,
		  Sdprintf("Created var choice 0x%x\n", children.hash->var_mask));

	    ch = allocFromBuffer(&state->choicepoints, sizeof(*ch));
	    ch->table_enum = NULL;
	    ch->table      = children.hash->table;
	    ch->var_mask   = children.hash->var_mask;
	    ch->var_index  = 1;
	    ch->novar      = k;
	    if ( advance_node(ch) )
	    { return ch;
	    } else
	    { state->choicepoints.top = (char*)ch;
	      ch--;
	      return NULL;
	    }
	  }
	}
					/* general enumeration */
	dstate->prune = FALSE;
	ch = allocFromBuffer(&state->choicepoints, sizeof(*ch));
	ch->table = NULL;
	ch->table_enum = newTableEnumWP(children.hash->table);
	table_key_t tk;
	table_value_t tv;
	advanceTableEnum(ch->table_enum, &tk, &tv);
	ch->key   = tk;
	ch->child = val2ptr(tv);
	break;
      }
      default:
	assert(0);
        return NULL;
    }
  } else
  { ch = allocFromBuffer(&state->choicepoints, sizeof(*ch));
    memset(ch, 0, sizeof(*ch));
    ch->child = node;
  }

  return ch;
}


#define descent_node(state, dstate, ch) LDFUNC(descent_node, state, dstate, ch)
static trie_choice *
descent_node(DECL_LD trie_gen_state *state, descent_state *dstate, trie_choice *ch)
{ while( ch && ch->child->children.any &&
	 false(ch->child, state->vflags) )
  { ch = add_choice(state, dstate, ch->child);
  }

  return ch;
}


static int
advance_node(DECL_LD trie_choice *ch)
{ if ( ch->table_enum )
  { table_key_t k;
    table_value_t v;

    if ( advanceTableEnum(ch->table_enum, &k, &v) )
    { ch->key   = k;
      ch->child = val2ptr(v);

      return TRUE;
    }
  } else if ( ch->table )
  { if ( ch->novar )
    { if ( (ch->child=lookupHTableWP(ch->table, ch->novar)) )
      { ch->key = ch->novar;
	ch->novar = 0;
	return TRUE;
      }
    }
    for( ; ch->var_index && ch->var_index < VMASKBITS; ch->var_index++ )
    { if ( (ch->var_mask & (0x1<<(ch->var_index-1))) )
      { word key = ((((word)ch->var_index))<<LMASK_BITS)|TAG_VAR;

	if ( (ch->child=lookupHTableWP(ch->table, key)) )
	{ ch->key = key;
	  ch->var_index++;
	  return TRUE;
	}
      }
    }
  }

  return FALSE;
}


#define next_choice0(state, dstate) LDFUNC(next_choice0, state, dstate)
static trie_choice *
next_choice0(DECL_LD trie_gen_state *state, descent_state *dstate)
{ trie_choice *btm = base_choice(state);
  trie_choice  *ch = top_choice(state)-1;

  while(ch >= btm)
  { if ( advance_node(ch) )
      return descent_node(state, dstate, ch);

    if ( ch->table_enum )
      freeTableEnum(ch->table_enum);

    state->choicepoints.top = (char*)ch;
    ch--;
  }

  return NULL;
}


#define next_choice(state) LDFUNC(next_choice, state)
static trie_choice *
next_choice(DECL_LD trie_gen_state *state)
{ trie_choice *ch;
  descent_state dstate;

  dstate.prune    = FALSE;
  dstate.compound = FALSE;

  do
  { ch = next_choice0(state, &dstate);
  } while (ch && false(ch->child, state->vflags));

  return ch;
}


static trie_node *
gen_state_leaf(trie_gen_state *state)
{ trie_choice *top = top_choice(state);

  return top[-1].child;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Unify term with the term represented a trie path (list of trie_choice).
Returns one of TRUE, FALSE or *_OVERFLOW.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define unify_trie_path(term, tn, gstate) LDFUNC(unify_trie_path, term, tn, gstate)
static int
unify_trie_path(DECL_LD term_t term, trie_node **tn, trie_gen_state *gstate)
{ ukey_state ustate;
  trie_choice *ch = base_choice(gstate);
  trie_choice *top = top_choice(gstate);

  init_ukey_state(&ustate, gstate->trie, valTermRef(term));
  for( ; ch < top; ch++ )
  { int rc;

    if ( (rc=unify_key(&ustate, ch->key)) != TRUE )
    { destroy_ukey_state(&ustate);
      return rc;
    }
  }

  destroy_ukey_state(&ustate);
  *tn = ch[-1].child;

  return TRUE;
}


foreign_t
trie_gen_raw(trie *trie, trie_node *root, term_t Key, term_t Value,
	     term_t Data, int LDFUNCP (*unify_data)(DECL_LD term_t, trie_node*, void *ctx),
	     void *ctx, control_t PL__ctx)
{ PRED_LD
  trie_gen_state state_buf;
  trie_gen_state *state;
  trie_node *n;

  switch( CTX_CNTRL )
  { case FRG_FIRST_CALL:
    { trie_choice *ch;
      descent_state dstate;
      int rc;

      TRIE_STAT_INC(trie, gen_call);

      dstate.term     = valTermRef(Key);
      dstate.size     = 1;
      dstate.compound = FALSE;
      dstate.prune	  = TRUE;
      deRef(dstate.term);

      acquire_trie(trie);
      state = &state_buf;
      init_trie_state(state, trie, root);
      rc = ( (ch = add_choice(state, &dstate, root)) &&
	     (ch = descent_node(state, &dstate, ch)) &&
	     (true(ch->child, state->vflags) || next_choice(state)) );
      clear_descent_state(&dstate);
      if ( !rc )
      { clear_trie_state(state);
	return FALSE;
      }
      break;
    }
    case FRG_REDO:
      state = CTX_PTR;
      if ( true(gen_state_leaf(state), state->vflags) ||
	   next_choice(state) )		/* pending choice was deleted */
      { break;
      } else
      { clear_trie_state(state);
	return FALSE;
      }
    case FRG_CUTTED:
      state = CTX_PTR;
      clear_trie_state(state);
      return TRUE;
    default:
      assert(0);
      return FALSE;
  }

  Mark(fli_context->mark);
  for( ; !isEmptyBuffer(&state->choicepoints); next_choice(state) )
  { for(;;)
    { int rc;
      size_t asize = aTop - aBase; /* using the argument stack may be dubious */

      if ( (rc=unify_trie_path(Key, &n, state)) == TRUE )
	break;

      aTop = aBase+asize;
      Undo(fli_context->mark);
      if ( rc == FALSE )
	goto next;

      if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
	continue;

      clear_trie_state(state);
      return FALSE;				/* resource error */
    }

    DEBUG(CHK_SECURE, PL_check_data(Key));

    if ( (!Value || unify_value(Value, n->value)) &&
	 (!Data  || LDFUNCP(*unify_data)(Data, n, ctx)) )
    { if ( next_choice(state) )
      { if ( !state->allocated )
	{ trie_gen_state *nstate = allocForeignState(sizeof(*state));
	  TmpBuffer nchp = &nstate->choicepoints;
	  TmpBuffer ochp = &state->choicepoints;

	  nstate->trie = state->trie;
	  nstate->vflags = state->vflags;
	  nstate->allocated = TRUE;
	  if ( ochp->base == ochp->static_buffer )
	  { size_t bytes = ochp->top - ochp->base;
	    initBuffer(nchp);
	    nchp->top  = nchp->base + bytes;
	    memcpy(nchp->base, ochp->base, bytes);
	  } else
	  { nchp->base = ochp->base;
	    nchp->top  = ochp->top;
	    nchp->max  = ochp->max;
	  }

	  state = nstate;
	}
	ForeignRedoPtr(state);
      } else
      { clear_trie_state(state);
	return TRUE;
      }
    } else
    { Undo(fli_context->mark);
    }

next:;
  }

  clear_trie_state(state);
  return FALSE;
}


foreign_t
trie_gen(term_t Trie, term_t Root, term_t Key, term_t Value,
	 term_t Data, int LDFUNCP (*unify_data)(DECL_LD term_t, trie_node*, void *ctx),
	 void *ctx, control_t PL__ctx)
{ if ( CTX_CNTRL == FRG_FIRST_CALL )
  { trie *trie;
    trie_node *root;

    if ( get_trie(Trie, &trie) )
    { if ( Root )
      { void *ptr;

	if ( !PL_get_pointer_ex(Root, &ptr) )
	  return FALSE;
	root = ptr;
      } else
      { root = &trie->root;
      }

      if ( root->children.any )
	return trie_gen_raw(trie, root, Key, Value, Data,
			    unify_data, ctx, PL__ctx);
    }

    return FALSE;
  } else
  { return trie_gen_raw(NULL, NULL, Key, Value, Data,
			unify_data, ctx, PL__ctx);
  }
}

static
PRED_IMPL("trie_gen", 3, trie_gen, PL_FA_NONDETERMINISTIC)
{ return trie_gen(A1, 0, A2, A3, 0, NULL, NULL, PL__ctx);
}

static
PRED_IMPL("trie_gen", 2, trie_gen, PL_FA_NONDETERMINISTIC)
{ return trie_gen(A1, 0, A2, 0, 0, NULL, NULL, PL__ctx);
}

#define unify_node_id(t, answer, ctx) LDFUNC(unify_node_id, t, answer, ctx)
static int
unify_node_id(DECL_LD term_t t, trie_node *answer, void *ctx)
{ (void) ctx;

  return PL_unify_pointer(t, answer);
}

static
PRED_IMPL("$trie_gen_node", 3, trie_gen_node, PL_FA_NONDETERMINISTIC)
{ return trie_gen(A1, 0, A2, 0, A3, LDFUNC_REF(unify_node_id), NULL, PL__ctx);
}



static
PRED_IMPL("$trie_property", 2, trie_property, 0)
{ PRED_LD
  trie *trie;

#ifdef O_TRIE_STATS
  static atom_t ATOM_lookup_count = 0;
  static atom_t ATOM_gen_call_count = 0;
  static atom_t ATOM_invalidated = 0;
  static atom_t ATOM_reevaluated = 0;

  if ( !ATOM_lookup_count )
  { ATOM_lookup_count   = PL_new_atom("lookup_count");
    ATOM_gen_call_count = PL_new_atom("gen_call_count");
    ATOM_invalidated    = PL_new_atom("invalidated");
    ATOM_reevaluated    = PL_new_atom("reevaluated");
  }
#endif

  if ( get_trie(A1, &trie) )
  { atom_t name; size_t arity;
    idg_node *idg;

    if ( PL_get_name_arity(A2, &name, &arity) && arity == 1 )
    { term_t arg = PL_new_term_ref();

      _PL_get_arg(1, A2, arg);

      if ( name == ATOM_node_count )
      { return PL_unify_integer(arg, trie->node_count);
      } else if ( name == ATOM_value_count )
      { return PL_unify_integer(arg, trie->value_count);
      } else if ( name == ATOM_size )
      { trie_stats stats;
	stat_trie(trie, &stats);
	if ( stats.nodes != trie->node_count )
	  Sdprintf("OOPS: trie_property/2: counted %zd nodes, admin says %zd\n",
		   (size_t)stats.nodes, (size_t)trie->node_count);
	if ( stats.values != trie->value_count )
	  Sdprintf("OOPS: trie_property/2: counted %zd values, admin says %zd\n",
		   (size_t)stats.values, (size_t)trie->value_count);
	// assert(stats.nodes  == trie->node_count);
	// assert(stats.values == trie->value_count);
	return PL_unify_int64(arg, stats.bytes);
      } else if ( name == ATOM_compiled_size )
      { atom_t dbref;
	if ( (dbref = trie->clause) )
	{ ClauseRef cref = clause_clref(dbref);
	  if ( cref )
	  { size_t sz = sizeofClause(cref->value.clause->code_size);
	    return PL_unify_int64(arg, sz);
	  }
	}
	return FALSE;
      } else if ( name == ATOM_hashed )
      { trie_stats stats;
	stat_trie(trie, &stats);
	return PL_unify_int64(arg, stats.hashes);
#ifdef O_TRIE_STATS
      } else if ( name == ATOM_lookup_count )
      { return PL_unify_int64(arg, trie->stats.lookups);
      } else if ( name == ATOM_gen_call_count)
      { return PL_unify_int64(arg, trie->stats.gen_call);
#ifdef O_PLMT
      } else if ( name == ATOM_wait )
      { return PL_unify_int64(arg, trie->stats.wait);
      } else if ( name == ATOM_deadlock )
      { return PL_unify_int64(arg, trie->stats.deadlock);
#endif
      } else if ( name == ATOM_invalidated && (idg=trie->data.IDG))
      { return PL_unify_int64(arg, idg->stats.invalidated);
      } else if ( name == ATOM_reevaluated && (idg=trie->data.IDG))
      { return PL_unify_int64(arg, idg->stats.reevaluated);
#endif
      } else if ( (idg=trie->data.IDG) )
      { if ( name == ATOM_idg_affected_count )
	{ return PL_unify_int64(arg, idg->affected ? idg->affected->size : 0);
	} else if ( name == ATOM_idg_dependent_count )
	{ return PL_unify_int64(arg, idg->dependent ? idg->dependent->size : 0);
	} else if ( name == ATOM_idg_size )
	{ size_t size = sizeof(*idg);

	  if ( idg->affected )  size += sizeofTablePP(idg->affected);
	  if ( idg->dependent ) size += sizeofTablePP(idg->dependent);

	  return PL_unify_int64(arg, size);
	}
      }
    }
  }

  return FALSE;
}

#ifdef O_NESTED_TRIES

		 /*******************************
		 *	 HIERARCHICAL TRIES	*
		 *******************************/

/** trie_insert_insert(+Trie, +Index, +Value)
*/

static
PRED_IMPL("trie_insert_insert", 3, trie_insert_insert, 0)
{ PRED_LD
  trie *trie;

  if ( get_trie(A1, &trie) )
  { Word kp, vp;
    trie_node *root, *node;
    tmp_buffer vars;
    int rc;

    initBuffer(&vars);
    kp	= valTermRef(A2);
    vp	= valTermRef(A3);

    rc = trie_lookup(trie, NULL, &root, kp, TRUE, &vars);
    if ( rc == TRUE )
    { rc = trie_lookup(trie, root, &node, vp, TRUE, &vars);

      if ( rc == TRUE )
      { set(root, TN_PRIMARY);
	root->value = ATOM_trienode;
	set(node, TN_SECONDARY);
	node->value = ATOM_trienode;
      } else
      { rc = trie_error(rc, A1);
      }
    } else
    { rc = trie_error(rc, A1);
    }

    discardBuffer(&vars);
    return rc;
  }

  return FALSE;
}


static
PRED_IMPL("trie_lookup_gen", 3, trie_lookup_gen, PL_FA_NONDETERMINISTIC)
{ PRED_LD
  trie *trie;

  if ( get_trie(A1, &trie) )
  { Word kp;
    trie_node *root;
    int rc;

    kp = valTermRef(A2);
    rc = trie_lookup(trie, NULL, &root, kp, FALSE, NULL);
    if ( rc == TRUE )
    { return trie_gen_raw(trie, root, A3, 0, 0, NULL, NULL, PL__ctx);
    } else
    { rc = trie_error(rc, A1);
    }

    return rc;
  }

  return FALSE;
}


static
PRED_IMPL("trie_lookup_delete", 3, trie_lookup_delete, 0)
{ PRED_LD

  trie *trie;

  if ( get_trie(A1, &trie) )
  { Word kp;
    trie_node *root;
    int rc;

    kp = valTermRef(A2);
    rc = trie_lookup(trie, NULL, &root, kp, FALSE, NULL);
    if ( rc == TRUE )
    { Word vp = valTermRef(A3);
      trie_node *node;

      rc = trie_lookup(trie, root, &node, vp, FALSE, NULL);
      if ( rc == TRUE )
      { trie_delete(trie, node, TRUE);
      } else
      { rc = trie_error(rc, A1);
      }
    } else
    { rc = trie_error(rc, A1);
    }

    return rc;
  }

  return FALSE;
}

#endif /*O_NESTED_TRIES*/


		 /*******************************
		 *	  COMPILED TRIES	*
		 *******************************/

typedef struct trie_compile_state
{ trie	       *trie;				/* Trie we are working on */
  int		try;				/* There are alternatives */
  int		last_is_fail;			/* Ends in I_FAIL */
  tmp_buffer	codes;				/* Output instructions */
  size_t	else_loc;			/* last else */
  size_t	maxvar;				/* Highest var index */
} trie_compile_state;

static void
init_trie_compile_state(trie_compile_state *state, trie *trie)
{ memset(state, 0, sizeof(*state));
  state->trie = trie;
  initBuffer(&state->codes);
  state->maxvar = 0;
}

static void
clean_trie_compile_state(trie_compile_state *state)
{ discardBuffer(&state->codes);
}


static void
add_vmi(trie_compile_state *state, vmi c)
{ addBuffer(&state->codes, encode(c), code);
}

static void
add_vmi_d(trie_compile_state *state, vmi c, code d)
{ addBuffer(&state->codes, encode(c), code);
  addBuffer(&state->codes, d, code);
}

static void
add_vmi_w(trie_compile_state *state, vmi c, word d)
{ addBuffer(&state->codes, encode(c), code);
  addBuffer(&state->codes, d, word);
}


static void
add_vmi_else_d(trie_compile_state *state, vmi c, code d)
{ size_t el;

  addBuffer(&state->codes, encode(c), code);
  el = entriesBuffer(&state->codes, code);
  addBuffer(&state->codes, (code)state->else_loc, code);
  state->else_loc = el;
  addBuffer(&state->codes, d, code);
}

static void
add_vmi_else_w(trie_compile_state *state, vmi c, word d)
{ size_t el;

  addBuffer(&state->codes, encode(c), code);
  el = entriesBuffer(&state->codes, code);
  addBuffer(&state->codes, (code)state->else_loc, code);
  state->else_loc = el;
  addBuffer(&state->codes, d, word);
}

static void
fixup_else(trie_compile_state *state)
{ Code base = baseBuffer(&state->codes, code);
  size_t pc = entriesBuffer(&state->codes, code);
  size_t el = state->else_loc;

  state->else_loc = base[el];
  base[el] = pc-el-1;
}

/* Add an indirect to the compiled trie.   Indirects are stored
 * using the header field, followed by the content.  I.e., the
 * same format as on the stacks, except that the trailing guard
 * is missing.  Therefore we write `wsize+1` words.
 */

static void
add_indirect(trie_compile_state *state, vmi op, word w)
{ Word p = addressIndirect(w);
  size_t wsize = wsizeofInd(*p);

  add_vmi(state, op);
  addMultipleBuffer(&state->codes, p, wsize+1, word);
}

static void
add_smallint(trie_compile_state *state, vmi c1, vmi c2, word w)
{ sword i = valInt(w);
#if CODES_PER_WORD == 1
  add_vmi_d(state, c1, (scode)i);
#else
  if ( (scode)i == i )
  { add_vmi_d(state, c1, (scode)i);
  } else
  { add_vmi(state, c2);
    addMultipleBuffer(&state->codes, &i, CODES_PER_WORD, code);
  }
#endif
}

static void
add_vmi_else_i(trie_compile_state *state, vmi c1, vmi c2, word w)
{ size_t el;
  sword i = valInt(w);
  vmi op;
#if CODES_PER_WORD == 1
  op = c1;
#else
  op =  (scode)i == i ? c1 : c2;
#endif

  addBuffer(&state->codes, encode(op), code);
  el = entriesBuffer(&state->codes, code);
  addBuffer(&state->codes, (code)state->else_loc, code);
  state->else_loc = el;
#if CODES_PER_WORD == 1
  addBuffer(&state->codes, i, scode);
#else
  if ( (scode)i == i )
    addBuffer(&state->codes, (scode)i, scode);
  else
    addMultipleBuffer(&state->codes, &i, CODES_PER_WORD, code);
#endif
}


#define compile_trie_value(v, state) LDFUNC(compile_trie_value, v, state)
static int
compile_trie_value(DECL_LD Word v, trie_compile_state *state)
{ term_agenda_P agenda;
  size_t var_number = 0;
  tmp_buffer varb;
  int rc = TRUE;
  int compounds = 0;
  Word p;

  initTermAgenda_P(&agenda, 1, v);
  while( (p=nextTermAgenda_P(&agenda)) )
  { size_t popn;

    if ( (popn = IS_AC_TERM_POP(p)) )
    { if ( popn == 1 )
	add_vmi(state, T_POP);
      else
	add_vmi_d(state, T_POPN, (code)popn);
    } else
    { word w = *p;

      switch( tag(w) )
      { case TAG_VAR:
	{ size_t index;

	  if ( isVar(w) )
	  { if ( var_number++ == 0 )
	    { initBuffer(&varb);
	    }
	    addBuffer(&varb, p, Word);
	    *p = w = ((((word)var_number))<<LMASK_BITS)|TAG_VAR;
	  }
	  index = (size_t)(w>>LMASK_BITS);
	  if ( index > state->maxvar )
	    state->maxvar = index;
	  add_vmi_d(state, T_VAR, (code)index);
	  break;
	}
	case TAG_ATTVAR:
	  rc = TRIE_LOOKUP_CONTAINS_ATTVAR;
	  goto out;
	case TAG_ATOM:			/* TBD: register */
	  add_vmi_d(state, T_ATOM, (code)w);
	  break;
	case TAG_INTEGER:
	  if ( storage(w) == STG_INLINE)
	  { add_smallint(state, T_SMALLINT, T_SMALLINTW, w);
#ifdef O_BIGNUM
	  } else
	  { add_indirect(state, T_MPZ, w);
#endif
	  }
	  break;
	case TAG_FLOAT:
	{ Code ip = (Code)valIndirectP(w);
	  add_vmi_d(state, T_FLOAT, ip[0]);
#if SIZEOF_CODE == 4
	  static_assertion(sizeof(double) == sizeof(code)*2);
	  addBuffer(&state->codes, ip[1], code);
#endif
          break;
	}
	case TAG_STRING:
	{ add_indirect(state, T_STRING, w);
	  break;
	}
	case TAG_COMPOUND:
	{ Functor f = valueTerm(w);
	  size_t arity = arityFunctor(f->definition);

	  if ( ++compounds == 1000 && !is_acyclic(p) )
	  { rc = TRIE_LOOKUP_CYCLIC;
	    goto out;
	  }
	  add_vmi_d(state, T_FUNCTOR, (code)f->definition);
	  pushWorkAgenda_P(&agenda, arity, f->arguments);
	  break;
	}
      }
    }
  }
out:
  clearTermAgenda_P(&agenda);

  if ( var_number )
  { Word *pp = baseBuffer(&varb, Word);
    Word *ep = topBuffer(&varb, Word);

    for(; pp < ep; pp++)
    { Word vp = *pp;
      setVar(*vp);
    }
    discardBuffer(&varb);
  }

  return rc;
}


#define compile_trie_node(n, state) LDFUNC(compile_trie_node, n, state)
static int
compile_trie_node(DECL_LD trie_node *n, trie_compile_state *state)
{ trie_children children;
  word key;
  int rc;

next:
  children = n->children;
  if ( n == &state->trie->root )
    goto children;
  key = n->key;

  switch(tagex(key))
  { case TAG_VAR|STG_LOCAL:			/* RESERVED_TRIE_VAL */
    { size_t popn = IS_TRIE_KEY_POP(key);

      assert(popn);
      if ( popn == 1 )
	add_vmi(state, T_POP);
      else
	add_vmi_d(state, T_POPN, (code)popn);
      break;
    }
    case TAG_ATOM|STG_GLOBAL:			/* functor */
    { if ( state->try )
	add_vmi_else_d(state, T_TRY_FUNCTOR, (code)key);
      else
	add_vmi_d(state, T_FUNCTOR, (code)key);
      break;
    }
    case TAG_VAR:
    { size_t index = (size_t)(key>>LMASK_BITS);

      if ( index > state->maxvar )
	state->maxvar = index;

      if ( state->try )
	add_vmi_else_d(state, T_TRY_VAR, (code)index);
      else
	add_vmi_d(state, T_VAR, (code)index);
      break;
    }
    case STG_GLOBAL|TAG_INTEGER:		/* indirect data */
    case STG_GLOBAL|TAG_STRING:
    case STG_GLOBAL|TAG_FLOAT:
    { size_t index = (size_t)(key>>LMASK_BITS);
      int idx = MSB(index);
      indirect *h = &state->trie->indirects->array.blocks[idx][index];
      size_t wsize = wsizeofInd(h->header);

      switch(tag(key))
      { case TAG_INTEGER:
	  { if ( state->try )
	      add_vmi_else_w(state, T_TRY_MPZ, h->header);
	    else
	      add_vmi_w(state, T_MPZ, h->header);
	  }
	  break;
        case TAG_STRING:
	  if ( state->try )
	    add_vmi_else_w(state, T_TRY_STRING, h->header);
	  else
	    add_vmi_w(state, T_STRING, h->header);
	  break;
        case TAG_FLOAT:
	  { static_assertion(sizeof(h->data[0]) == sizeof(double));
	    if ( state->try )
	      add_vmi_else_w(state, T_TRY_FLOAT, h->data[0]);
	    else
	      add_vmi_w(state, T_FLOAT, h->data[0]);
	    goto indirect_done;
	  }
      }

      addMultipleBuffer(&state->codes, h->data, wsize, word);
    indirect_done:
      break;
    }
    case TAG_ATOM:
    { if ( state->try )
	add_vmi_else_d(state, T_TRY_ATOM, code2atom(key));
      else
	add_vmi_d(state, T_ATOM, code2atom(key));
      break;
    }
    case TAG_INTEGER:
    { if ( state->try )
	add_vmi_else_i(state, T_TRY_SMALLINT, T_TRY_SMALLINTW, key);
      else
	add_smallint(state, T_SMALLINT, T_SMALLINTW, key);
      break;
    }
    default:
      assert(0);
  }

children:
  if ( children.any && false(n, TN_PRIMARY|TN_SECONDARY) )
  { switch( children.any->type )
    { case TN_KEY:
      { state->try = FALSE;
	n = children.key->child;
	goto next;
      }
      case TN_HASHED:
      { TableWP table = children.hash->table;
	TableEnum e = newTableEnumWP(table);
	table_key_t k;
	table_value_t v;

	if ( !advanceTableEnum(e, &k, &v) )
	{ freeTableEnum(e);
	  return TRUE;				/* empty path */
	}

	for(;;)
	{ n = val2ptr(v);

	  if ( !(state->try = advanceTableEnum(e, &k, &v)) )
	  { freeTableEnum(e);
	    goto next;
	  }

	  if ( (rc=compile_trie_node(n, state)) != TRUE )
	  { freeTableEnum(e);
	    return rc;
	  }
	  fixup_else(state);
	}
      }
    }
  } else
  { if ( n->value )			/* what if we have none? */
    { if ( answer_is_conditional(n) )
	add_vmi_d(state, T_DELAY, ptr2code(n));

      if ( true(state->trie, TRIE_ISMAP) )
      { add_vmi(state, T_VALUE);
	if ( !isRecord(n->value) )
	{ if ( isAtom(n->value) )
	  { add_vmi_d(state, T_ATOM, word2code(n->value));
	  } else
	  { add_smallint(state, T_SMALLINT, T_SMALLINTW, n->value);
	  }
	} else
	{ term_t t2;

	  if ( (t2=PL_new_term_ref()) &&
	       PL_recorded(word2ptr(record_t, n->value), t2) )
	  { Word p = valTermRef(t2);

	    deRef(p);
	    if ( (rc = compile_trie_value(p, state)) != TRUE )
	      return rc;
	  } else
	  { return FALSE;
	  }
	  PL_reset_term_refs(t2);
	}
      }
      add_vmi(state, I_EXIT);
      state->last_is_fail = FALSE;
    } else
    { add_vmi(state, I_FAIL);
      state->last_is_fail = TRUE;
    }
  }

  return TRUE;
}


static int
fixup_last_fail(trie_compile_state *state)
{ if ( state->last_is_fail )
    add_vmi(state, I_EXIT);	/* make sure the clause ends with I_EXIT */
  return TRUE;
}


static int
create_trie_clause(Definition def, Clause *cp, trie_compile_state *state)
{ size_t code_size = entriesBuffer(&state->codes, code);
  size_t size      = sizeofClause(code_size);
  //size_t clsize    = size + SIZEOF_CREF_CLAUSE;
  Clause cl;

  cl = PL_malloc_atomic(size);
  memset(cl, 0, sizeof(*cl));
  cl->predicate = def;
  cl->code_size = code_size;
  cl->prolog_vars = TRIE_VAR_OFFSET + state->maxvar;
  cl->variables = cl->prolog_vars;	/* 2: pseudo arity */
  set(cl, UNIT_CLAUSE);			/* no body */
  memcpy(cl->codes, baseBuffer(&state->codes, code), sizeOfBuffer(&state->codes));
  *cp = cl;

  ATOMIC_ADD(&GD->statistics.codes, cl->code_size);
  ATOMIC_INC(&GD->statistics.clauses);

  return TRUE;
}


atom_t
compile_trie(DECL_LD Definition def, trie *trie)
{ atom_t dbref;

retry:
  if ( !(dbref = trie->clause) )
  { if ( trie->value_count == 0 )
    { dbref = ATOM_fail;
      if ( !COMPARE_AND_SWAP_ATOM(&trie->clause, 0, dbref) )
	goto retry;
    } else
    { trie_compile_state state;
      Clause cl;
      ClauseRef cref;
      fid_t fid;

      init_trie_compile_state(&state, trie);
      add_vmi(&state, def->functor->arity == 2 ? T_TRIE_GEN2 : T_TRIE_GEN3);
      if ( (fid=PL_open_foreign_frame()) )
      { if ( compile_trie_node(&trie->root, &state) &&
	     fixup_last_fail(&state) &&
	     create_trie_clause(def, &cl, &state) )
	{ cref = assertDefinition(def, cl, CL_END);
	  if ( cref )
	  { dbref = lookup_clref(cref->value.clause);
	    if ( !COMPARE_AND_SWAP_ATOM(&trie->clause, 0, dbref) )
	    { PL_unregister_atom(dbref);
	      retractClauseDefinition(def, cref->value.clause, FALSE);
	      PL_close_foreign_frame(fid);
	      goto retry;
	    }
	  }
	}
	PL_close_foreign_frame(fid);
      } else
      { dbref = ATOM_error;
      }
      assert(state.else_loc == 0);
      clean_trie_compile_state(&state);
    }
  }

  return dbref;
}


static
PRED_IMPL("$trie_compile", 2, trie_compile, 0)
{ PRED_LD
  trie *trie;

  if ( get_trie(A1, &trie) )
  { Procedure proc = (true(trie, TRIE_ISMAP)
			     ? GD->procedures.trie_gen_compiled3
			     : GD->procedures.trie_gen_compiled2);
    atom_t clref = compile_trie(proc->definition, trie);

    return PL_unify_atomic(A2, clref);
  }

  return FALSE;
}


static void
set_trie_clause_general_undefined(Clause clause)
{ Code PC, ep;

  PC = clause->codes;
  ep = PC + clause->code_size;

  for( ; PC < ep; PC = stepPC(PC) )
  { code c = fetchop(PC);

    switch(c)
    { case T_DELAY:
	PC[1] = ptr2code(NULL);
        break;
    }
  }
}

		 /*******************************
		 *      PUBLISH PREDICATES	*
		 *******************************/

#define NDET PL_FA_NONDETERMINISTIC

BeginPredDefs(trie)
  PRED_DEF("is_trie",		    1, is_trie,		     0)
  PRED_DEF("trie_new",		    1, trie_new,	     0)
  PRED_DEF("trie_destroy",	    1, trie_destroy,	     0)
  PRED_DEF("trie_insert",	    2, trie_insert,	     0)
  PRED_DEF("trie_insert",	    3, trie_insert,	     0)
  PRED_DEF("trie_insert",	    4, trie_insert,	     0)
  PRED_DEF("$trie_insert_abstract", 3, trie_insert_abstract, 0)

  PRED_DEF("trie_update",	    3, trie_update,	     0)
  PRED_DEF("trie_lookup",	    3, trie_lookup,	     0)
  PRED_DEF("trie_delete",	    3, trie_delete,	     0)
  PRED_DEF("trie_term",		    2, trie_term,	     0)
  PRED_DEF("trie_gen",		    3, trie_gen,	     NDET)
  PRED_DEF("trie_gen",		    2, trie_gen,	     NDET)
  PRED_DEF("$trie_gen_node",	    3, trie_gen_node,	     NDET)
  PRED_DEF("$trie_property",	    2, trie_property,	     0)
#if O_NESTED_TRIES
  PRED_DEF("trie_insert_insert",    3, trie_insert_insert,   0)
  PRED_DEF("trie_lookup_gen",       3, trie_lookup_gen,      NDET)
  PRED_DEF("trie_lookup_delete",    3, trie_lookup_delete,   0)
#endif
  PRED_DEF("$trie_compile",         2, trie_compile,         0)
EndPredDefs

void
initTries(void)
{ Procedure proc;
  Definition def;

  PL_register_blob_type(&trie_blob);

  proc = PL_predicate("trie_gen_compiled", 2, "system");
  def = proc->definition;
  set(def, P_LOCKED_SUPERVISOR|P_VOLATILE);
  def->codes = SUPERVISOR(trie_gen);
  GD->procedures.trie_gen_compiled2 = proc;

  proc = PL_predicate("trie_gen_compiled", 3, "system");
  def = proc->definition;
  set(def, P_LOCKED_SUPERVISOR|P_VOLATILE);
  def->codes = SUPERVISOR(trie_gen);
  GD->procedures.trie_gen_compiled3 = proc;
}
