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) 1997-2006 Cisco Systems, Inc.  All Rights Reserved.
18 *
19 * Contributor(s):
20 *
21 * END LICENSE BLOCK */
22
23/*
24 * ECLiPSe Kernel Module
25 *
26 * $Id: handle.c,v 1.2 2012/02/11 17:09:31 jschimpf Exp $
27 *
28 * Author:	Stefano Novello, IC-Parc
29 *		Joachim Schimpf, IC-Parc
30 *
31 * Contents:	Module to deal with generic handles
32 *		from Prolog to external objects
33 *
34 * Description:
35 *
36 * |------------|
37 * | THANDLE    |                         |-----------|
38 * |	   --------+                      |           |
39 * |------------|  |   |-----------|      |           |
40 *      ...        |   | TPTR      |      |  <data>   |      |----------|
41 *                 |   |       ---------> |           |      |  ....    |
42 * |------------|  |   | - - - - - |      |-----------|      |  mark()  |
43 * | THANDLE    |  +-> | TEXTERN   |                         |  copy()  |
44 * |	   ----------> |       ----------------------------> |  free()  |
45 * |------------|      |-----------|                         |----------|
46 *                     unique anchor         data             type desc
47 *                      on global
48 *
49 * A module that uses handles will associate a data structure with the
50 * handle, as well as a type descriptor (method table).
51 *
52 * Handles to external data are implemented using a unique "anchor"
53 * on the global stack. The Prolog code references the anchor via
54 * THANDLE pointers.
55 *
56 * The anchor has two components:
57 *
58 *	t_ext_type *ExternalClass(p)	points to a method table (class)
59 *	t_ext_ptr   ExternalData(p)	points to the external data
60 *
61 * The ExternalData() field can point to arbitrary external data.
62 * The ExternalClass() field points to a user-supplied descriptor
63 * which is a table of methods for standard operations on the data.
64 *
65 * When the last THANDLE referring to an anchor disappears it will
66 * eventually be garbage collected.  When the anchor disappears,
67 * the external object's free() method gets invoked.
68 *
69 * If the object is manually freed before the anchor disappears, the
70 * anchor becomes stale. This is marked by overwriting ExternalData()
71 * with NULL. Since the anchor is never copied, all accesses via
72 * any THANDLE will see that this handle is stale.
73 *
74 * If an anchor gets physically copied, e.g. by setval, record, etc,
75 * the copy() or remote_copy() method is used to inform the external object.
76 *
77 * Other methods for comparing, printing and gc can be specified.
78 */
79
80#include "config.h"
81#include "sepia.h"
82#include "types.h"
83#include "embed.h"
84#include "mem.h"
85#include "error.h"
86#include "ec_io.h"
87#include "dict.h"
88#include "database.h"
89#include "emu_export.h"
90
91
92/*
93 * Call cleanup method (if any) and mark handle as stale (of not already)
94 * (pw)[1].val.ptr is ExternalData(pw) expansion to satisfy gcc-4.x
95 */
96#define AnchorFree(pw) { \
97	if (ExternalData(pw)) { \
98	    if (ExternalClass(pw)->free) \
99		ExternalClass(pw)->free(ExternalData(pw)); \
100	    (pw)[1].val.ptr = (pword *) NULL; \
101	} \
102}
103
104
105/*
106 * Function to free the handle on untrailing
107 */
108/*ARGSUSED*/
109static void
110_handle_cleanup(pword *pw,
111	word *pdata,
112	int size,	/* unused (untrail calling convention) */
113	int flags)	/* unused (untrail calling convention) */
114{
115	if (!pw || DifferTypeC(pw->tag, TEXTERN))
116	{
117	    p_fprintf(current_err_, "ECLiPSe: handle_cleanup: invalid handle\n");
118	    return;
119	}
120	AnchorFree(pw);
121}
122
123
124/*
125 * Construct a new handle
126 */
127pword Winapi
128ec_handle(const t_ext_type *class, const t_ext_ptr data)
129{
130	pword handle;
131	pword *pw;
132
133	/* push global stack anchor */
134	pw = TG;
135	TG += HANDLE_ANCHOR_SIZE;
136	Check_Gc;
137	pw[0].tag.kernel = TEXTERN;
138	pw[0].val.ptr = (pword *) class;
139	pw[1].tag.kernel = TPTR;
140	pw[1].val.ptr = (pword *) data;
141
142	/* Make handle */
143	handle.tag.kernel = THANDLE;
144	handle.val.ptr = pw;
145
146	/* Trail cleanup */
147	ec_trail_undo(_handle_cleanup, pw, NULL, NULL, 0, 0);
148
149	return handle;
150}
151
152
153/*
154 * Get the data pointer from a handle (expect the given type)
155 */
156int Winapi
157ec_get_handle(const pword handle, const t_ext_type *cl, t_ext_ptr *data)
158{
159	const pword * pw = &handle;
160	Dereference_(pw);
161	Get_Typed_Object(pw->val, pw->tag, cl, *data);
162	Succeed_;
163}
164
165
166/*
167 * Free the handle eagerly (expect the given type)
168 */
169int Winapi
170ec_free_handle(const pword handle, const t_ext_type *cl)
171{
172	const pword * pw = &handle;
173	Dereference_(pw);
174	Check_Typed_Object_Handle(pw->val,pw->tag,(t_ext_type *) cl);
175	AnchorFree(pw->val.ptr);
176	Succeed_;
177}
178
179
180/*
181 * Free the handle eagerly (generic)
182 */
183int
184p_handle_free(value v_handle, type t_handle)
185{
186	Check_Type(t_handle, THANDLE);
187	Check_Type(v_handle.ptr->tag, TEXTERN);
188	AnchorFree(v_handle.ptr);
189	Succeed_;
190}
191
192
193/*
194 * Arrange for the handle to get freed on cut
195 */
196int
197p_handle_free_on_cut(value v_handle, type t_handle)
198{
199	Check_Type(t_handle, THANDLE);
200	Check_Type(v_handle.ptr->tag, TEXTERN);
201
202	schedule_cut_fail_action((void (*)(value,type)) p_handle_free,v_handle,t_handle);
203	Succeed_;
204}
205
206
207/*
208 * Copy an anchor
209 */
210void
211handle_copy_anchor(
212	pword *from,	/* a heap or global stack location */
213	pword *to,	/* a heap or global stack location */
214	int trail)	/* should be true if *to is a global stack location */
215{
216	to[0] = from[0];
217	if (ExternalClass(from)->copy && ExternalData(from))
218	    to[1].val.ptr = (pword *) ExternalClass(from)->copy(ExternalData(from));
219	else
220	    to[1].val.ptr = (pword *) ExternalData(from);
221	to[1].tag.kernel = from[1].tag.kernel;
222
223	/* Trail cleanup */
224	if (trail)
225	    ec_trail_undo(_handle_cleanup, to, NULL, NULL, 0, 0);
226}
227
228