1/* BEGIN LICENSE BLOCK
2 * Version: CMPL 1.1
3 *
4 * The contents of this file are subject to the Cisco-style Mozilla Public
5 * License Version 1.1 (the "License"); you may not use this file except
6 * in compliance with the License.  You may obtain a copy of the License
7 * at www.eclipse-clp.org/license.
8 *
9 * Software distributed under the License is distributed on an "AS IS"
10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
11 * the License for the specific language governing rights and limitations
12 * under the License.
13 *
14 * The Original Code is  The ECLiPSe Constraint Logic Programming System.
15 * The Initial Developer of the Original Code is  Cisco Systems, Inc.
16 * Portions created by the Initial Developer are
17 * Copyright (C) 1992-2006 Cisco Systems, Inc.  All Rights Reserved.
18 *
19 * Contributor(s):
20 *
21 * END LICENSE BLOCK */
22
23/*
24 * SEPIA C SOURCE MODULE
25 *
26 * VERSION	$Id: dict.c,v 1.11 2013/02/08 15:00:52 jschimpf Exp $
27 */
28
29/*
30 * IDENTIFICATION	dict.c
31 *
32 * AUTHOR:		Joachim Schimpf
33 *
34 * DESCRIPTION		SEPIA dictionary and related routines
35 *
36 * CONTENTS:
37 *
38 *	dict_init()
39 *
40 *		initialise the dictionary data structures and enter
41 *		some predefined functors.
42 *
43 *	dident	enter_dict_n(char *name, int namelength, int arity)
44 *
45 *		Returns the DID for the functor with given name and arity.
46 *		If it is not yet in the dictionary, it is entered. The name
47 *		is specified with the length, so it can contain NUL bytes.
48 *
49 *	dident	enter_dict(char *name, int arity)
50 *
51 *		Same as enter_dict_n(), but takes a NUL-terminated C string
52 *
53 *	dident	in_dict(char *name, int arity)
54 *
55 *		Same as enter_dict(), but makes the entry a permanent one, ie.
56 *		it will never be garbage collected. It is safe to store such
57 *		DIDs in places that the garbage collector does not know about.
58 *
59 *	dident	ec_did(char *name, int arity)
60 *
61 *		Same as in_dict(), for naming like other user functions.
62 *
63 *	dident	add_dict(dident olddid, int newarity)
64 *
65 *		Converts a given DID into one for the same name but different
66 *		arity. If such an entry does not yet exist, it is created.
67 *
68 *	dident	check_did_n(char *name, int namelength, int arity)
69 *
70 *		Returns the DID for the functor with given name and arity.
71 *		If it is not yet in the dictionary, D_UNKNOWN is returned.
72 *
73 *	dident	check_did(dident olddid, int newarity)
74 *
75 *		Converts a given DID into one for the same name but different
76 *		arity. If such an entry does not exist, D_UNKNOWN is returned.
77 *
78 *	pword  *enter_string_n(char *name, int length, int stability)
79 *
80 *		Create an atom with the given stability and returns a pointer
81 *		to the corresponding string in the heap. This string exists
82 *		only as long as a functor with this name exists. That means,
83 *		if the string pointer is stored in a place where it is not
84 *		known to the garbage collector, the stability has to be
85 *		sufficiently high.
86 *
87 *	dident	bitfield_did(int bitfield)
88 *
89 *		convert a 19-bit bitfield representation of a DID (as used in
90 *		the variable names) to a standard 32-bit DID.
91 *
92 *	int	next_functor(int *index, dident *did)
93 *
94 *		support function for traversing the dictionary, see below.
95 *
96 *	gc_dictionary(arity)
97 *
98 *		Dictionary garbage collector.
99 *
100 */
101
102
103#include	"config.h"
104#include	"os_support.h"
105#include	"sepia.h"
106#include	"types.h"
107#include	"embed.h"
108#include	"error.h"
109#include	"mem.h"
110#include	"ec_io.h"
111#include	"dict.h"
112#include	"emu_export.h"
113
114static dident		_in_dict_opt(char *name, register int length, int hval, int arity, int options);
115static void		_std_did_init(void);
116static void		_constant_table_init(int);
117
118
119/*-----------------------------------------------------------------------------
120
121The basic data structure for the dictionary is the struct dict_item.
122A dictionary identifier (DID) is simply the address of such a dict_item.
123A dict_item contains:
124
125	- arity
126	- pointer to a (Sepia-)string representing the name
127	- procedure chain
128	- property chain
129	- collision chain
130	- flags
131
132dict_items are allocated in blocks of DICT_ITEM_BLOCK_SIZE (1024) elements.
133The addresses of these blocks are kept in a directory array of size
134DICT_DIRECTORY_SIZE (512). The maximum number of dictionary entries is thus
135DICT_DIRECTORY_SIZE * DICT_ITEM_BLOCK_SIZE (524288).
136This scheme is necessary to have a short 19-bit identifier (9 bits directory index,
13710 bits block index) for DIDs, which is used to store variable names in the tag.
138For all other purposes, a DID is stored directly as its 32-bit-address.
139
140For finding DIDs when their name is given, there is a hash table of size
141DICT_HASH_TABLE_SIZE. The hash value is computed from the name only, not
142from the arity. Thus all functors with the same name hash onto the same
143slot of the hash table (together with other functors whose name happens to
144give the same hash value). All colliding entries are kept in a circular
145chain, built using the 'next' field of the dict_items. The dict_item that
146is referenced from the hash table is marked with the 'head' bit.
147
148The circular collision chain is also used to find a functor that has the
149same name but different arity as a given one (e.g. in functor/3), so no
150new hashing is needed in this case, see function add_dict().
151
152The strings holding the functor names are allocated separately from the
153dict_items. All functors with the same name (but different arities) share
154the same string. Note that, due to the current handling of strings in Sepia,
155these strings are not only referenced by dict_items, but may also be pointed
156to by TSTRG pwords from elsewhere. The dictionary strings look like standard
157Sepia strings, but their tag is TBUFFER|IN_DICT|<ref_counter>.
158The reference counter counts the number of references from dict_items only,
159and is used to free the string when the last functor with this name disappears.
160To make sure that referenced strings are not collected, the marking routine
161marks the corresponding atom whenever a persistent string is encountered.
162
163-----------------------------------------------------------------------------*/
164
165#define DICT_DIRECTORY_SIZE	512
166#define DICT_ITEM_BLOCK_SIZE	1024
167
168#define DidBlock(i) ((i) >> 10)
169#define DidOffset(i) ((i) & 0x3ff)
170#define MakeBitField(block, offs) ((block)<<10|(offs))
171
172/* values for the options for _in_dict_opt() */
173#define IN_DICT_CHECK	0
174#define IN_DICT_ENTER	1
175
176#define NULL_DID	((dident) D_UNKNOWN)
177
178#define Inc_Ref_Ctr(tag)	{ (tag) += 0x100; }
179#define DecRefCtr(tag)		((tag) -= 0x100, (tag) & 0x0fffff00)
180
181
182/* DICT_HASH_TABLE_SIZE must be a power of 2 (we use masking) */
183#define DICT_HASH_TABLE_SIZE	8192
184
185/* compute hash value and length of a NULL-terminated string */
186#define Hash(id, hash, length) {					\
187	register char *str = (id);					\
188        for (length = hash = 0; *str; str++, length++)			\
189            hash += (hash<<3) + *(unsigned char *)str;			\
190        hash &= DICT_HASH_TABLE_SIZE-1;					\
191}
192
193/* compute hash value of a string of given length */
194#define Hashl(id, hash, n) {						\
195	register char *str = (id);					\
196	register int length = (n);					\
197        for (hash = 0; length > 0; str++, --length)			\
198            hash += (hash<<3) + *(unsigned char *)str;			\
199        hash &= DICT_HASH_TABLE_SIZE-1;					\
200}
201
202
203/*
204 * Compare 2 strings of length length.
205 * length is decremented and is 0 if the strings were equal
206 */
207#define Compare_N_Chars(length, s1, s2) {				\
208	register char *aux1 = (s1), *aux2 = (s2);			\
209	while (length) {						\
210	    if (*aux1++ != *aux2++)					\
211		break;							\
212	    --length;							\
213	}								\
214}
215
216#define DidInUse(d)	(DidString(d))
217
218
219/*
220 * TYPEDEFS and GLOBAL VARIABLES
221 */
222
223static struct dictionary {
224	dident	hash_table[DICT_HASH_TABLE_SIZE];
225	dident	directory[DICT_DIRECTORY_SIZE];	/* table of dict_item blocks */
226	struct dict_item tag_did[NTYPES+1];	/* to hold type properties */
227	a_mutex_t lock;		/* lock for hash table */
228	int	dir_index;	/* next free directory slot */
229	dident	free_item_list;	/* chain of free dict_items */
230	int	items_free;	/* number of elements in this chain */
231	int	table_usage;	/* number of hash slots in use */
232	int	collisions;	/* number of hash collisions */
233	int	gc_countdown;	/* remaining allocations before triggering gc */
234	int	gc_interval;	/* remaining allocations before triggering gc */
235	int	gc_number;	/* number of garbage collections so far */
236	word	gc_time;	/* and the time they took */
237	int	string_used;
238	int	string_free;
239} *dict;
240
241
242void
243dict_init(int flags)
244{
245    if (flags & INIT_SHARED)
246    {
247	register int i;
248	dict = (struct dictionary *) hg_alloc_size(sizeof(struct dictionary));
249	shared_data->dictionary = (void_ptr) dict;
250	for (i=0; i< DICT_HASH_TABLE_SIZE; i++)
251	    dict->hash_table[i] = NULL_DID;
252	for (i=0; i< DICT_DIRECTORY_SIZE; i++)
253	    dict->directory[i] = NULL_DID;
254	for (i=0; i <= NTYPES; i++)
255	{
256	    dict->tag_did[i].string = 0;
257	    dict->tag_did[i].properties = 0;
258	    dict->tag_did[i].macro = 0;
259	}
260	dict->dir_index = 0;
261	dict->free_item_list = NULL_DID;
262	dict->items_free = 0;
263	dict->string_used = 0;
264	dict->string_free = 0;
265	dict->table_usage = 0;
266	dict->collisions = 0;
267	dict->gc_interval = DICT_ITEM_BLOCK_SIZE/16*15;
268	/* set initial countdown high enough to make sure the first
269	 * collection does not occur too early in the boot phase */
270	dict->gc_countdown = 2*dict->gc_interval;
271	dict->gc_number = 0;
272	dict->gc_time = 0;
273	a_mutex_init(&dict->lock);
274    }
275    if (flags & INIT_PRIVATE)
276    {
277	int i;
278
279	dict = (struct dictionary *) shared_data->dictionary;
280	_std_did_init();
281
282	/* Tag descriptor array (more settings in bip_emu_init()) */
283	for (i=0; i <= NTYPES; i++)
284	{
285	    tag_desc[i].super =
286	    tag_desc[i].tag.kernel = (word) i;
287	    tag_desc[i].order = 0;
288	    tag_desc[i].type_name =
289	    tag_desc[i].tag_name = D_UNKNOWN;
290	}
291
292	tag_desc[TLIST].tag_name = in_dict("list", 0);
293	tag_desc[TCOMP].tag_name = in_dict("structure", 0);
294	tag_desc[TSTRG].tag_name = d_.string0;
295	tag_desc[TBIG].tag_name = in_dict("bignum", 0);
296	tag_desc[TDBL].tag_name = d_.double0;
297	tag_desc[TRAT].tag_name = d_.rational0;
298	tag_desc[TSUSP].tag_name = d_.goal;
299	tag_desc[THANDLE].tag_name = in_dict("handle", 0);
300	tag_desc[TNIL].tag_name = d_.nil;
301	tag_desc[TINT].tag_name = d_.integer0;
302	tag_desc[TDICT].tag_name = d_.atom0;
303	tag_desc[TPTR].tag_name = d_.meta0;
304
305	tag_desc[TLIST].super = TCOMP;
306	tag_desc[TCOMP].type_name = d_.compound0;
307	tag_desc[TSTRG].type_name = d_.string0;
308	tag_desc[TBIG].super = TINT;
309	tag_desc[TINT].type_name = d_.integer0;
310	tag_desc[TDBL].type_name = d_.float0;
311	tag_desc[TRAT].type_name = d_.rational0;
312	tag_desc[TSUSP].type_name = d_.goal;
313	tag_desc[THANDLE].type_name = in_dict("handle", 0);
314	tag_desc[TNIL].super = TDICT;
315	tag_desc[TDICT].type_name = d_.atom0;
316	tag_desc[TPTR].type_name = d_.meta0;
317    }
318
319    _constant_table_init(flags);
320}
321
322
323/*
324 * Return dict_item for the specified type/tag.
325 * It is used to attach properties to types, in particular macros.
326 */
327
328dident
329transf_did(word t)
330{
331    return (dident) &dict->tag_did[tag_desc[TagTypeC(t)].super];
332}
333
334
335/*
336 * String allocation for dictionary.
337 * These strings are write-once, read-only, except for dictionary gc.
338 */
339
340#define StringSize(length) (BufferSizePwords(length+1) * sizeof(pword))
341
342static pword *
343alloc_string(int length)
344{
345    pword *ptr;
346    ptr = (pword *) hg_alloc_size((int) StringSize(length));
347    return ptr;
348}
349
350static void
351free_string(pword *ptr)
352{
353    hg_free_size((generic_ptr) ptr, (int) StringSize(ptr->val.nint));
354}
355
356
357
358/*
359 * return a new dict_item
360 *
361 * Initializes all fields except .next
362 * Free dict_items are in the free list and can be recognised also
363 * by having a NULL string field.
364 */
365
366static dident
367_alloc_dict_item(pword *dict_string, int arity)
368{
369    register dident dip;
370
371    dip = dict->free_item_list;
372    if (!dip)				/* free list empty, allocate a new block */
373    {
374	register int i;
375	if (dict->dir_index == DICT_DIRECTORY_SIZE)
376	    ec_panic("dictionary overflow", "atom/functor creation");
377	dip =
378	dict->free_item_list =
379	dict->directory[dict->dir_index] =
380	    (dident) hg_alloc_size(sizeof(struct dict_item) * DICT_ITEM_BLOCK_SIZE);
381	for (i = 0; i < DICT_ITEM_BLOCK_SIZE; ++i)
382	{
383	    dip[i].bitfield = MakeBitField(dict->dir_index, i);
384	    dip[i].string = (pword *) 0;
385	    dip[i].arity = UNUSED_DID_ARITY;
386	    dip[i].next = &dip[i+1];
387	}
388	dip[i-1].next = NULL_DID;
389	dict->dir_index++;
390	dict->items_free += DICT_ITEM_BLOCK_SIZE;
391    }
392
393    dip->string = dict_string;		/* initialize the dict_item */
394    Inc_Ref_Ctr(dict_string->tag.kernel);
395    dip->arity = arity;
396    dip->procedure = 0;
397    dip->properties = 0;
398    dip->macro = 0;
399    dip->attainable = 0;
400    dip->module = 0;
401    dip->isop = 0;
402    dip->head = 0;
403    dip->stability = 0;
404
405    dict->free_item_list = dip->next; /* unlink it from the free list */
406    dict->items_free--;
407    if (--dict->gc_countdown == 0)
408    {
409	pword pw;
410	Make_Atom(&pw, d_.garbage_collect_dictionary);
411	ec_post_event(pw);
412    }
413    return dip;
414}
415
416
417dident
418in_dict(char *name, int arity)
419{
420    register int hval, len;
421    register dident dip;
422    Hash(name, hval, len);
423    dip = _in_dict_opt(name, len, hval, arity, IN_DICT_ENTER);
424    Set_Did_Stability(dip, DICT_PERMANENT);
425    return dip;
426}
427
428dident Winapi
429ec_did(const char *name, const int arity)
430{
431    register int hval, len;
432    register dident dip;
433    Hash((char *)name, hval, len);
434    dip = _in_dict_opt((char *) name, len, hval, arity, IN_DICT_ENTER);
435    Set_Did_Stability(dip, DICT_PERMANENT);
436    return dip;
437}
438
439dident
440enter_dict(char *name, int arity)
441{
442    register int hval, len;
443    Hash(name, hval, len);
444    return _in_dict_opt(name, len, hval, arity, IN_DICT_ENTER);
445}
446
447dident
448enter_dict_n(char *name, register word len, int arity)
449{
450    register int hval;
451    Hashl(name, hval, len);
452    return _in_dict_opt(name, (int) len, hval, arity, IN_DICT_ENTER);
453}
454
455dident
456check_did_n(char *name, word len, int arity)
457{
458    register int hval;
459    Hashl(name, hval, len);
460    return _in_dict_opt(name, (int) len, hval, arity, IN_DICT_CHECK);
461}
462
463pword *
464enter_string_n(char *name, word len, int stability)
465{
466    register int hval;
467    register dident dip;
468    Hashl(name, hval, len);
469    dip = _in_dict_opt(name, (int) len, hval, 0, IN_DICT_ENTER);
470    Set_Did_Stability(dip, stability);
471    return DidString(dip);
472}
473
474dident
475bitfield_did(word bf)
476{
477    return (dident) (dict->directory[DidBlock(bf)] + DidOffset(bf));
478}
479
480
481/*
482 * _in_dict_opt(name, length, hval, arity, options)
483 *	options are IN_DICT_CHECK or IN_DICT_ENTER
484 *
485 * We guarantee that functors with the same name always share their name string!
486 *
487 * We only lock on dictionary modifications, assuming that dids are
488 * never removed under our feet. This means that for dictionary gc's
489 * we have to stop all workers!
490 */
491
492static dident
493_in_dict_opt(char *name,	/* might not be NUL-terminated! */
494	register int length,
495	int hval,
496	int arity,
497	int options)
498{
499    register dident dip;
500    register dident start;
501    register pword *dict_string;
502
503    start = dict->hash_table[hval];
504    dict_string = (pword *) 0;
505    if (start)
506    {
507	dip = start;
508	do
509	{
510	    if (!dict_string)
511	    {
512		if (DidLength(dip) == length)
513		{
514		    register word cmp = length;
515		    Compare_N_Chars(cmp, name, DidName(dip));
516		    if (!cmp)		/* name found */
517		    {
518			if (DidArity(dip) == arity)
519			    return (dident) dip;
520			else
521			    dict_string = DidString(dip);
522		    }
523		}
524	    }
525	    else if (DidString(dip) == dict_string && DidArity(dip) == arity)
526		return (dident) dip;
527	    dip = dip->next;
528	} while (dip != start);
529    }
530    if (options == IN_DICT_CHECK)
531	return (dident) NULL_DID;
532
533    if (!dict_string)	/* a functor with a new name */
534    {
535	dict->string_used += length+1;
536	dict_string = alloc_string(length);
537	Set_Buffer_Size(dict_string, length+1);
538	dict_string->tag.kernel = TBUFFER|IN_DICT;
539	Copy_Bytes((char *)(dict_string+1), name, (int) (length));
540	((char *)(dict_string+1))[length] = 0;
541	if (start)
542	    dict->collisions++;
543    }
544    dip = _alloc_dict_item(dict_string, arity);
545    a_mutex_lock(&dict->lock);
546    if (start)
547    {
548	dip->next = start->next;
549	start->next = dip;
550    }
551    else	/* the first entry in this hash slot */
552    {
553	dip->next = dip;
554	dip->head = 1;
555	dict->hash_table[hval] = dip;
556	dict->table_usage++;
557    }
558    a_mutex_unlock(&dict->lock);
559    return (dident) dip;
560}
561
562
563dident
564add_dict(register dident old_did, register int new_arity)
565{
566    register dident	dip;
567
568    dip = (dident) old_did;
569    do {
570	if (DidArity(dip) == new_arity && DidString(dip) == DidString(old_did))
571	    return (dident) dip;
572	dip = dip->next;
573    } while (dip != DidPtr(old_did));
574
575    /* not found, make a new entry */
576    dip = _alloc_dict_item(DidString(old_did), new_arity);
577    a_mutex_lock(&dict->lock);
578    dip->next = DidNext(old_did);
579    DidNext(old_did) = dip;
580    a_mutex_unlock(&dict->lock);
581    return (dident) dip;
582}
583
584dident
585check_did(register dident old_did, register int new_arity)
586{
587    register dident	dip = (dident) old_did;
588
589    do {
590	if (DidArity(dip) == new_arity && DidString(dip) == DidString(old_did))
591	    return (dident) dip;
592	dip = dip->next;
593    } while (dip != DidPtr(old_did));
594    return D_UNKNOWN;
595}
596
597
598/*
599 * int next_functor()
600 *
601 * A support function to scan the dictionary. It is used to implement
602 * current_functor/1 and the like.
603 * The update semantics of this function is unclear (i.e. if a new
604 * functor is entered between successive calls of next_functor(),
605 * it will be returned or not, depending of where it is inserted).
606 * Note also that dictionary GCs might happen between successive calls
607 * to this function, which has similar consequences.
608 * However, the function is at least robust and will not crash.
609 *
610 * To be used like:
611 *
612 *	int	idx = 0;
613 *	dident	did;
614 *
615 *	while (next_functor(&idx, &did))
616 *	{
617 *		<use did>
618 *	}
619 */
620
621int
622next_functor(			/* returns 0 when dictionary exhausted	*/
623    	int *pidx,		/* in/out: current dict index		*/
624	dident *pdid)		/* output: valid did			*/
625{
626    register dident dip;
627    register int idx = *pidx;
628
629    while (DidBlock(idx) < dict->dir_index)
630    {
631	dip = dict->directory[DidBlock(idx)];
632	if (dip)
633	{
634	    dip += DidOffset(idx);
635	    do
636	    {
637		idx++;
638		if (DidInUse(dip))
639		{
640		    *pdid = (dident) dip;
641		    *pidx = idx;
642		    return 1;
643		}
644		dip++;
645	    } while (DidOffset(idx));
646	}
647	else
648	    idx = (DidBlock(idx) + 1) * DICT_ITEM_BLOCK_SIZE;
649    }
650    return 0;
651}
652
653
654
655/*--------------------------------------------------------------
656 * Dictionary garbage collection
657 *--------------------------------------------------------------*/
658
659/*
660 * _tidy_dictionary()
661 */
662
663#define Useful(d)	((d)->attainable || (d)->stability > DICT_VOLATILE \
664			|| (d)->procedure || (d)->properties)
665
666#if 0
667
668/*
669 * The free list is built such that the oldest dids are reused first in order
670 * to quickly fill did blocks again, so that they are more or less read-only
671 * afterwards.
672 * Another advantage of this scheme is that we can easily detect when a block
673 * becomes completely unused, and then free the whole block.
674 */
675
676static void
677_tidy_dictionary0(void)
678{
679    int block, idx;
680    register dident dip, aux;
681    register dident *free_list_tail = &dict->free_item_list;
682
683    *free_list_tail = NULL_DID;
684    for (block = 0; block < dict->dir_index; block++)
685    {
686	dip = dict->directory[block];
687	for (idx = 0; idx < DICT_ITEM_BLOCK_SIZE; idx++, dip++)
688	{
689	    if (DidInUse(dip) && Useful(dip))
690	    {
691		dip->attainable = 0;
692		continue;
693	    }
694	    else if (DidInUse(dip))		/* a garbage did, unlink it */
695	    {
696		/* Tidy the collision chain in which dip occurs. This assumes that
697		 * all DIDs with this name are in the same chain!
698		 */
699		register dident prev = dip;
700		int head_removed = 0;
701
702		do
703		{
704		    aux = prev->next;
705		    if (Useful(aux))		/* no garbage, skip it */
706		    {
707			prev = aux;
708			continue;
709		    }
710		    else			/* remove aux */
711		    {
712			pword *str = DidString(aux);
713			prev->next = aux->next;
714			aux->next = NULL_DID;
715			dict->items_free++;
716			if (DecRefCtr(str->tag.kernel) == 0)
717			{
718			    dict->string_used -= str->val.nint + 1;
719			    free_string(str);
720			    /*
721			    p_fprintf(current_err_, "%s/%d (with string)\n",
722							DidName(aux), DidArity(aux));
723			    */
724			}
725			/*
726			else
727			{
728			    p_fprintf(current_err_, "%s/%d\n",
729							DidName(aux), DidArity(aux));
730			}
731			*/
732			aux->string = (pword *) 0;
733			aux->arity = -1;
734			if (aux->head)
735			    head_removed = 1;
736		    }
737		} while (aux != dip);
738
739		if (head_removed)
740		{
741		    register char *dummy1;
742		    register int dummy2;
743		    register hval;
744		    Hash(DidName(dip), hval, dummy2, dummy1);
745		    if (prev != dip)
746		    {
747			prev->head = 1;
748			dict->hash_table[hval] = prev;
749		    }
750		    else	/* we removed all chain elements */
751		    {
752			dict->hash_table[hval] = NULL_DID;
753			dict->table_usage--;
754		    }
755		}
756	    } /* else: an already unlinked garbage did */
757	    *free_list_tail = dip;		/* add it to the free list */
758	    free_list_tail = &dip->next;
759	}
760    }
761    *free_list_tail = NULL_DID;
762    Succeed_;
763}
764
765#endif /* 0 */
766
767/*
768 * alternatively, scan through the hash table
769 */
770
771static void
772_tidy_dictionary(void)
773{
774    int idx;
775    register dident dip;
776    register dident prev;
777
778    for (idx = 0; idx < DICT_HASH_TABLE_SIZE; idx++)
779    {
780	prev = dict->hash_table[idx];
781	if (prev)
782	{
783	    do
784	    {
785		dip = prev->next;
786		if (Useful(dip))
787		{
788		    dip->attainable = 0;
789		    prev = dip;
790		}
791		else		/* a garbage did, unlink it */
792		{
793		    pword *str = DidString(dip);
794		    prev->next = dip->next;
795		    /*
796		    p_fprintf(current_err_, "\n%s/%d", DidName(dip), DidArity(dip));
797		    */
798		    if (DecRefCtr(str->tag.kernel) == 0)
799		    {
800			dict->collisions--;
801			dict->string_used -= str->val.nint + 1;
802			free_string(str);
803			/*
804			p_fprintf(current_err_, " (with string)");
805			*/
806		    }
807		    /* add it to the free list */
808#ifdef DEBUG_DICT
809		    dip->arity = (word) dip->string;
810		    dip->string = (pword *) 0;
811#else
812		    dip->arity = UNUSED_DID_ARITY;
813		    dip->string = (pword *) 0;
814		    dip->next = dict->free_item_list;
815		    dict->free_item_list = dip;
816		    dict->items_free++;
817#endif
818		    if (dip->head)		/* removing the chain header */
819		    {
820			if (prev != dip)
821			{
822			    prev->head = 1;
823			    dict->hash_table[idx] = prev;
824			}
825			else	/* we removed all chain elements */
826			{
827			    dict->hash_table[idx] = NULL_DID;
828			    dict->collisions++;	/* was not a collision */
829			    dict->table_usage--;
830			}
831		    }
832		}
833	    } while (!dip->head);
834	}
835    }
836}
837
838static void
839_mark_dids_from_procs(pri *proc)
840{
841    for (; proc; proc = PriNext(proc))
842    {
843	if (proc->module_def)
844	    Mark_Did(proc->module_def);
845	if (proc->module_ref)
846	    Mark_Did(proc->module_ref);
847	if (proc->trans_function)
848	    Mark_Did(proc->trans_function);
849	if (DynamicProc(proc))
850	    ec_mark_dids_dyn_code(PriCode(proc));
851	/* PriDid does not need to be marked because it has a procedure
852	 * and will therefore not be collected */
853    }
854}
855
856int
857ec_gc_dictionary(void)
858{
859    int		usage_before, garbage, idx = 0;
860    dident	d;
861    word	gc_time;
862    extern int	in_exception(void);
863    extern void mark_dids_from_properties(property *prop_list),
864		mark_dids_from_stacks(word arity),
865		mark_dids_from_streams(void);
866
867    dict->gc_countdown = dict->gc_interval;
868
869    if (!(GlobalFlags & GC_ENABLED)	/* if switched off */
870	|| ec_options.parallel_worker	/* or heap is shared */
871	|| g_emu_.nesting_level > 1	/* or when emulators are nested */
872	|| in_exception())		/* or inside exception */
873    {
874	Succeed_;			/* then don't gc (not implemented) */
875    }
876
877#ifndef PRINTAM
878    Disable_Int()
879#endif
880
881    if (GlobalFlags & GC_VERBOSE)
882    {
883	(void) ec_outfs(log_output_,"DICTIONARY GC .");
884	ec_flush(log_output_);
885    }
886
887    usage_before = dict->dir_index * DICT_ITEM_BLOCK_SIZE -
888			dict->items_free;
889    gc_time = user_time();
890
891    mark_dids_from_stacks(0L);		/* mark the abstract machine's data */
892
893    while (next_functor(&idx, &d))	/* mark from all the properties */
894    {
895	if (DidProc(d))
896	    _mark_dids_from_procs(DidProc(d));
897	if (DidProperties(d))
898	    mark_dids_from_properties(DidProperties(d));
899    }
900
901    mark_dids_from_streams();		/* mark from the stream descriptors */
902
903    if (GlobalFlags & GC_VERBOSE)
904    {
905	(void) ec_outfs(log_output_,"."); ec_flush(log_output_);
906    }
907
908    _tidy_dictionary();
909
910    gc_time = user_time() - gc_time;
911    dict->gc_number++;
912    dict->gc_time += gc_time;
913    garbage = usage_before - (dict->dir_index * DICT_ITEM_BLOCK_SIZE -
914				dict->items_free);
915
916#ifndef PRINTAM
917    Enable_Int()
918#endif
919
920    if (GlobalFlags & GC_VERBOSE)
921    {
922	p_fprintf(log_output_, ". %d - %d, (%.1f %%), time: %.3f\n",
923	    usage_before,
924	    garbage,
925	    (100.0*garbage)/usage_before,
926	    (float)gc_time/clock_hz);
927	ec_flush(log_output_);
928    }
929
930    Succeed_;
931}
932
933
934
935/*--------------------------------------------------------------
936 * Statistics and debugging
937 *--------------------------------------------------------------*/
938
939/*ARGSUSED*/
940int
941ec_dict_param(value vwhat, type twhat, value vval, type tval)
942{
943    pword result;
944
945    result.tag.kernel = TINT;
946    switch(vwhat.nint)
947    {
948    case 0:	/* # entries */
949	result.val.nint = dict->dir_index * DICT_ITEM_BLOCK_SIZE -
950				dict->items_free;
951	break;
952    case 1:	/* # free items */
953	result.val.nint = dict->items_free;
954	break;
955    case 2:	/* hash table size */
956	result.val.nint = DICT_HASH_TABLE_SIZE;
957	break;
958    case 3:	/* hash table usage */
959	result.val.nint = dict->table_usage;
960	break;
961    case 4:	/* collisions */
962	result.val.nint = dict->collisions;
963	break;
964    case 5:	/* gc_number */
965	result.val.nint = dict->gc_number;
966	break;
967    case 6:	/* gc time */
968	Return_Unify_Float(vval, tval, dict->gc_time/clock_hz);
969    case 7:	/* set or get the gc interval */
970	if (IsInteger(tval))
971	{
972	    dict->gc_countdown = dict->gc_interval = vval.nint;
973	}
974	result.tag.kernel = TINT;
975	result.val.nint = dict->gc_interval;
976	break;
977    default:
978	Fail_;
979    }
980    Return_Unify_Pw(vval, tval, result.val, result.tag);
981}
982
983
984/*
985 * auxiliary functions for debugging
986 */
987
988#ifdef PRINTAM
989#ifndef lint
990
991pr_functors(value v, type t)
992{
993    register dident dip;
994    int index, len;
995
996    Check_Integer(t);
997    for (index = 0; index < DICT_HASH_TABLE_SIZE; index++)
998    {
999	dip = dict->hash_table[index];
1000	if (dip)
1001	{
1002	    len = 0;
1003	    do {
1004		len++;
1005		dip = dip->next;
1006	    } while (!dip->head);
1007	    if (dip != dict->hash_table[index])
1008		p_fprintf(current_output_,"BAD COLLISION LIST\n");
1009	    if (len >= v.nint)
1010	    {
1011		p_fprintf(current_output_,"[%d]", index);
1012		do {
1013		    p_fprintf(current_output_," %s/%d",
1014				DidName(dip), DidArity(dip));
1015		    dip = dip->next;
1016		} while (!dip->head);
1017		p_fprintf(current_output_,"\n");
1018	    }
1019	}
1020    }
1021    Succeed_;
1022}
1023
1024pr_dict(void)
1025{
1026    p_fprintf(current_output_, "blocks allocated = %d\n", dict->dir_index);
1027    p_fprintf(current_output_, "items used = %d\n",
1028		dict->dir_index*DICT_ITEM_BLOCK_SIZE-dict->items_free);
1029    p_fprintf(current_output_, "items free = %d\n", dict->items_free);
1030    p_fprintf(current_output_, "string_used = %d\n", dict->string_used);
1031    p_fprintf(current_output_, "table_usage = %d/%d\n",
1032				dict->table_usage, DICT_HASH_TABLE_SIZE);
1033    p_fprintf(current_output_, "table_usage ratio = %.1f%%\n",
1034				100.0*dict->table_usage/DICT_HASH_TABLE_SIZE);
1035    p_fprintf(current_output_, "collisions = %d\n", dict->collisions);
1036    p_fprintf(current_output_, "collision ratio = %.1f%%\n",
1037				100.0*dict->collisions/dict->table_usage);
1038    p_fprintf(current_output_, "gc countdown = %d\n", dict->gc_countdown);
1039    p_fprintf(current_output_, "gc number = %d\n", dict->gc_number);
1040    p_fprintf(current_output_, "gc time = %.3f\n",
1041				(float)dict->gc_time/clock_hz);
1042    Succeed_;
1043}
1044
1045
1046/*
1047 * 	help debugging: print a dictionary entry
1048*/
1049static dident
1050_pdict(dident entry)
1051{
1052    pri	*proc;
1053
1054    p_fprintf(current_err_, "%s/", DidName(entry));
1055    p_fprintf(current_err_, "%d", DidArity(entry));
1056    p_fprintf(current_err_, "\n length=%d ", DidLength(entry));
1057    p_fprintf(current_err_, "module=%d ", DidModule(entry));
1058    p_fprintf(current_err_, "macro=%d ", DidMacro(entry));
1059    p_fprintf(current_err_, "attainable=%d ", DidAttainable(entry));
1060    p_fprintf(current_err_, "stability=%d ", DidStability(entry));
1061    p_fprintf(current_err_, "head=%d ", DidPtr(entry)->head);
1062    p_fprintf(current_err_, "isop=%d", DidIsOp(entry));
1063    p_fprintf(current_err_, "\n next=%x ", DidPtr(entry)->next);
1064    p_fprintf(current_err_, "properties=%x ", DidProperties(entry));
1065    proc = DidPtr(entry)->procedure;
1066    p_fprintf(current_err_, "\n proc=0x%x", proc);
1067    if (proc) {
1068	p_fprintf(current_err_, "(code=0x%x", PriCode(proc));
1069	p_fprintf(current_err_, " next=0x%x", PriNext(proc));
1070	p_fprintf(current_err_, " module=%d", PriModule(proc));
1071	p_fprintf(current_err_, " flags=0x%x", PriFlags(proc));
1072	p_fprintf(current_err_, " did=0x%x)", PriDid(proc));
1073    }
1074    (void) ec_newline(current_err_);
1075    return entry;
1076}
1077
1078#endif /* lint */
1079#endif /* PRINTAM */
1080
1081
1082static void
1083_std_did_init(void)
1084{
1085	/* The first did entered is the empty name. This is used for
1086	 * unknown variable names. It has a zero bitfield representation.
1087	 */
1088	d_.empty = 	in_dict("", 0);
1089
1090	d_.semi0 = 	in_dict(";", 0);
1091	d_.naf = 	in_dict("\\+", 1);
1092	d_.not1 = 	in_dict("not", 1);
1093	d_.fail_if = 	in_dict("fail_if", 1);
1094	d_.once =	in_dict("once", 1);
1095	d_.not_unify = 	in_dict("\\=", 2);
1096	d_.diff_reg =   in_dict("~=",2);
1097	d_.not_identical = 	in_dict("\\==", 2);
1098	d_.not_equal =	in_dict("=\\=", 2);
1099
1100	d_.comment = 	in_dict("/*", 0);
1101	d_.eocl = 	in_dict( ".", 0);
1102	d_.eof = 	in_dict( "end_of_file", 0);
1103	d_.list = 	in_dict( ".", 2);
1104	d_.rulech0 = 	in_dict(":-",0);
1105	d_.rulech1 = 	in_dict( ":-", 1);
1106	d_.rulech2 = 	in_dict( ":-", 2);
1107	d_.goalch = 	in_dict( "?-", 1);
1108	d_.grammar = 	in_dict("-->", 2);
1109	d_.nil = 	in_dict( "[]", 0);
1110	d_.fail = 	in_dict("fail",0);
1111	d_.nilcurbr = 	in_dict( "{}", 0);
1112	d_.nilcurbr1 = 	in_dict( "{}", 1);
1113	d_.eoi = 	in_dict( "\004", 0);
1114	d_.cond = 	in_dict( "->", 2);
1115	d_.ampersand = 	in_dict( "&", 2);
1116	d_.cut = 	in_dict( "!", 0);
1117	d_.syscut = 	in_dict( "syscut", 0);
1118	d_.cut_to = 	in_dict( "cut_to", 1);
1119        d_.arg =	in_dict("arg", 3);
1120        d_.subscript =	in_dict("subscript", 2);
1121	d_.comma = 	in_dict( ",", 2);
1122	d_.semicolon = 	in_dict( ";", 2);
1123	d_.colon =	in_dict(":", 2);
1124	d_.bar = 	in_dict( "|", 2);
1125	d_.uref = 	in_dict( "_", 0);
1126      	d_.univ = 	in_dict("=..", 2);
1127		/* arithmetic */
1128	d_.plus1 = 	in_dict("+", 1);
1129	d_.plus = 	in_dict("+", 2);
1130	d_.minus1 = 	in_dict("-", 1);
1131	d_.minus = 	in_dict("-", 2);
1132	d_.times = 	in_dict("*", 2);
1133	d_.inf = 	in_dict("<", 2);
1134	d_.sup = 	in_dict(">", 2);
1135	d_.supq = 	in_dict(">=", 2);
1136	d_.infq = 	in_dict("=<", 2);
1137	d_.inf0 = 	in_dict("<", 0);
1138	d_.sup0 = 	in_dict(">", 0);
1139	d_.supq0 = 	in_dict(">=", 0);
1140	d_.infq0 = 	in_dict("=<", 0);
1141	d_.quotient = 	in_dict("/",2);
1142	d_.div = 	in_dict("//", 2);
1143	d_.modulo = 	in_dict("mod", 2);
1144	d_.equal = 	in_dict("=:=", 2);
1145	d_.is = 	in_dict("is",2);
1146	d_.rshift = 	in_dict(">>", 2);
1147	d_.lshift = 	in_dict("<<", 2);
1148	d_.and2 = 	in_dict("/\\",2);
1149	d_.or2 = 	in_dict("\\/", 2);
1150	d_.power = 	in_dict("^", 2);
1151	d_.bitnot = 	in_dict("\\", 1);
1152	d_.min =	in_dict("min",2);
1153	d_.minint =	in_dict("minint",1);
1154	d_.max =	in_dict("max",2);
1155	d_.maxint =	in_dict("maxint",1);
1156	d_.abs =	in_dict("abs",1);
1157	d_.xor2 =	in_dict("xor",2);
1158	d_.pi =		in_dict("pi",0);
1159	d_.e =		in_dict("e",0);
1160	d_.sin =	in_dict("sin",1);
1161	d_.cos =	in_dict("cos",1);
1162	d_.tan =	in_dict("tan",1);
1163	d_.asin =	in_dict("asin",1);
1164	d_.acos =	in_dict("acos",1);
1165	d_.atan =	in_dict("atan",1);
1166	d_.exp =	in_dict("exp",1);
1167	d_.sqrt =	in_dict("sqrt",1);
1168	d_.ln =		in_dict("ln",1);
1169	d_.fix =	in_dict("fix",1);
1170	d_.float1 =	in_dict("float",1);
1171	d_.breal1 =	in_dict("breal",1);
1172	d_.breal_from_bounds = in_dict("breal_from_bounds",1);
1173	d_.breal_min = in_dict("breal_min",1);
1174	d_.breal_max = in_dict("breal_max",1);
1175	d_.round =	in_dict("round",1);
1176	d_.floor1 =	in_dict("floor",1);
1177	d_.rational1 =	in_dict("rational",1);
1178	d_.numerator1 =	in_dict("numerator",1);
1179	d_.denominator1 = in_dict("denominator",1);
1180
1181		/* term comparison */
1182	d_.unify = 	in_dict("=", 2);
1183	d_.identical = 	in_dict("==", 2);
1184	d_.less = 	in_dict("@<", 2);
1185	d_.lessq = 	in_dict("@=<", 2);
1186	d_.greater = 	in_dict("@>", 2);
1187	d_.greaterq = 	in_dict("@>=", 2);
1188
1189	d_.reset = 	in_dict("reset",0);
1190	d_.block =	in_dict("block", 3);
1191	d_.exit_block = in_dict("exit_block",1);
1192	d_.call = 	in_dict("call", 1);
1193	d_.call_body = 	in_dict("call_", 2);
1194	d_.metacall = 	in_dict("call", 3);
1195	d_.go = 	in_dict("go", 0);
1196	d_.break0 =	in_dict("break", 0);
1197	d_.local_break = in_dict("local_break", 0);
1198	d_.compile = 	in_dict("compile",1);
1199	d_.pcompile = 	in_dict("pcompile", 3);
1200	d_.error = 	in_dict("error",2);
1201	d_.syserror = 	in_dict("syserror", 4);
1202	d_.user = 	in_dict("user", 0);
1203	d_.true0 = 	in_dict("true", 0);
1204	d_.default0 = 	in_dict("default", 0);
1205	d_.read = 	in_dict("read",0);
1206	d_.write = 	in_dict("write",0);
1207	d_.update =	in_dict("update",0);
1208	d_.append =	in_dict("append", 0);
1209	d_.string =	in_dict("string", 1);
1210	d_.input = 	in_dict("input",0);
1211	d_.output = 	in_dict("output",0);
1212	d_.err = 	in_dict("error",0);
1213	d_.answer = 	in_dict("answer",0);
1214	d_.dummy_call =	in_dict("dummy_call",0);
1215	d_.no_err_handler =	in_dict("no_err_handler",2);
1216	d_.exit_postponed =	in_dict("exit_postponed",0);
1217	d_.error_handler =	in_dict("error_handler",2);
1218	d_.call_explicit =	in_dict("call_explicit",2);
1219	d_.garbage_collect_dictionary = in_dict("garbage_collect_dictionary",0);
1220	d_.throw1	= in_dict("throw",1);
1221
1222	d_.hang =	in_dict("hang",0);
1223	d_.nohang =	in_dict("nohang",0);
1224
1225	d_.warning_output = 	in_dict("warning_output",0);
1226	d_.log_output = 	in_dict("log_output",0);
1227	d_.user_input = 	in_dict("user_input",0);
1228	d_.user_output = 	in_dict("user_output",0);
1229	d_.user_error = 	in_dict("user_error",0);
1230	d_.null = 		in_dict("null", 0);
1231	d_.flush = 		in_dict("flush",0);
1232	d_.emulate = 		in_dict("Emulate",0);
1233	d_.abort = 		in_dict("abort",0);
1234	d_.eerrno =		in_dict("sys_errno", 0);
1235	d_.cprolog = 		in_dict("cprolog", 0);
1236	d_.bsi = 		in_dict("bsi", 0);
1237	d_.quintus = 		in_dict("quintus", 0);
1238	d_.sicstus = 		in_dict("sicstus", 0);
1239	d_.var = 		in_dict("var", 1);
1240	d_.nonground = 		in_dict("nonground", 1);
1241	d_.ground = 		in_dict("ground", 1);
1242	d_.on =			in_dict("on", 0);
1243	d_.off =		in_dict("off", 0);
1244	d_.prolog =		in_dict("prolog", 0);
1245	d_.system =		in_dict("system", 0);
1246	d_.built_in =		in_dict("built_in", 0);
1247
1248		/* assert */
1249	d_.clause =	in_dict("clause", 3);
1250
1251	d_.halt = 	in_dict("halt",0);
1252	d_.halt0 = 	in_dict("halt0",0);
1253	d_.debugger =	in_dict("debugger", 0);
1254
1255		/* declarations */
1256	d_.dynamic = 	in_dict("dynamic",1);
1257	d_.abolish = 	in_dict("abolish",1);
1258	d_.mode = 	in_dict("mode",1);
1259	d_.delay =	in_dict("delay", 1);
1260	d_.if2 =		in_dict("if", 2);
1261	d_.local = 	in_dict("local",1);
1262	d_.global = 	in_dict("global",1);
1263	d_.export1 = 	in_dict("export",1);
1264	d_.import = 	in_dict("import",1);
1265	d_.from = 	in_dict("from",2);
1266	d_.module1 = 	in_dict("module", 1);
1267	d_.module_directive = 	in_dict("module_directive", 4);
1268
1269		/* module names */
1270	d_.default_module =	in_dict(ec_options.default_module, 0);
1271	d_.eclipse_home =	in_dict(ec_eclipse_home, 0);
1272	d_.kernel_sepia = in_dict("sepia_kernel", 0);
1273	d_.cn =		in_dict("cn", 0);
1274
1275	       /* operators */
1276	d_.local0	= in_dict("local", 0);
1277	d_.global0	= in_dict("global", 0);
1278
1279		/* debugger */
1280	d_.sepia =		in_dict("sepia", 0);
1281	d_.macro = 		in_dict("macro", 0);
1282	d_.skip = 		in_dict("skip", 0);
1283	d_.spy = 		in_dict("spy", 0);
1284	d_.leash = 		in_dict("leash", 0);
1285	d_.command = 		in_dict("command", 0);
1286	d_.ellipsis =		in_dict("...",0);
1287
1288		/* modes */
1289	d_.plus0 =		in_dict("+", 0);
1290	d_.plusplus =		in_dict("++", 0);
1291	d_.minus0 =		in_dict("-", 0);
1292	d_.question =		in_dict("?", 0);
1293
1294        d_.unify0 = in_dict("=", 0);
1295        d_.stop = in_dict("stop", 0);
1296        d_.print = in_dict("print", 0);
1297        d_.notrace = in_dict("notrace", 0);
1298        d_.trace = in_dict("trace", 0);
1299        d_.trace_frame = in_dict("tf", TF_ARITY);
1300        d_.debug = in_dict("debug", 0);
1301        d_.nodebug = in_dict("nodebug", 0);
1302        d_.global_trail_overflow = in_dict("global_trail_overflow", 0);
1303        d_.local_control_overflow = in_dict("local_control_overflow", 0);
1304
1305	d_.at2 = in_dict("@", 2);
1306	d_.lock = in_dict("lock", 1);
1307	d_.localb = in_dict("local_", 2);
1308	d_.globalb = in_dict("global_", 2);
1309	d_.exportb = in_dict("export_", 2);
1310	d_.import_fromb = in_dict("import_from_", 3);
1311	d_.woken = in_dict("woken", WL_ARITY);
1312	d_.write1 = in_dict("write", 1);
1313	d_.write2 = in_dict("write", 2);
1314	d_.writeq1 = in_dict("writeq", 1);
1315	d_.writeq2 = in_dict("writeq", 2);
1316	d_.read1 = in_dict("read", 1);
1317	d_.read2 = in_dict("read", 2);
1318	d_.define_global_macro3 = in_dict("define_global_macro",3);
1319	d_.define_local_macro3 = in_dict("define_local_macro",3);
1320	d_.erase_macro1 = in_dict("erase_macro",1);
1321	d_.trans_term = in_dict("trans_term",2);
1322
1323        d_.var0 = in_dict("var", 0);
1324        d_.atom0 = in_dict("atom", 0);
1325        d_.string0 = in_dict("string", 0);
1326	d_.float0 = in_dict("float",0);
1327        d_.integer0 = in_dict("integer", 0);
1328        d_.double0 = in_dict("double", 0);
1329        d_.rational0 = in_dict("rational", 0);
1330        d_.real0 = in_dict("real", 0);
1331	d_.byte = in_dict("byte", 0);
1332        d_.compound0 = in_dict("compound", 0);
1333	d_.universally_quantified = in_dict("universally_quantified", 0);
1334	d_.suspending = in_dict("suspending", 0);
1335	d_.suspend_attr = in_dict("suspend", 3);
1336	d_.constrained = in_dict("constrained", 0);
1337	d_.meta0 = in_dict("meta", 0);
1338	d_.free = in_dict("free",0);
1339
1340	d_.stdin0 = in_dict("stdin", 0);
1341	d_.stdout0 = in_dict("stdout", 0);
1342	d_.stderr0 = in_dict("stderr", 0);
1343
1344	/* macros */
1345	d_.top_only = in_dict("top_only", 0);
1346	d_.protect_arg = in_dict("protect_arg", 0);
1347	d_.clause0 = in_dict("clause", 0);
1348	d_.goal = in_dict("goal", 0);
1349
1350	d_.with2 =		in_dict("with", 2);
1351	d_.with_attributes2 =	in_dict("with attributes", 2);
1352	d_.apply2 =		in_dict("apply", 2);
1353
1354	d_.some = in_dict("some", 0);
1355	d_.all = in_dict("all", 0);
1356
1357	/* compiler */
1358	d_.compile_stream = in_dict("compile_stream", 1);
1359	d_.system_debug = in_dict("system_debug", 0);
1360	d_.file_query = in_dict("file_query_body", 3);
1361	d_.external = in_dict("external", 0);
1362	d_.term = in_dict("term", 0);
1363	d_.not_not = in_dict("not not", 1);
1364	d_.softcut = in_dict("*->", 2);
1365	d_.functor = in_dict("functor", 3);
1366	d_.integer = in_dict("integer", 1);
1367        d_.double1 = in_dict("double", 1);
1368	d_.atom = in_dict("atom", 1);
1369	d_.atomic = in_dict("atomic", 1);
1370	d_.nonvar = in_dict("nonvar", 1);
1371	d_.meta = in_dict("meta", 1);
1372	d_.number = in_dict("number", 1);
1373	d_.real = in_dict("real", 1);
1374	d_.breal = in_dict("breal", 1);
1375	d_.compound = in_dict("compound", 1);
1376	d_.free1 = in_dict("free", 1);
1377	d_.bignum = in_dict("bignum", 1);
1378	d_.is_event = in_dict("is_event", 1);
1379	d_.is_handle = in_dict("is_handle", 1);
1380	d_.is_list = in_dict("is_list", 1);
1381	d_.is_suspension = in_dict("is_suspension", 1);
1382	d_.pragma = in_dict("pragma", 1);
1383	d_.make_suspension = in_dict("make_suspension", 3);
1384	d_.wake = in_dict("wake", 0);
1385	d_.state = in_dict("state", 0);
1386	d_.priority = in_dict("priority", 0);
1387	d_.invoc = in_dict("invoc", 0);
1388	d_.module0 = in_dict("module", 0);
1389}
1390
1391
1392
1393/*--------------------------------------------------------------------
1394 * Constant table for storing non-simple ground constants
1395 * other than strings and atoms.
1396 * Entries are made
1397 *	- for constants occurring in code
1398 *	- explicitly by calling canonical_copy/2
1399 * There is currently no garbage collection on this table.
1400 * Terms in this table are made persistent, which means that pointers
1401 * to these terms (and their subterms) can always be shared and never
1402 * need to be copied again. This is indicated by the PERSISTENT bit
1403 * being set in pointers (in)to these persistent heap term.
1404 * Also, DIDs within these terms are marked as permanent,
1405 * so the dictionary gc does not need to scan this table.
1406 *--------------------------------------------------------------------*/
1407
1408#define CONSTANT_TABLE_MIN_SIZE		256
1409#define CONSTANT_TABLE_MAX_SIZE		1048576
1410#define CONSTANT_TABLE_EXPAND_FACTOR	2
1411
1412
1413typedef struct constant_entry {			/* one table entry */
1414    	pword			value;
1415    	uword			hash;
1416    	struct constant_entry	*next;
1417} t_constant_entry;
1418
1419static struct constant_table {			/* the whole table */
1420	uword			size;
1421	uword			nentries;
1422	uword			nreuse;
1423	t_constant_entry	**htable;
1424} *constant_table;
1425
1426
1427/*
1428 * Initialise the table
1429 */
1430
1431static void
1432_constant_table_init(int flags)
1433{
1434    if (flags & INIT_SHARED)
1435    {
1436	uword i;
1437	constant_table = (struct constant_table *) hg_alloc_size(sizeof(struct constant_table));
1438	shared_data->constant_table = (void_ptr) constant_table;
1439	constant_table->size = CONSTANT_TABLE_MIN_SIZE;
1440	constant_table->nentries = 0;
1441	constant_table->nreuse = 0;
1442	constant_table->htable = (t_constant_entry **)
1443		hg_alloc_size(constant_table->size * sizeof(t_constant_entry *));
1444	for (i=0; i< constant_table->size; i++)
1445	    constant_table->htable[i] = NULL;
1446    }
1447    if (flags & INIT_PRIVATE)
1448    {
1449	constant_table = (struct constant_table *) shared_data->constant_table;
1450    }
1451}
1452
1453
1454/*
1455 * Grow the table
1456 */
1457
1458static void
1459_constant_table_expand(struct constant_table *table)
1460{
1461    uword new_size = table->size * CONSTANT_TABLE_EXPAND_FACTOR;
1462    t_constant_entry **new_htable;
1463    uword i;
1464
1465    /* make and initialize a larger table */
1466    new_htable = (t_constant_entry **)
1467	    hg_alloc_size(new_size * sizeof(t_constant_entry *));
1468    for (i = 0; i < new_size; ++i)
1469    {
1470	new_htable[i] = NULL;
1471    }
1472
1473    /* redistribute the entries from the old table */
1474    for (i = 0; i < table->size; ++i)
1475    {
1476	t_constant_entry *elem;
1477	for(elem = table->htable[i]; elem; )
1478	{
1479	    t_constant_entry **new_slot = &new_htable[elem->hash % new_size];
1480	    t_constant_entry *next_elem = elem->next;
1481	    elem->next = *new_slot;
1482	    *new_slot = elem;
1483	    elem = next_elem;
1484	}
1485    }
1486
1487    /* free the old table */
1488    hg_free_size(table->htable, table->size * sizeof(t_constant_entry *));
1489
1490    /* assign the new one */
1491    table->htable = new_htable;
1492    table->size = new_size;
1493}
1494
1495
1496/*
1497 * Lookup/Enter
1498 *
1499 * PSUCCEED:		*presult contains the tabled copy of (v,t)
1500 *			    or (v,t) itself in case of simple terms
1501 * PFAIL:		the term cannot be tabled in a meaningful way,
1502 *			    e.g. because it is a bounded real
1503 *			    (v,t) itself is returned as result anyway
1504 * INSTANTIATION_FAULT:	the term was nonground
1505 * other:		a serious problem occurred
1506 */
1507
1508int
1509ec_constant_table_enter(value v, type t, pword *presult)
1510{
1511    int res = PSUCCEED;		/* initialise for ec_term_hash() */
1512    t_constant_entry *pelem;
1513    t_constant_entry **pslot;
1514    uword hash;
1515
1516    /* no point tabling simple (single-pword) things */
1517    if (IsSimple(t))
1518    {
1519	presult->val.all = v.all;
1520	presult->tag.all = t.all;
1521	return PSUCCEED;
1522    }
1523
1524    /*
1525     * Bounded reals cannot be shared (when nonzero width)
1526     * because they must not arithmetically compare equal!
1527     */
1528    if (IsInterval(t) &&  (IvlLwb(v.ptr) < IvlUpb(v.ptr)))
1529    {
1530	presult->val.all = v.all;
1531	presult->tag.all = t.all;
1532	return PFAIL;
1533    }
1534
1535    /* compute hash value */
1536    hash = ec_term_hash(v, t, MAX_U_WORD, &res);
1537    if (res != PSUCCEED)
1538    {
1539	return res;
1540    }
1541
1542    /* lookup the entry */
1543    pslot = &constant_table->htable[hash % constant_table->size];
1544    for(pelem = *pslot; pelem; pslot = &pelem->next, pelem = *pslot)
1545    {
1546	if (pelem->hash == hash
1547	 && ec_compare_terms(v, t, pelem->value.val, pelem->value.tag) == 0
1548	 )
1549	{
1550	    break;
1551	}
1552    }
1553
1554    if (!pelem)
1555    {
1556	/* insert new entry */
1557	pelem = (t_constant_entry *) hg_alloc_size(sizeof(t_constant_entry));
1558	if ((res = create_heapterm(&pelem->value, v, t)) != PSUCCEED)
1559	{
1560	    hg_free_size(pelem, sizeof(t_constant_entry));
1561	    return res;
1562	}
1563
1564	/*
1565	 * Mark it as a persistent heap term.
1566	 * This will also make any DIDs within the term permanent,
1567	 * so dictionary gc does not need to mark persistent terms.
1568	 */
1569	make_heapterm_persistent(&pelem->value);
1570
1571	pelem->hash = hash;
1572	pelem->next = *pslot;
1573	*pslot = pelem;
1574	++constant_table->nentries;
1575
1576	/* expand table if too full */
1577	if (constant_table->nentries > constant_table->size
1578	 && constant_table->size < CONSTANT_TABLE_MAX_SIZE)
1579	{
1580	    _constant_table_expand(constant_table);
1581	}
1582
1583    }
1584    else
1585    {
1586	++constant_table->nreuse;
1587    }
1588
1589    *presult = pelem->value;
1590    return PSUCCEED;
1591}
1592
1593
1594#ifdef PRINTAM
1595pr_constant_table(void)
1596{
1597    uword entry_count = 0;
1598    uword max_chain = 0;
1599    uword used_slots = 0;
1600    uword i;
1601
1602    for(i = 0; i < constant_table->size; ++i)
1603    {
1604	uword chain_length = 0;
1605	t_constant_entry *pelem = constant_table->htable[i];
1606	if (pelem)
1607	    ++used_slots;
1608	for(; pelem; pelem = pelem->next)
1609	{
1610	    writeq_term(pelem->value.val.all, pelem->value.tag.all);
1611	    ++chain_length;
1612	}
1613	entry_count += chain_length;
1614	if (chain_length > max_chain)
1615	    max_chain = chain_length;
1616    }
1617
1618    p_fprintf(current_output_, "GROUND CONSTANT TABLE\n");
1619    p_fprintf(current_output_, "size      = %d\n", constant_table->size);
1620    p_fprintf(current_output_, "entries   = %d\n", constant_table->nentries);
1621    p_fprintf(current_output_, "reuse     = %d\n", constant_table->nreuse);
1622    p_fprintf(current_output_, "max chain = %d\n", max_chain);
1623    p_fprintf(current_output_, "avg chain = %f\n", ((double) entry_count)/used_slots);
1624    if (entry_count != constant_table->nentries)
1625	p_fprintf(current_output_, "!!! Deviating entry count %d\n", entry_count);
1626    Succeed_;
1627}
1628#endif
1629