Commit f0f96dbdf08e5ba64fc33db0a9eff7d36b1f6111 - expel

tons more renaming to ubik Haldean Brown 3 years ago

89 changed file(s) with 10355 addition(s) and 10355 deletion(s). Raw diff Collapse all Expand all

-3

.gitignore less more

0		expelc/expelc
1		expelc/expeli
2		runexpel/runexpel
	0	ub/ubic
	1	ub/ubi
	2	ubik/ubik
3	3
4	4	dist
5	5	build

-1

Makefile.am less more

0		SUBDIRS = include libexpel expelc runexpel test/unit test/pyasm test/prog
	0	SUBDIRS = include libubik ub ubik test/unit test/pyasm test/prog

+28

-28

README less more

0		Architecture of the Expel Runtime ======================================
	0	Architecture of the Ubik Runtime =======================================
1	1	Haldean Brown First draft: Nov 2015
2	2	Last updated: Mar 2016
3	3
4	4
5	5	This document attempts to fully explain the implementation and behavior
6		of the Expel runtime. When the code and this document disagree, the code
	6	of the Ubik runtime. When the code and this document disagree, the code
7	7	is incorrect; on the other hand, don't trust anything in this document.
8	8
9	9
10	10	Structure of the project -----------------------------------------------
11	11
12	12	The project itself is divided into a few software components. By far the
13		most interesting is libexpel, which is the shared library that contains
14		the entirety of the Expel runtime. There's runexpel, which is a simple
15		thing that uses libexpel to load and run Expel bytecode. There's expelc
16		and expeli, which are a compiler and interpreter, respectively; both are
17		thin wrappers around libexpel, which contains the actual compiler
	13	most interesting is libubik, which is the shared library that contains
	14	the entirety of the Ubik runtime. There's runubik, which is a simple
	15	thing that uses libubik to load and run Ubik bytecode. There's ubikc
	16	and ubiki, which are a compiler and interpreter, respectively; both are
	17	thin wrappers around libubik, which contains the actual compiler
18	18	implementation. And then there's pyasm, which is a hilarious "assembler"
19	19	written as a Python DSL; pyasm will be gone the moment there's a working
20		Expel compiler, but for now, with my focus on the runtime, pyasm is here
	20	Ubik compiler, but for now, with my focus on the runtime, pyasm is here
21	21	to stay.
22	22
23	23	There are unit tests and "integration tests"; unit tests are haphazard

25	25	test/pyasm/*.xlpy) are pretty comprehensive. You can run all of the
26	26	tests by running `make check`.
27	27
28		To build and test expel, run the following commands:
	28	To build and test ubik, run the following commands:
29	29
30	30	./configure
31	31	make check
32	32
33		If the configure script is not present (i.e., you got Expel from git
	33	If the configure script is not present (i.e., you got Ubik from git
34	34	instead of from a tarball), you will need to run:
35	35
36	36	autoreconf --install
37	37
38	38	Before you run anything else. When you're done with all that, the
39		compiler will be present at expelc/expelc, the interpreter will be at
40		expelc/expeli and the runtime will be at runexpel/runexpel. To install
	39	compiler will be present at ubikc/ubikc, the interpreter will be at
	40	ubikc/ubiki and the runtime will be at runubik/runubik. To install
41	41	these to your system path (along with the headers and static library),
42	42	use:
43	43

48	48	It does some simple checks to make sure that you're not doing anything
49	49	dumb.
50	50
51		For completeness, building Expel requires:
	51	For completeness, building Ubik requires:
52	52
53	53	- GCC 4.9 or later (it's possible that the build works with other
54	54	versions of GCC and with clang, but they're untested)

56	56	- Flex 2.6 or later
57	57	- GNU autoconf 2.69 or later
58	58
59		Expel has no runtime dependencies outside of libc. The rest of this
	59	Ubik has no runtime dependencies outside of libc. The rest of this
60	60	document is more interesting, I promise.
61	61
62	62
63	63	Runtime representations ------------------------------------------------
64	64
65		Expel is based on a simple primitive: unbalanced binary trees of 64-bit
	65	Ubik is based on a simple primitive: unbalanced binary trees of 64-bit
66	66	values (called "words"). Everything is expressed in this way, from
67	67	integers to types to functions; this homogeneity of data representation
68	68	allows us to simplify otherwise-complicated tasks and has a satisfying
69	69	purity. Note that the in-memory representation is extremely close to the
70		on-disk representation of compiled Expel programs.
	70	on-disk representation of compiled Ubik programs.
71	71
72	72	Each node in the tree has a left value, a right value, and a tag. Each
73	73	value can be one of two things: a pointer to another node or a word; the

109	109	they are identified only by an integer constant; derived types (quite
110	110	predictably) require quite a bit more information about the type itself.
111	111
112		The base types of Expel are a few flavors of integer, lists and tuples.
	112	The base types of Ubik are a few flavors of integer, lists and tuples.
113	113	Each of these has a base type code and comes with a tree encoding. The
114	114	full list of base type codes is:
115	115

170	170	appear on the left of a typed value is a type descriptor value, and
171	171	could appear on the right of a type node.
172	172
173		A resource identifier is how all entities within the expel runtime are
	173	A resource identifier is how all entities within the ubik runtime are
174	174	identified. Resources all have a name, author, version and scope; all of
175	175	these are encoded in the URI tree. The left of a URI tree is the
176	176	constant word `uri`, and the right is a cons-cell list, where the first

184	184
185	185	Building logic ---------------------------------------------------------
186	186
187		Logic in Expel is encoded in a directed acyclic graph of computations
	187	Logic in Ubik is encoded in a directed acyclic graph of computations
188	188	(DAGC); nodes in this graph then reference values stored as trees. There
189	189	are four kinds of nodes in a DAGC:
190	190

213	213	evaluating them just calls the associated native
214	214	code block. That code block then fills in the result
215	215	of the compuation over the graph on the native node.
216		Reading native nodes in from expel bytecode is not
	216	Reading native nodes in from ubik bytecode is not
217	217	supported; this is only a construct used internally
218	218	in the runtime.
219	219	`ref` This node has the value of another node in the

230	230	terminal nodes is found, and all nodes in that set are evaluated in
231	231	turn. This gives the result for the DAGC. Once evaluated, the DAGC is
232	232	semantically and computationally equivalent to a single value; this is
233		possible because all functions in Expel are idempotent, and thus a
	233	possible because all functions in Ubik are idempotent, and thus a
234	234	zero-arity function is equivalent to a value.
235	235
236	236	Logic is then built up by creating a number of graphs and referencing

239	239	completed. Once all required input nodes have been completed, the DAGC
240	240	can be evaluated.
241	241
242		An expel bytecode blob contains some number of graphs; the various
	242	An ubik bytecode blob contains some number of graphs; the various
243	243	graphs can reference each other, and in general their ordering in the
244	244	bytecode does not matter. There is only one exception: when evaluating a
245	245	bytecode blob, the first graph is considered to represent the desired

249	249
250	250	Encoding in-flight and at-rest -----------------------------------------
251	251
252		Expel bytecode has a single binary storage format that is used for
	252	Ubik bytecode has a single binary storage format that is used for
253	253	network operations and for on-disk storage. The format begins with a
254	254	header, and then contains a number of encoded graphs.
255	255

368	368	Byte index Field
369	369	0-7 Node index of referrent node
370	370
371		Expel bytecode blobs may have arbitrary data following the data encoded
	371	Ubik bytecode blobs may have arbitrary data following the data encoded
372	372	by the standard; conforming parsers will ignore the data that follows
373	373	the encoded graphs. This is provided as a means for tools to attach
374	374	metadata onto the end of the bytecode if so desired.
375	375
376	376	Compilation ------------------------------------------------------------
377	377
378		The compiler for Expel is distributed as part of the Expel library; a
	378	The compiler for Ubik is distributed as part of the Ubik library; a
379	379	compiler executable can be built using:
380	380
381		$ make dist/expelc
382		$ dist/expelc path/to/file.xl out.xlb
	381	$ make dist/ubic
	382	$ dist/ubic path/to/file.xl out.xlb
383	383
384	384	The process of creating an executable is divided into two phases, not
385	385	unlike compilation for C and other native languages: compilation and

390	390	the details away from the user, but they still get the advantage of
391	391	fast, incremental builds.
392	392
393		Compilation begins by loading the given Expel file and generating code
	393	Compilation begins by loading the given Ubik file and generating code
394	394	for the module (see below). In general, at the end of this process there
395	395	are still unresolved references; we collect all of the imports that
396	396	provide those references, and find the files that provide the requisite

-4

configure.ac less more

1	1	# Process this file with autoconf to produce a configure script.
2	2
3	3	AC_PREREQ([2.69])
4		AC_INIT([expel], [0.1], [expel@haldean.org])
	4	AC_INIT([ubik], [0.1], [ubik@haldean.org])
5	5
6	6	# Use automake to compile Makefile.ac to Makefile.in
7	7	AM_INIT_AUTOMAKE([foreign -Wall -Werror])
8	8
9	9	# Make sure we're running in the right directory
10		AC_CONFIG_SRCDIR([libexpel/rt.c])
	10	AC_CONFIG_SRCDIR([libubik/rt.c])
11	11
12	12	AC_CONFIG_HEADERS([config.h])
13	13

44	44	AC_FUNC_REALLOC
45	45	AC_CHECK_FUNCS([backtrace backtrace_symbols_fd bzero clock_gettime fmemopen getcwd memmove memset strdup])
46	46
47		AC_CONFIG_FILES([Makefile include/Makefile expelc/Makefile libexpel/Makefile
48		runexpel/Makefile test/prog/Makefile test/unit/Makefile
	47	AC_CONFIG_FILES([Makefile include/Makefile ub/Makefile libubik/Makefile
	48	ubik/Makefile test/prog/Makefile test/unit/Makefile
49	49	test/pyasm/Makefile])
50	50	AC_OUTPUT

-6

~~expelc/Makefile.am~~ less more

0		include ../res/build-config.am
1
2		bin_PROGRAMS = expelc expeli
3
4		expelc_LDADD = ../libexpel/libexpel.a
5		expeli_LDADD = ../libexpel/libexpel.a

-103

~~expelc/expelc.c~~ less more

0		/*
1		* expelc.c: expel compiler
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19
20		#include <stdio.h>
21		#include <stdlib.h>
22		#include <string.h>
23
24		#include "ubik/compile.h"
25		#include "ubik/env.h"
26		#include "ubik/ubik.h"
27		#include "ubik/parse.h"
28		#include "ubik/schedule.h"
29		#include "ubik/value.h"
30
31		#define c(x) \
32		do { \
33		err = x; \
34		if (err != OK) \
35		{ \
36		char *expl = xl_error_explain(err); \
37		printf("%s\n", expl); \
38		free(err); free(expl); \
39		goto teardown; \
40		} } while(0)
41
42		void
43		usage()
44		{
45		printf("expelc compiles expel source code to bytecode\n");
46		printf("usage: expelc SOURCE OUT\n");
47		}
48
49		int
50		main(int argc, char *argv[])
51		{
52		struct xl_dagc **graphs = NULL;
53		struct xl_stream in, out;
54		size_t i;
55		size_t n_graphs = 0;
56		xl_error err;
57		struct xl_compilation_env env;
58		char *source_name;
59
60		if (argc != 3)
61		{
62		usage();
63		return EXIT_FAILURE;
64		}
65
66		c(xl_start());
67
68		source_name = argv[1];
69		if (xl_stream_rfile(&in, source_name) != OK)
70		{
71		printf("could not open %s for reading\n", argv[1]);
72		return EXIT_FAILURE;
73		}
74		if (xl_stream_wfile(&out, argv[2]) != OK)
75		{
76		printf("could not open %s for writing\n", argv[2]);
77		return EXIT_FAILURE;
78		}
79
80		c(xl_compile_env_default(&env));
81		c(xl_compile(&graphs, &n_graphs, source_name, &in, &env));
82		c(xl_compile_env_free(&env));
83		c(xl_save(&out, graphs, n_graphs));
84
85		teardown:
86		xl_stream_close(&in);
87		xl_stream_close(&out);
88
89		for (i = 0; i < n_graphs; i++)
90		{
91		if (xl_release(graphs[i]) != OK)
92		printf("error when releasing graph\n");
93		}
94
95		free(graphs);
96
97		if (xl_teardown() != OK)
98		printf("error when tearing down runtime\n");
99
100		return err == OK ? EXIT_SUCCESS : EXIT_FAILURE;
101		}
102

-149

~~expelc/expeli.c~~ less more

0		/*
1		* expeli.c: expel interpreter
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19
20		#include <stdio.h>
21		#include <stdlib.h>
22		#include <string.h>
23
24		#include "ubik/ast.h"
25		#include "ubik/compile.h"
26		#include "ubik/env.h"
27		#include "ubik/ubik.h"
28		#include "ubik/parse.h"
29		#include "ubik/resolve.h"
30		#include "ubik/schedule.h"
31		#include "ubik/value.h"
32
33		#define c(x) \
34		do { \
35		err = x; \
36		if (err != OK) \
37		{ \
38		char *expl = xl_error_explain(err); \
39		printf("%s\n", expl); \
40		free(err); free(expl); \
41		goto teardown; \
42		} } while(0)
43
44		int
45		main(int argc, char *argv[])
46		{
47		struct xl_ast *ast;
48		struct xl_dagc **graphs;
49		struct xl_stream sstdin;
50		struct xl_env env = {0};
51		struct xl_scheduler *s;
52		local(resolve_context) struct xl_resolve_context rctx = {0};
53		size_t n_graphs;
54		size_t i;
55		xl_error err;
56		xl_error teardown_err;
57		xl_error parse_err;
58		char *buf;
59
60		ast = NULL;
61		graphs = NULL;
62		s = NULL;
63
64		c(xl_start());
65
66		c(xl_stream_rfilep(&sstdin, stdin));
67
68		parse_err = xl_parse(&ast, "(stdin)", &sstdin);
69		if (parse_err == OK)
70		parse_err = xl_resolve(ast, "(stdin)", &sstdin, &rctx);
71		if (argc > 1 && strcmp(argv[1], "emit-ast") == 0)
72		err = xl_ast_print(ast);
73		c(parse_err);
74		c(err);
75
76		c(xl_compile_ast(&graphs, &n_graphs, ast, NULL));
77
78		c(xl_env_init(&env));
79
80		c(xl_schedule_new(&s));
81		c(xl_schedule_push(s, graphs[0], &env, NULL));
82		c(xl_schedule_run(s));
83
84		teardown:
85		if (ast != NULL)
86		{
87		teardown_err = xl_ast_free(ast);
88		if (teardown_err != OK)
89		{
90		buf = xl_error_explain(teardown_err);
91		printf("error when freeing ast: %s\n", buf);
92		free(buf);
93		free(teardown_err);
94		}
95		}
96
97		if (s != NULL)
98		{
99		teardown_err = xl_schedule_free(s);
100		if (teardown_err != OK)
101		{
102		buf = xl_error_explain(teardown_err);
103		printf("error when freeing scheduler: %s\n", buf);
104		free(buf);
105		free(teardown_err);
106		}
107		free(s);
108		}
109
110		if (graphs != NULL)
111		{
112		for (i = 0; i < n_graphs; i++)
113		{
114		if (graphs[i] == NULL)
115		continue;
116		teardown_err = xl_release(graphs[i]);
117		if (teardown_err != OK)
118		{
119		buf = xl_error_explain(teardown_err);
120		printf("graph release failed: %s\n", buf);
121		free(buf);
122		free(teardown_err);
123		}
124		}
125		free(graphs);
126		}
127
128		teardown_err = xl_env_free(&env);
129		if (teardown_err != OK)
130		{
131		buf = xl_error_explain(teardown_err);
132		printf("error when freeing environment: %s\n", buf);
133		free(buf);
134		free(teardown_err);
135		}
136
137		teardown_err = xl_teardown();
138		if (teardown_err != OK)
139		{
140		buf = xl_error_explain(teardown_err);
141		printf("error when tearing down runtime: %s\n", buf);
142		free(buf);
143		free(teardown_err);
144		}
145
146		return err == OK ? EXIT_SUCCESS : EXIT_FAILURE;
147		}
148

-6

~~libexpel/.gitignore~~ less more

0		grammar.c
1		grammar.h
2		grammar.output
3		token.c
4		uri-value.h
5		humanize-poly.h

-10

~~libexpel/Makefile.am~~ less more

0		lib_LIBRARIES = libexpel.a
1		libexpel_a_SOURCES = store.c error.c uri.c gen.c timer.c eval.c load.c gc.c pointerset.c compile.c string.c schedule.c natives.c types.c print-ast.c value.c bdagc.c assert.c explain.c ast.c dagc.c parse.c util.c rt.c stream.c env.c token.l grammar.y uri-value.tree humanize-poly.tree vector.c resolve.c closure.c streamutil.c
2		BUILT_SOURCES = grammar.h uri-value.h humanize-poly.h
3
4		libexpel_a_CFLAGS = -std=c11 -Werror -Wall -Wextra -fno-strict-aliasing -rdynamic -Wswitch-enum -fPIC
5		libexpel_a_CPPFLAGS = -I$(top_srcdir)/include/ -D_GNU_SOURCE #-D_FORTIFY_SOURCE=2
6		AM_YFLAGS = -d --report=state -Wall -Werror
7
8		.tree.h:
9		$(PYTHON) ../res/buildtree/buildtree.py $< $@

-26

~~libexpel/assert.c~~ less more

0		/*
1		* assert.h: compile-conditional assertions
2		* Copyright (C) 2015, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include "ubik/assert.h"
20
21		int
22		break_on_assert()
23		{
24		return 0;
25		}

-404

~~libexpel/ast.c~~ less more

0		/*
1		* ast.c: in-memory ast representation
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include "ubik/assert.h"
20		#include "ubik/ast.h"
21
22		#include <stdlib.h>
23		#include <string.h>
24
25		#define check_alloc(x, nelem, contents) { \
26		(x) = calloc(nelem, sizeof(contents)); \
27		if ((x) == NULL) return xl_raise(ERR_NO_MEMORY, ""); }
28
29		/* Allocates a new AST. */
30		no_ignore xl_error
31		xl_ast_new(struct xl_ast **ast)
32		{
33		check_alloc(*ast, 1, struct xl_ast);
34		return OK;
35		}
36
37		no_ignore static xl_error
38		_free_atom(struct xl_ast_atom *atom)
39		{
40		switch (atom->atom_type)
41		{
42		case ATOM_NAME:
43		case ATOM_TYPE_NAME:
44		case ATOM_STRING:
45		free(atom->str);
46		break;
47
48		case ATOM_QUALIFIED:
49		free(atom->qualified.head);
50		free(atom->qualified.tail);
51
52		case ATOM_NUM:
53		case ATOM_INT:
54		break;
55
56		default:
57		return xl_raise(ERR_BAD_TYPE, "unknown atom type in free");
58		}
59
60		free(atom);
61		return OK;
62		}
63
64		no_ignore static xl_error
65		_free_arg_list(struct xl_ast_arg_list *arg_list)
66		{
67		struct xl_ast_arg_list *next;
68
69		while (arg_list != NULL)
70		{
71		next = arg_list->next;
72		if (arg_list->name != NULL)
73		free(arg_list->name);
74		if (arg_list->gen != NULL)
75		free(arg_list->gen);
76		free(arg_list);
77		arg_list = next;
78		}
79		return OK;
80		}
81
82		no_ignore static xl_error
83		_free_expr(struct xl_ast_expr *expr)
84		{
85		xl_error err;
86
87		switch (expr->expr_type)
88		{
89		case EXPR_ATOM:
90		err = _free_atom(expr->atom);
91		break;
92		case EXPR_APPLY:
93		err = _free_expr(expr->apply.head);
94		if (err != OK)
95		return err;
96		err = _free_expr(expr->apply.tail);
97		break;
98		case EXPR_LAMBDA:
99		err = _free_expr(expr->lambda.body);
100		if (err != OK)
101		return err;
102		err = _free_arg_list(expr->lambda.args);
103		break;
104		case EXPR_CONSTRUCTOR:
105		free(expr->constructor.type_name);
106		err = xl_ast_free(expr->constructor.scope);
107		break;
108		case EXPR_CONDITIONAL:
109		err = _free_expr(expr->condition.cond);
110		if (err != OK)
111		return err;
112		err = _free_expr(expr->condition.implied);
113		if (err != OK)
114		return err;
115		err = _free_expr(expr->condition.opposed);
116		break;
117		case EXPR_BLOCK:
118		err = xl_ast_free(expr->block);
119		break;
120		default:
121		return xl_raise(ERR_BAD_TYPE, "unknown expr type in free");
122		}
123
124		if (err != OK)
125		return err;
126
127		if (expr->gen != NULL)
128		free(expr->gen);
129		free(expr);
130		return OK;
131		}
132
133		no_ignore static xl_error
134		_free_type_expr(struct xl_ast_type_expr *type_expr)
135		{
136		xl_error err;
137
138		switch (type_expr->type_expr_type)
139		{
140		case TYPE_EXPR_ATOM:
141		free(type_expr->name);
142		break;
143
144		case TYPE_EXPR_APPLY:
145		err = _free_type_expr(type_expr->apply.head);
146		if (err != OK)
147		return err;
148		err = _free_type_expr(type_expr->apply.tail);
149		if (err != OK)
150		return err;
151		break;
152		}
153
154		free(type_expr);
155		return OK;
156		}
157
158		no_ignore static xl_error
159		_free_binding(struct xl_ast_binding *binding)
160		{
161		xl_error err;
162
163		free(binding->name);
164
165		err = _free_expr(binding->expr);
166		if (err != OK)
167		return err;
168
169		if (binding->type_expr != NULL)
170		{
171		err = _free_type_expr(binding->type_expr);
172		if (err != OK)
173		return err;
174		}
175
176		free(binding);
177		return OK;
178		}
179
180		no_ignore static xl_error
181		_free_member_list(struct xl_ast_member_list *member_list)
182		{
183		xl_error err;
184
185		if (member_list->next)
186		{
187		err = _free_member_list(member_list->next);
188		if (err != OK)
189		return err;
190		}
191
192		free(member_list->name);
193
194		err = _free_type_expr(member_list->type);
195		if (err != OK)
196		return err;
197
198		free(member_list);
199		return OK;
200		}
201
202		no_ignore static xl_error
203		_free_type(struct xl_ast_type *type)
204		{
205		xl_error err;
206
207		free(type->name);
208
209		switch (type->type)
210		{
211		case TYPE_RECORD:
212		err = _free_member_list(type->members);
213		if (err != OK)
214		return err;
215		break;
216
217		default:
218		return xl_raise(ERR_BAD_TYPE, "unknown type type in free");
219		}
220
221		free(type);
222		return OK;
223		}
224
225		no_ignore static xl_error
226		_free_import_list(struct xl_ast_import_list *import_list)
227		{
228		struct xl_ast_import_list *to_free;
229
230		while (import_list != NULL)
231		{
232		to_free = import_list;
233		import_list = to_free->next;
234
235		free(to_free->name);
236		free(to_free);
237		}
238
239		return OK;
240		}
241
242		no_ignore xl_error
243		xl_ast_free(struct xl_ast *ast)
244		{
245		size_t i;
246		xl_error err;
247
248		for (i = 0; i < ast->bindings.n; i++)
249		{
250		err = _free_binding(ast->bindings.elems[i]);
251		if (err != OK)
252		return err;
253		}
254		xl_vector_free(&ast->bindings);
255
256		for (i = 0; i < ast->types.n; i++)
257		{
258		err = _free_type(ast->types.elems[i]);
259		if (err != OK)
260		return err;
261		}
262		xl_vector_free(&ast->types);
263
264		if (ast->immediate != NULL)
265		{
266		err = _free_expr(ast->immediate);
267		if (err != OK)
268		return err;
269		}
270
271		if (ast->imports != NULL)
272		{
273		err = _free_import_list(ast->imports);
274		if (err != OK)
275		return err;
276		}
277
278		free(ast);
279		return OK;
280		}
281
282		no_ignore xl_error
283		xl_ast_bind(struct xl_ast ast, struct xl_ast_binding bind)
284		{
285		return xl_vector_append(&ast->bindings, bind);
286		}
287
288		no_ignore xl_error
289		xl_ast_add_type(struct xl_ast ast, struct xl_ast_type type)
290		{
291		return xl_vector_append(&ast->types, type);
292		}
293
294		no_ignore xl_error
295		xl_ast_atom_new_qualified(
296		struct xl_ast_atom **atom,
297		char *name)
298		{
299		size_t head_len;
300		size_t tail_len;
301		size_t name_len;
302		size_t i;
303
304		head_len = 0;
305		tail_len = 0;
306		name_len = strlen(name);
307		for (i = 0; i < name_len; i++)
308		{
309		if (name[i] == ':')
310		{
311		head_len = i;
312		tail_len = name_len - i - 1;
313		break;
314		}
315		}
316
317		xl_assert(head_len > 0);
318		xl_assert(tail_len > 0);
319
320		check_alloc(*atom, 1, struct xl_ast_atom);
321		(*atom)->atom_type = ATOM_QUALIFIED;
322
323		(*atom)->qualified.head = calloc(head_len + 1, sizeof(char));
324		if ((*atom)->qualified.head == NULL)
325		return xl_raise(ERR_NO_MEMORY, "qualified alloc");
326		memcpy((*atom)->qualified.head, name, head_len);
327
328		(*atom)->qualified.tail = calloc(tail_len + 1, sizeof(char));
329		if ((*atom)->qualified.tail == NULL)
330		return xl_raise(ERR_NO_MEMORY, "qualified alloc");
331		memcpy((*atom)->qualified.tail, &name[head_len + 1], tail_len);
332
333		free(name);
334
335		return OK;
336		}
337
338		no_ignore xl_error
339		xl_ast_import(
340		struct xl_ast *ast,
341		struct xl_ast_import_list *import_list)
342		{
343		import_list->next = ast->imports;
344		ast->imports = import_list;
345		return OK;
346		}
347
348		no_ignore xl_error
349		xl_ast_subexprs(
350		struct xl_ast **subast,
351		struct xl_ast_expr **subexprs,
352		size_t *n_subexprs,
353		struct xl_ast_expr *expr)
354		{
355		*subast = NULL;
356		*n_subexprs = 0;
357
358		switch (expr->expr_type)
359		{
360		case EXPR_ATOM:
361		return OK;
362
363		case EXPR_APPLY:
364		subexprs[0] = expr->apply.head;
365		subexprs[1] = expr->apply.tail;
366		*n_subexprs = 2;
367		return OK;
368
369		case EXPR_LAMBDA:
370		subexprs[0] = expr->lambda.body;
371		*n_subexprs = 1;
372		return OK;
373
374		case EXPR_CONSTRUCTOR:
375		*subast = expr->constructor.scope;
376		return OK;
377
378		case EXPR_CONDITIONAL:
379		subexprs[0] = expr->condition.cond;
380		subexprs[1] = expr->condition.implied;
381		subexprs[2] = expr->condition.opposed;
382		*n_subexprs = 3;
383		return OK;
384
385		case EXPR_BLOCK:
386		*subast = expr->block;
387		return OK;
388		}
389
390		return xl_raise(ERR_BAD_TYPE, "bad type in expr subexpressions");
391		}
392
393		void
394		xl_ast_merge_loc(
395		struct xl_ast_loc *res,
396		struct xl_ast_loc *l1,
397		struct xl_ast_loc *l2)
398		{
399		res->line_start = size_min(l1->line_start, l2->line_start);
400		res->line_end = size_max(l1->line_end, l2->line_end);
401		res->col_start = size_min(l1->col_start, l2->col_start);
402		res->col_end = size_max(l1->col_end, l2->col_end);
403		}

-101

~~libexpel/bdagc.c~~ less more

0		/*
1		* bdagc.c: graph builder
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include "ubik/assert.h"
20		#include "ubik/bdagc.h"
21
22		#include <stdlib.h>
23		#include <string.h>
24
25		no_ignore xl_error
26		xl_bdagc_init(struct xl_graph_builder *b)
27		{
28		b->nodes = NULL;
29		b->n_nodes = 0;
30		b->cap_nodes = 0;
31		b->result = NULL;
32		return OK;
33		}
34
35		/* Adds a node to the graph. */
36		no_ignore xl_error
37		xl_bdagc_push_node(
38		struct xl_graph_builder *b,
39		struct xl_dagc_node *node)
40		{
41		size_t new_cap;
42		struct xl_dagc_node **temp;
43
44		if (b->n_nodes == b->cap_nodes)
45		{
46		new_cap = b->cap_nodes == 0 ? 8 : b->cap_nodes * 2;
47		temp = realloc(
48		b->nodes, new_cap * sizeof(struct xl_dagc_node *));
49		if (temp == NULL)
50		return xl_raise(ERR_NO_MEMORY, "bdagc push node");
51		b->nodes = temp;
52		b->cap_nodes = new_cap;
53		}
54
55		b->nodes[b->n_nodes++] = node;
56		return OK;
57		}
58
59		/* Builds the graph. */
60		no_ignore xl_error
61		xl_bdagc_build(
62		struct xl_dagc **outgraph,
63		struct xl_graph_builder *b)
64		{
65		xl_error err;
66		size_t i;
67		size_t node_size;
68		struct xl_dagc *graph;
69
70		err = xl_dagc_alloc(&graph, b->n_nodes, sizeof(struct xl_dagc), NULL);
71		if (err != OK)
72		return err;
73
74		xl_assert(b->result != NULL);
75
76		for (i = 0; i < b->n_nodes; i++)
77		{
78		err = xl_dagc_node_sizeof(&node_size, b->nodes[i]);
79		if (err != OK)
80		return err;
81		memcpy(graph->nodes[i], b->nodes[i], node_size);
82
83		err = xl_dagc_replace_node_refs(
84		graph->nodes[i], b->nodes, graph->nodes, b->n_nodes);
85		if (err != OK)
86		return err;
87
88		if (b->nodes[i] == b->result)
89		graph->result = graph->nodes[i];
90		}
91
92		err = xl_dagc_init(graph);
93		if (err != OK)
94		return err;
95
96		free(b->nodes);
97
98		*outgraph = graph;
99		return OK;
100		}

-386

~~libexpel/closure.c~~ less more

0		/*
1		* closure.c: closure transformation on ASTs
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include <string.h>
20
21		#include "ubik/assert.h"
22		#include "ubik/ast.h"
23		#include "ubik/closure.h"
24		#include "ubik/resolve.h"
25
26		/* A brief digression into the algorithm at play here.
27		*
28		* The goal of the closure transformation is to turn closures into
29		* partially-applied functions to capture the closed-over data. This
30		* allows us to maintain simplicity at the VM layer, and doing it as a
31		* source transformation seems the easiest, so that's what we're doing
32		* here.
33		*
34		* By the time we get here, every name has been resolved in one way or
35		* another. The different resolution types are all listed out in
36		* resolve.h, but the one we're interested in here is RESOLVE_CLOSURE.
37		* The goal is, by the time we're done with it, the AST will have no
38		* names that are resolved to a closure.
39		*
40		* Here's the algorithm:
41		* 1. Find a "bottom" expression: this is an expression that is a
42		* name A that resolved to a closure. Let B be the bottom
43		* expression. (this happens in traverse_expr)
44		* 2. For every expression above the bottom expression, apply the
45		* first of the following applicable rules (this happens in
46		* apply_upward_transform):
47		* a. If the expression is a lambda expression, prepend A to
48		* its list of arguments and mark it as needing application
49		* (this state is stored in expr->scope->needs_closure_appl).
50		* If the binding for A is reachable from this expression's scope
51		* without crossing a function boundary, this expression is
52		* the "top" expression; goto 3. Else continue recursing
53		* upwards.
54		* b. For all other expressions, do nothing and recurse to its
55		* parent.
56		* 3. Let X by the top expression (this, as well as steps 4 and 5,
57		* happen in apply_downwards_transform).
58		* 4. Examine each subexpression of X. If a subexpression Y is
59		* marked as needing application, replace Y in X with an apply
60		* expression whose function is Y and whose argument is an
61		* atomic expression with name A and local resolution (this
62		* specific transformation happens in apply_closure).
63		* 5. For each subexpression Y of X, let X = Y and goto 3.
64		* 6. Change the resolution of B to local.
65		* 7. Repeat until there are no more names resolved to a closure.
66		*/
67
68		no_ignore static xl_error
69		apply_closure(struct xl_ast_expr *lambda, char resolving_name)
70		{
71		struct xl_ast_expr *apply;
72		struct xl_ast_expr *name;
73
74		(*lambda)->scope->needs_closure_appl = false;
75
76		/* damn this is a lot of work. */
77		name = calloc(1, sizeof(struct xl_ast_expr));
78		if (name == NULL)
79		return xl_raise(ERR_NO_MEMORY, "closure name alloc");
80		name->expr_type = EXPR_ATOM;
81
82		name->atom = calloc(1, sizeof(struct xl_ast_atom));
83		if (name->atom == NULL)
84		return xl_raise(ERR_NO_MEMORY, "closure name alloc");
85		name->atom->atom_type = ATOM_NAME;
86		name->atom->name_loc = calloc(1, sizeof(struct xl_resolve_name_loc));
87		if (name->atom->name_loc == NULL)
88		return xl_raise(ERR_NO_MEMORY, "closure name alloc");
89		name->atom->name_loc->type = RESOLVE_LOCAL;
90
91		name->atom->str = strdup(resolving_name);
92		if (name->atom->str == NULL)
93		return xl_raise(ERR_NO_MEMORY, "closure name alloc");
94
95		name->scope = (*lambda)->scope->parent;
96
97		apply = calloc(1, sizeof(struct xl_ast_expr));
98		if (apply == NULL)
99		return xl_raise(ERR_NO_MEMORY, "closure apply alloc");
100		apply->expr_type = EXPR_APPLY;
101
102		apply->scope = (*lambda)->scope->parent;
103
104		apply->apply.head = *lambda;
105		apply->apply.tail = name;
106
107		*lambda = apply;
108		return OK;
109		}
110
111		no_ignore static xl_error
112		apply_downwards_transform(
113		char *resolving_name,
114		struct xl_resolve_context *ctx,
115		struct xl_ast_expr **expr_ref)
116		{
117		struct xl_ast *subast;
118		xl_error err;
119		size_t i;
120		struct xl_ast_expr *expr;
121
122		expr = *expr_ref;
123		subast = NULL;
124
125		if (expr->scope->needs_closure_appl)
126		{
127		err = apply_closure(expr_ref, resolving_name);
128		if (err != OK)
129		return err;
130		expr = *expr_ref;
131		}
132
133		#define check_closure_appl(subexpr) do { \
134		err = apply_downwards_transform(resolving_name, ctx, &subexpr); \
135		if (err != OK) return err; \
136		} while (0)
137
138		switch (expr->expr_type)
139		{
140		case EXPR_ATOM:
141		return OK;
142
143		case EXPR_APPLY:
144		check_closure_appl(expr->apply.head);
145		check_closure_appl(expr->apply.tail);
146		return OK;
147
148		case EXPR_LAMBDA:
149		check_closure_appl(expr->lambda.body);
150		return OK;
151
152		case EXPR_CONDITIONAL:
153		check_closure_appl(expr->condition.cond);
154		check_closure_appl(expr->condition.implied);
155		check_closure_appl(expr->condition.opposed);
156		return OK;
157
158		case EXPR_CONSTRUCTOR:
159		subast = expr->constructor.scope;
160		break;
161		case EXPR_BLOCK:
162		subast = expr->block;
163		break;
164		}
165
166		for (i = 0; i < subast->bindings.n; i++)
167		{
168		struct xl_ast_binding *bind;
169		bind = subast->bindings.elems[i];
170		check_closure_appl(bind->expr);
171		}
172
173		if (subast->immediate != NULL)
174		{
175		check_closure_appl(subast->immediate);
176		}
177		return OK;
178		}
179
180		no_ignore static xl_error
181		apply_upwards_transform(
182		char **resolving_name_ref,
183		struct xl_resolve_context *ctx,
184		struct xl_ast_expr **expr_ref)
185		{
186		char *resolving_name;
187		bool is_top;
188		size_t i;
189		struct xl_ast_expr *expr;
190		struct xl_ast_arg_list *args;
191		struct xl_resolve_scope *scope;
192
193		resolving_name = *resolving_name_ref;
194		expr = *expr_ref;
195
196		/* check to see if we can reach the definition of this name from where
197		* we are, without crossing a boundary. */
198		is_top = false;
199		scope = expr->scope;
200		do
201		{
202		for (i = 0; i < scope->names.n; i++)
203		{
204		struct xl_resolve_name *name;
205		name = scope->names.elems[i];
206		if (strcmp(name->name, resolving_name) == 0)
207		{
208		is_top = true;
209		goto break_all;
210		}
211		}
212		if (scope->boundary == BOUNDARY_FUNCTION)
213		goto break_all;
214		scope = scope->parent;
215		} while (scope != NULL);
216
217		break_all:
218
219		if (expr->expr_type == EXPR_LAMBDA)
220		{
221		args = calloc(1, sizeof(struct xl_ast_arg_list));
222		args->name = strdup(resolving_name);
223		args->next = expr->lambda.args;
224
225		expr->lambda.args = args;
226		expr->scope->needs_closure_appl = true;
227		}
228
229		if (is_top)
230		{
231		*resolving_name_ref = NULL;
232		return apply_downwards_transform(resolving_name, ctx, expr_ref);
233		}
234		return OK;
235		}
236
237		static inline bool
238		is_closure_ref(struct xl_ast_expr *expr)
239		{
240		if (expr->expr_type != EXPR_ATOM)
241		return false;
242		if (expr->atom->atom_type != ATOM_NAME)
243		return false;
244		return expr->atom->name_loc->type == RESOLVE_CLOSURE;
245		}
246
247		no_ignore static xl_error
248		traverse_ast(
249		char **resolving_name,
250		bool *changed,
251		struct xl_resolve_context *ctx,
252		struct xl_ast *ast);
253
254		no_ignore static xl_error
255		traverse_expr(
256		char **resolving_name,
257		bool *changed,
258		struct xl_resolve_context *ctx,
259		struct xl_ast_expr **expr_ref)
260		{
261		struct xl_ast *subast;
262		struct xl_ast_expr *expr;
263		xl_error err;
264
265		expr = *expr_ref;
266		subast = NULL;
267
268		if (is_closure_ref(expr))
269		{
270		*resolving_name = expr->atom->str;
271		expr->atom->name_loc->type = RESOLVE_LOCAL;
272		*changed = true;
273		return OK;
274		}
275
276		#define traverse_child(subexpr) do { \
277		err = traverse_expr(resolving_name, changed, ctx, &subexpr); \
278		if (err != OK) \
279		return err; \
280		if (*resolving_name != NULL) \
281		{ \
282		err = apply_upwards_transform( \
283		resolving_name, ctx, expr_ref); \
284		return err; \
285		} \
286		} while (0)
287
288		switch (expr->expr_type)
289		{
290		case EXPR_ATOM:
291		return OK;
292
293		case EXPR_APPLY:
294		traverse_child(expr->apply.head);
295		traverse_child(expr->apply.tail);
296		return OK;
297
298		case EXPR_LAMBDA:
299		traverse_child(expr->lambda.body);
300		return OK;
301
302		case EXPR_CONDITIONAL:
303		traverse_child(expr->condition.cond);
304		traverse_child(expr->condition.implied);
305		traverse_child(expr->condition.opposed);
306		return OK;
307
308		case EXPR_CONSTRUCTOR:
309		subast = expr->constructor.scope;
310		break;
311		case EXPR_BLOCK:
312		subast = expr->block;
313		break;
314		}
315
316		if (subast != NULL)
317		{
318		err = traverse_ast(resolving_name, changed, ctx, subast);
319		if (err != OK)
320		return err;
321
322		if (*resolving_name != NULL)
323		{
324		err = apply_upwards_transform(
325		resolving_name, ctx, expr_ref);
326		return err;
327		}
328		}
329		return OK;
330		}
331
332		no_ignore xl_error
333		traverse_ast(
334		char **resolving_name,
335		bool *changed,
336		struct xl_resolve_context *ctx,
337		struct xl_ast *ast)
338		{
339		size_t i;
340		xl_error err;
341
342		for (i = 0; i < ast->bindings.n; i++)
343		{
344		struct xl_ast_binding *bind;
345
346		bind = ast->bindings.elems[i];
347		err = traverse_expr(
348		resolving_name, changed, ctx, &bind->expr);
349		if (err != OK)
350		return err;
351		}
352
353		if (ast->immediate != NULL)
354		{
355		err = traverse_expr(
356		resolving_name, changed, ctx, &ast->immediate);
357		if (err != OK)
358		return err;
359		}
360
361		return OK;
362		}
363
364		no_ignore xl_error
365		xl_reduce_closures(
366		struct xl_resolve_context *ctx,
367		struct xl_ast *ast)
368		{
369		char *resolving_name;
370		bool changed;
371		xl_error err;
372
373		do
374		{
375		changed = false;
376		resolving_name = NULL;
377
378		err = traverse_ast(&resolving_name, &changed, ctx, ast);
379		if (err != OK)
380		return err;
381		xl_assert(resolving_name == NULL);
382		} while (changed);
383
384		return OK;
385		}

-255

~~libexpel/compile.c~~ less more

0		/*
1		* compile.c: expel compilation
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include <stdio.h>
20		#include <stdlib.h>
21		#include <string.h>
22		#include <unistd.h>
23
24		#include "ubik/compile.h"
25		#include "ubik/gen.h"
26		#include "ubik/parse.h"
27		#include "ubik/resolve.h"
28		#include "ubik/string.h"
29		#include "ubik/util.h"
30
31
32		no_ignore xl_error
33		xl_compile_env_default(struct xl_compilation_env *cenv)
34		{
35		char *scratch_dir;
36		char *include_dirs;
37		xl_error err;
38
39		scratch_dir = calloc(512, sizeof(char));
40		if (getcwd(scratch_dir, 500) == NULL)
41		{
42		perror("could not open current directory");
43		return xl_raise(ERR_UNEXPECTED_FAILURE, "getcwd");
44		}
45		strcat(scratch_dir, "/expel-build");
46		cenv->scratch_dir = scratch_dir;
47
48		include_dirs = getenv("EXPEL_INCLUDE");
49		if (include_dirs == NULL)
50		{
51		cenv->include_dirs = NULL;
52		cenv->n_include_dirs = 0;
53		}
54		else
55		{
56		err = xl_string_split(
57		&cenv->include_dirs,
58		&cenv->n_include_dirs,
59		include_dirs,
60		strlen(include_dirs),
61		':');
62		if (err != OK)
63		return err;
64		}
65
66		return OK;
67		}
68
69		no_ignore xl_error
70		xl_compile_env_free(struct xl_compilation_env *cenv)
71		{
72		size_t i;
73
74		free(cenv->scratch_dir);
75
76		for (i = 0; i < cenv->n_include_dirs; i++)
77		free(cenv->include_dirs[i]);
78		free(cenv->include_dirs);
79
80		return OK;
81		}
82
83		no_ignore xl_error
84		xl_compile(
85		struct xl_dagc ***graphs,
86		size_t *n_graphs,
87		char *source_name,
88		struct xl_stream *in_stream,
89		struct xl_compilation_env *cenv)
90		{
91		struct xl_ast *ast;
92		local(resolve_context) struct xl_resolve_context ctx = {0};
93		xl_error err;
94		xl_error free_err;
95
96		err = xl_parse(&ast, source_name, in_stream);
97		if (err != OK)
98		return err;
99
100		err = xl_resolve(ast, source_name, in_stream, &ctx);
101		if (err != OK)
102		goto free_ast;
103
104		err = xl_compile_ast(graphs, n_graphs, ast, cenv);
105		if (err != OK)
106		goto free_ast;
107
108		free_ast:
109		free_err = xl_ast_free(ast);
110		if (err != OK)
111		return err;
112		if (free_err != OK)
113		return free_err;
114		return OK;
115		}
116
117		no_ignore static xl_error
118		_open_stream_for_requirement(
119		struct xl_stream *out,
120		char **source_name,
121		char *package_name,
122		struct xl_compilation_env *cenv)
123		{
124		size_t i;
125		char *test_file;
126		char *test_basename;
127		xl_error err;
128
129		test_basename = calloc(strlen(package_name) + 4, sizeof(char));
130		strcpy(test_basename, package_name);
131		strcat(test_basename, ".xl");
132
133		for (i = 0; i < cenv->n_include_dirs; i++)
134		{
135		err = xl_string_path_concat(
136		&test_file, cenv->include_dirs[i], test_basename);
137		if (err != OK)
138		return err;
139		if (access(test_file, R_OK) == 0)
140		{
141		err = xl_stream_rfile(out, test_file);
142		if (err != OK)
143		return err;
144		#ifdef XL_COMPILE_DEBUG
145		printf("found %s for %s\n", test_file, package_name);
146		#endif
147		free(test_file);
148		*source_name = test_basename;
149		return OK;
150		}
151		free(test_file);
152		}
153
154		free(test_basename);
155		return xl_raise(ERR_ABSENT, package_name);
156		}
157
158		no_ignore static xl_error
159		_add_requirement(
160		struct xl_dagc ***graphs,
161		size_t *n_graphs,
162		struct xl_gen_requires *requires,
163		struct xl_uri *dependency,
164		struct xl_compilation_env *cenv)
165		{
166		struct xl_dagc **req_graphs;
167		size_t n_req_graphs;
168		struct xl_gen_requires *req_requires;
169		struct xl_stream package_stream;
170		struct xl_ast *ast;
171		struct xl_dagc **buf;
172		char *source_name;
173		xl_error err;
174
175		unused(requires);
176
177		source_name = NULL;
178		err = _open_stream_for_requirement(
179		&package_stream, &source_name, dependency->source, cenv);
180		if (err != OK)
181		return err;
182
183		err = xl_parse(&ast, source_name, &package_stream);
184		free(source_name);
185		if (err != OK)
186		return err;
187
188		req_requires = NULL;
189		err = xl_compile_unit(
190		&req_graphs, &n_req_graphs, &req_requires, ast, LOAD_IMPORTED,
191		dependency->source);
192		if (err != OK)
193		return err;
194		if (req_requires != NULL)
195		return xl_raise(
196		ERR_NOT_IMPLEMENTED,
197		"only one level of imports allowed");
198
199		buf = realloc(
200		*graphs,
201		(n_graphs + n_req_graphs) sizeof(struct xl_dagc **));
202		if (buf == NULL)
203		return xl_raise(ERR_NO_MEMORY, "graph list realloc");
204		memcpy(
205		&buf[*n_graphs],
206		req_graphs,
207		n_req_graphs * sizeof(struct xl_dagc **));
208		*graphs = buf;
209		*n_graphs += n_req_graphs;
210
211		err = xl_ast_free(ast);
212		if (err != OK)
213		return err;
214
215		xl_stream_close(&package_stream);
216		free(req_graphs);
217
218		return OK;
219		}
220
221		no_ignore xl_error
222		xl_compile_ast(
223		struct xl_dagc ***graphs,
224		size_t *n_graphs,
225		struct xl_ast *ast,
226		struct xl_compilation_env *cenv)
227		{
228		struct xl_gen_requires *requires;
229		struct xl_gen_requires *head;
230		xl_error err;
231
232		requires = NULL;
233		err = xl_compile_unit(
234		graphs, n_graphs, &requires, ast, LOAD_MAIN, NULL);
235		if (err != OK)
236		return err;
237
238		head = requires;
239		while (requires != NULL)
240		{
241		err = _add_requirement(
242		graphs, n_graphs, requires,
243		requires->dependency, cenv);
244		if (err != OK)
245		return err;
246		requires = requires->next;
247		}
248
249		err = xl_gen_requires_free(head);
250		if (err != OK)
251		return err;
252
253		return OK;
254		}

-590

~~libexpel/dagc.c~~ less more

0		/*
1		* dagc.c: common tasks for directed acyclic graphs of computation
2		* Copyright (C) 2015, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include <stdbool.h>
20		#include <stdlib.h>
21		#include <string.h>
22
23		#include "ubik/assert.h"
24		#include "ubik/dagc.h"
25		#include "ubik/ubik.h"
26		#include "ubik/util.h"
27
28		no_ignore xl_error
29		xl_dagc_new(struct xl_dagc **graph, size_t n_nodes)
30		{
31		return xl_dagc_alloc(
32		graph, n_nodes, sizeof(struct xl_dagc), NULL);
33		}
34
35		/* Gets the dependencies of a node.
36		*
37		* For nodes with two dependencies, d1 and d2 will be filled in
38		* with valid pointers. For nodes with one dependency, d1 will be
39		* filled in with a pointer and d2 will be set to NULL. For nodes
40		* with no dependencies, both will be NULL. */
41		no_ignore xl_error
42		xl_dagc_get_deps(
43		struct xl_dagc_node **d1,
44		struct xl_dagc_node **d2,
45		struct xl_dagc_node **d3,
46		struct xl_dagc_node *n)
47		{
48		switch (n->node_type)
49		{
50		case DAGC_NODE_APPLY:
51		d1 = ((struct xl_dagc_apply ) n)->func;
52		d2 = ((struct xl_dagc_apply ) n)->arg;
53		*d3 = NULL;
54		return OK;
55
56		case DAGC_NODE_COND:
57		d1 = ((struct xl_dagc_cond ) n)->condition;
58		d2 = ((struct xl_dagc_cond ) n)->if_true;
59		d3 = ((struct xl_dagc_cond ) n)->if_false;
60		return OK;
61
62		case DAGC_NODE_LOAD:
63		*d1 = NULL;
64		*d2 = NULL;
65		*d3 = NULL;
66		return OK;
67
68		case DAGC_NODE_REF:
69		d1 = ((struct xl_dagc_ref ) n)->referrent;
70		*d2 = NULL;
71		*d3 = NULL;
72		return OK;
73
74		case DAGC_NODE_STORE:
75		d1 = ((struct xl_dagc_store ) n)->value;
76		*d2 = NULL;
77		*d3 = NULL;
78		return OK;
79
80		case DAGC_NODE_CONST:
81		case DAGC_NODE_INPUT:
82		case DAGC_NODE_NATIVE:
83		*d1 = NULL;
84		*d2 = NULL;
85		*d3 = NULL;
86		return OK;
87		}
88		return xl_raise(ERR_UNKNOWN_TYPE, "get deps");
89		}
90
91		static int
92		_cmp_adjacency(const void v1, const void v2)
93		{
94		uintptr_t p1, p2;
95		p1 = ((uintptr_t ) v1);
96		p2 = ((uintptr_t ) v2);
97		if (p1 < p2)
98		return -1;
99		if (p1 > p2)
100		return 1;
101		return 0;
102		}
103
104		no_ignore static xl_error
105		_find_adjacency(
106		size_t *i,
107		struct xl_dagc_adjacency *adjacencies,
108		size_t n,
109		struct xl_dagc_node *child)
110		{
111		uintptr_t cptr, aptr;
112		size_t min, max;
113
114		min = 0;
115		max = n;
116		cptr = (uintptr_t) child;
117
118		while (min < max)
119		{
120		*i = (min + max - 1) / 2;
121		aptr = (uintptr_t) adjacencies[*i].child;
122		if (aptr == cptr)
123		return OK;
124		if (aptr > cptr)
125		max = *i;
126		if (aptr < cptr)
127		min = *i + 1;
128		}
129		return xl_raise(ERR_ABSENT, "find adjacency");
130		}
131
132		no_ignore static xl_error
133		_increment_n_parents(
134		struct xl_dagc *graph,
135		struct xl_dagc_node *child)
136		{
137		xl_error err;
138		size_t i;
139
140		i = graph->n;
141		err = _find_adjacency(&i, graph->adjacency, graph->n, child);
142		if (err != OK)
143		return err;
144		if (unlikely(i >= graph->n))
145		return xl_raise(ERR_UNEXPECTED_FAILURE,
146		"find adjacent result bogus");
147		graph->adjacency[i].n_parents++;
148		return OK;
149		}
150
151		no_ignore static xl_error
152		_add_parent(
153		struct xl_dagc *graph,
154		struct xl_dagc_node *parent,
155		struct xl_dagc_node *child)
156		{
157		struct xl_dagc_adjacency *adj;
158		size_t adj_i, parent_i;
159		xl_error err;
160
161		adj_i = graph->n;
162		err = _find_adjacency(
163		&adj_i, graph->adjacency, graph->n, child);
164		if (err != OK)
165		return err;
166		if (unlikely(adj_i >= graph->n))
167		return xl_raise(ERR_UNEXPECTED_FAILURE,
168		"find adjacent result bogus");
169		adj = &graph->adjacency[adj_i];
170		/* Find the first NULL parent entry. */
171		for (parent_i = 0;
172		adj->parents[parent_i] && parent_i < adj->n_parents;
173		parent_i++);
174		if (adj->parents[parent_i] != NULL)
175		return xl_raise(ERR_UNEXPECTED_FAILURE,
176		"all parents full already");
177		adj->parents[parent_i] = parent;
178		return OK;
179		}
180
181		no_ignore xl_error
182		xl_dagc_init(struct xl_dagc *graph)
183		{
184		struct xl_dagc_node p, d1, d2, d3;
185		struct xl_dagc_adjacency *adj;
186		size_t i, next_in, next_out;
187		xl_error err;
188
189		graph->tag = TAG_GRAPH;
190		graph->refcount = 1;
191
192		/* Adjacency is stored as a sorted list of adjacency
193		* lists; the first element in each list is the child and
194		* the remaining elements are parents. */
195		graph->adjacency = calloc(graph->n, sizeof(struct xl_dagc_adjacency));
196
197		for (i = 0; i < graph->n; i++)
198		{
199		graph->adjacency[i].child = graph->nodes[i];
200		graph->adjacency[i].parents = NULL;
201		graph->adjacency[i].n_parents = 0;
202		}
203
204		qsort(graph->adjacency, graph->n,
205		sizeof(struct xl_dagc_adjacency), _cmp_adjacency);
206
207		/* First go through and count how many parents each one has. */
208		for (i = 0; i < graph->n; i++)
209		{
210		p = graph->nodes[i];
211		err = xl_dagc_get_deps(&d1, &d2, &d3, p);
212		if (err != OK)
213		return err;
214
215		if (d1 != NULL)
216		{
217		err = _increment_n_parents(graph, d1);
218		if (err != OK)
219		return err;
220		}
221		if (d2 != NULL)
222		{
223		err = _increment_n_parents(graph, d2);
224		if (err != OK)
225		return err;
226		}
227		if (d3 != NULL)
228		{
229		err = _increment_n_parents(graph, d3);
230		if (err != OK)
231		return err;
232		}
233		}
234
235		/* Now allocate the parent arrays. */
236		for (i = 0; i < graph->n; i++)
237		{
238		adj = &graph->adjacency[i];
239		adj->parents = calloc(
240		adj->n_parents, sizeof(struct xl_dagc_node *));
241		}
242
243		/* Finally fill in the actual parent arrays. */
244		for (i = 0; i < graph->n; i++)
245		{
246		p = graph->nodes[i];
247		err = xl_dagc_get_deps(&d1, &d2, &d3, p);
248		if (err != OK)
249		return err;
250
251		if (d1 != NULL)
252		{
253		err = _add_parent(graph, p, d1);
254		if (err != OK)
255		return err;
256		}
257		if (d2 != NULL)
258		{
259		err = _add_parent(graph, p, d2);
260		if (err != OK)
261		return err;
262		}
263		if (d3 != NULL)
264		{
265		err = _add_parent(graph, p, d3);
266		if (err != OK)
267		return err;
268		}
269		}
270
271		/* Go through and find how many nodes are inputs or terminals */
272		graph->in_arity = 0;
273		graph->out_arity = 0;
274		for (i = 0; i < graph->n; i++)
275		{
276		p = graph->nodes[i];
277		if (p->node_type == DAGC_NODE_INPUT)
278		graph->in_arity++;
279		if (p->is_terminal)
280		graph->out_arity++;
281		}
282
283		/* Then populate the input and terminal lists. */
284		graph->inputs = calloc(graph->in_arity, sizeof(struct xl_dagc_node *));
285		graph->terminals =
286		calloc(graph->out_arity, sizeof(struct xl_dagc_node *));
287		for (i = 0, next_out = 0; i < graph->n; i++)
288		{
289		p = graph->nodes[i];
290		if (p->node_type == DAGC_NODE_INPUT)
291		{
292		next_in = ((struct xl_dagc_input *) p)->arg_num;
293		xl_assert(next_in < graph->in_arity);
294		if (graph->inputs[next_in] != NULL)
295		return xl_raise(
296		ERR_BAD_GRAPH,
297		"multiple inputs with same arg num");
298		graph->inputs[next_in] = p;
299		}
300		if (p->is_terminal)
301		graph->terminals[next_out++] = p;
302		}
303
304		return OK;
305		}
306
307		no_ignore xl_error
308		xl_dagc_get_parents(
309		struct xl_dagc_node ***parents,
310		size_t *n_parents,
311		struct xl_dagc *graph,
312		struct xl_dagc_node *child)
313		{
314		size_t i;
315		xl_error err;
316
317		i = graph->n;
318		err = _find_adjacency(&i, graph->adjacency, graph->n, child);
319		if (err != OK)
320		return err;
321		if (unlikely(i >= graph->n))
322		return xl_raise(ERR_UNEXPECTED_FAILURE, NULL);
323
324		*parents = graph->adjacency[i].parents;
325		*n_parents = graph->adjacency[i].n_parents;
326		return OK;
327		}
328
329		no_ignore xl_error
330		xl_dagc_node_sizeof(
331		size_t *size,
332		struct xl_dagc_node *node)
333		{
334		switch (node->node_type)
335		{
336		case DAGC_NODE_APPLY:
337		*size = sizeof(struct xl_dagc_apply);
338		return OK;
339		case DAGC_NODE_COND:
340		*size = sizeof(struct xl_dagc_cond);
341		return OK;
342		case DAGC_NODE_CONST:
343		*size = sizeof(struct xl_dagc_const);
344		return OK;
345		case DAGC_NODE_INPUT:
346		*size = sizeof(struct xl_dagc_input);
347		return OK;
348		case DAGC_NODE_LOAD:
349		*size = sizeof(struct xl_dagc_load);
350		return OK;
351		case DAGC_NODE_NATIVE:
352		*size = sizeof(struct xl_dagc_native);
353		return OK;
354		case DAGC_NODE_REF:
355		*size = sizeof(struct xl_dagc_ref);
356		return OK;
357		case DAGC_NODE_STORE:
358		*size = sizeof(struct xl_dagc_store);
359		return OK;
360		}
361		return xl_raise(ERR_UNKNOWN_TYPE, "unknown node type in size");
362		}
363
364		no_ignore static xl_error
365		_replace_ref(
366		struct xl_dagc_node **ref,
367		struct xl_dagc_node **proto,
368		struct xl_dagc_node **copied,
369		size_t n)
370		{
371		size_t i;
372
373		if (*ref == NULL)
374		return OK;
375		for (i = 0; i < n; i++)
376		{
377		if (proto[i] == *ref)
378		{
379		*ref = copied[i];
380		return OK;
381		}
382		}
383		return xl_raise(ERR_ABSENT, "replace ref");
384		}
385
386		no_ignore xl_error
387		xl_dagc_replace_node_refs(
388		struct xl_dagc_node *node,
389		struct xl_dagc_node **proto,
390		struct xl_dagc_node **copied,
391		size_t n_nodes)
392		{
393		union xl_dagc_any_node *n;
394		xl_error err;
395
396		n = (union xl_dagc_any_node *) node;
397
398		switch (node->node_type)
399		{
400		case DAGC_NODE_APPLY:
401		err = _replace_ref(&n->as_apply.func, proto, copied, n_nodes);
402		if (err != OK)
403		return err;
404		err = _replace_ref(&n->as_apply.arg, proto, copied, n_nodes);
405		return err;
406
407		case DAGC_NODE_REF:
408		err = _replace_ref(&n->as_ref.referrent, proto, copied, n_nodes);
409		return err;
410
411		case DAGC_NODE_STORE:
412		err = _replace_ref(&n->as_store.value, proto, copied, n_nodes);
413		return err;
414
415		case DAGC_NODE_COND:
416		err = _replace_ref(&n->as_cond.condition, proto, copied, n_nodes);
417		if (err != OK)
418		return err;
419		err = _replace_ref(&n->as_cond.if_true, proto, copied, n_nodes);
420		if (err != OK)
421		return err;
422		err = _replace_ref(&n->as_cond.if_false, proto, copied, n_nodes);
423		return err;
424
425		case DAGC_NODE_LOAD:
426		case DAGC_NODE_CONST:
427		case DAGC_NODE_INPUT:
428		case DAGC_NODE_NATIVE:
429		return OK;
430		}
431		return xl_raise(ERR_UNKNOWN_TYPE, "replace node refs");
432		}
433
434		no_ignore static xl_error
435		_increment_value_refs(struct xl_dagc_node *node)
436		{
437		struct xl_dagc_load *l;
438		struct xl_dagc_store *s;
439		struct xl_dagc_const *c;
440		xl_error err;
441
442		if (node->known.any != NULL)
443		{
444		err = xl_take(node->known.any);
445		if (err != OK)
446		return err;
447		}
448		if (node->known_type != NULL)
449		{
450		err = xl_take(node->known_type);
451		if (err != OK)
452		return err;
453		}
454
455		switch (node->node_type)
456		{
457		case DAGC_NODE_APPLY:
458		case DAGC_NODE_NATIVE:
459		case DAGC_NODE_COND:
460		case DAGC_NODE_REF:
461		case DAGC_NODE_INPUT:
462		return OK;
463
464		case DAGC_NODE_LOAD:
465		l = (struct xl_dagc_load *) node;
466		return xl_take(l->loc);
467
468		case DAGC_NODE_STORE:
469		s = (struct xl_dagc_store *) node;
470		return xl_take(s->loc);
471
472		case DAGC_NODE_CONST:
473		c = (struct xl_dagc_const *) node;
474		err = xl_take(c->type);
475		if (err != OK)
476		return err;
477		return xl_take(c->value.any);
478		}
479		return xl_raise(ERR_UNKNOWN_TYPE, "inc value refs");
480		}
481
482		no_ignore xl_error
483		xl_dagc_copy(
484		struct xl_dagc **res_ptr,
485		struct xl_dagc *proto)
486		{
487		struct xl_dagc_adjacency *adj;
488		struct xl_dagc *result;
489		size_t i, j, size;
490		xl_error err;
491
492		/* Start by making a direct copy, then replace all of the references. */
493		size = sizeof(struct xl_dagc);
494		if (proto->tag & TAG_GRAPH_NATIVE)
495		size = sizeof(struct xl_dagc_native);
496
497		err = xl_dagc_alloc(&result, proto->n, size, proto);
498		if (err != OK)
499		return err;
500		*res_ptr = result;
501
502		result->refcount = 0;
503
504		memcpy(result->nodes[0], proto->nodes[0],
505		proto->n * sizeof(union xl_dagc_any_node));
506
507		for (i = 0; i < result->n; i++)
508		{
509		err = xl_dagc_replace_node_refs(
510		result->nodes[i], proto->nodes, result->nodes,
511		result->n);
512		if (err != OK)
513		return err;
514		err = _increment_value_refs(result->nodes[i]);
515		if (err != OK)
516		return err;
517		}
518
519		result->inputs =
520		calloc(result->in_arity, sizeof(struct xl_dagc_node *));
521		result->terminals =
522		calloc(result->out_arity, sizeof(struct xl_dagc_node *));
523		for (i = 0; i < result->in_arity; i++)
524		{
525		result->inputs[i] = proto->inputs[i];
526		err = _replace_ref(
527		&result->inputs[i], proto->nodes, result->nodes,
528		result->n);
529		if (err != OK)
530		return err;
531		}
532		for (i = 0; i < result->out_arity; i++)
533		{
534		result->terminals[i] = proto->terminals[i];
535		err = _replace_ref(
536		&result->terminals[i], proto->nodes, result->nodes,
537		result->n);
538		if (err != OK)
539		return err;
540		}
541
542		if (proto->result != NULL)
543		{
544		err = _replace_ref(
545		&result->result, proto->nodes, result->nodes,
546		result->n);
547		if (err != OK)
548		return err;
549		}
550
551		result->adjacency =
552		calloc(result->n, sizeof(struct xl_dagc_adjacency));
553		memcpy(result->adjacency, proto->adjacency,
554		result->n * sizeof(struct xl_dagc_adjacency));
555
556		for (i = 0; i < result->n; i++)
557		{
558		adj = &result->adjacency[i];
559		err = _replace_ref(
560		&adj->child, proto->nodes, result->nodes, result->n);
561		if (err != OK)
562		return err;
563
564		adj->parents =
565		calloc(adj->n_parents, sizeof(struct xl_dagc_node *));
566		memcpy(adj->parents, proto->adjacency[i].parents,
567		adj->n_parents * sizeof(struct xl_dagc_node *));
568		for (j = 0; j < adj->n_parents; j++)
569		{
570		err = _replace_ref(
571		&adj->parents[j], proto->nodes,
572		result->nodes, result->n);
573		if (err != OK)
574		return err;
575		}
576		}
577
578		qsort(result->adjacency, result->n,
579		sizeof(struct xl_dagc_adjacency), _cmp_adjacency);
580
581		if (result->identity != NULL)
582		{
583		err = xl_take(result->identity);
584		if (err != OK)
585		return err;
586		}
587
588		return OK;
589		}

-456

~~libexpel/env.c~~ less more

0		/*
1		* env.c: expel environment definitions
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include <math.h>
20		#include <string.h>
21
22		#include "ubik/assert.h"
23		#include "ubik/ubik.h"
24		#include "ubik/env.h"
25		#include "ubik/util.h"
26
27		#define ENV_MAX_LOAD 0.5
28		#define ENV_INIT_CAP 8
29		#define ENV_CAP_SCALE 2
30
31		static struct xl_env root;
32
33		struct xl_env *
34		xl_env_get_root()
35		{
36		return &root;
37		}
38
39		no_ignore xl_error
40		xl_env_init(struct xl_env *env)
41		{
42		env->bindings = NULL;
43		env->n = 0;
44		env->cap = 0;
45		env->parent = xl_env_get_root();
46		env->watches = NULL;
47		return OK;
48		}
49
50		no_ignore xl_error
51		xl_env_make_child(struct xl_env child, struct xl_env parent)
52		{
53		xl_error err;
54		err = xl_env_init(child);
55		if (err != OK)
56		return err;
57		child->parent = parent;
58		return OK;
59		}
60
61		no_ignore xl_error
62		xl_env_free(struct xl_env *env)
63		{
64		xl_error err;
65		size_t i;
66		struct xl_env_watch_list *to_free;
67
68		if (likely(env->bindings != NULL))
69		{
70		for (i = 0; i < env->cap; i++)
71		{
72		if (env->bindings[i].value.any == NULL)
73		continue;
74		err = xl_release(env->bindings[i].uri);
75		if (err != OK)
76		return err;
77		err = xl_release(env->bindings[i].type);
78		if (err != OK)
79		return err;
80		err = xl_release(env->bindings[i].value.any);
81		if (err != OK)
82		return err;
83		}
84		free(env->bindings);
85		}
86		while (env->watches != NULL)
87		{
88		to_free = env->watches;
89		env->watches = to_free->prev;
90
91		if (to_free->watch->refcount > 1)
92		to_free->watch->refcount--;
93		else
94		free(to_free->watch);
95		free(to_free);
96		}
97
98		env->n = 0;
99		env->cap = 0;
100		env->bindings = NULL;
101
102		env->watches = NULL;
103		if (env != xl_env_get_root())
104		env->parent = xl_env_get_root();
105		return OK;
106		}
107
108		no_ignore xl_error
109		xl_env_iterate(
110		xl_env_cb callback,
111		struct xl_env *env,
112		void *callback_arg)
113		{
114		xl_error err;
115		size_t i;
116
117		for (i = 0; i < env->cap; i++)
118		{
119		if (env->bindings[i].uri == NULL)
120		continue;
121		err = callback(callback_arg, env, env->bindings[i].uri);
122		if (err != OK)
123		return err;
124		}
125
126		return OK;
127		}
128
129		no_ignore xl_error
130		xl_env_get(
131		union xl_value_or_graph *value,
132		struct xl_value **type,
133		struct xl_env *env,
134		struct xl_uri *uri)
135		{
136		size_t i;
137		size_t probed;
138		size_t h;
139		bool found;
140
141		found = false;
142
143		if (env->cap != 0)
144		{
145		h = uri->hash % env->cap;
146		for (probed = 0; probed < env->cap; probed++)
147		{
148		i = (h + probed) % env->cap;
149		if (env->bindings[i].uri == NULL)
150		break;
151		if (env->bindings[i].uri->hash != uri->hash)
152		continue;
153		if (xl_uri_eq(uri, env->bindings[i].uri))
154		{
155		if (value != NULL)
156		{
157		value->any = env->bindings[i].value.any;
158		*type = env->bindings[i].type;
159		}
160		found = true;
161		break;
162		}
163		}
164		}
165
166		if (found)
167		return OK;
168
169		xl_assert(env->parent != env);
170		if (env->parent == NULL)
171		return xl_raise(ERR_ABSENT, "xl_get");
172		return xl_env_get(value, type, env->parent, uri);
173		}
174
175		no_ignore xl_error
176		xl_env_present(
177		bool *is_present,
178		struct xl_env *env,
179		struct xl_uri *uri)
180		{
181		xl_error err;
182
183		err = xl_env_get(NULL, NULL, env, uri);
184		if (err == OK)
185		*is_present = true;
186		else if (err->error_code == ERR_ABSENT)
187		{
188		free(err);
189		*is_present = false;
190		}
191		else
192		return err;
193		return OK;
194		}
195
196		/* Inserts the given URI-value pair into the given binding array.
197		*
198		* This assumes that the table has space for another entry, and
199		* will return ERR_FULL if the table has no spaces remaining.
200		*
201		* The overwrite parameter controls whether existing data will be
202		* overwritten. True means that it will be, false means that it
203		* will not. */
204		no_ignore static xl_error
205		_insert(
206		struct xl_binding *binds,
207		size_t cap,
208		struct xl_binding *insert,
209		bool overwrite)
210		{
211		size_t i;
212		size_t probed;
213		xl_error err;
214
215		i = insert->uri->hash % cap;
216		for (probed = 0; probed < cap; probed++)
217		{
218		if (binds[i].uri == NULL)
219		break;
220		if (xl_uri_eq(binds[i].uri, insert->uri))
221		break;
222		i = (i + 1) % cap;
223		}
224		if (unlikely(probed == cap))
225		return xl_raise(ERR_FULL, "env insert");
226
227		/* There was already a value at this key, we need to release our
228		* reference on it. */
229		if (unlikely(binds[i].value.any != NULL))
230		{
231		if (!overwrite)
232		return xl_raise(ERR_PRESENT, "env overwrite");
233		err = xl_release(binds[i].value.any);
234		if (err != OK)
235		return err;
236		err = xl_release(binds[i].uri);
237		if (err != OK)
238		return err;
239		err = xl_release(binds[i].type);
240		if (err != OK)
241		return err;
242		}
243
244		binds[i] = *insert;
245		return OK;
246		}
247
248		/* Resizes and rebalances an environment, scaling the capacity by
249		* ENV_CAP_SCALE as defined above.
250		*
251		* This first allocates a new bindings array, and then reinserts the
252		* bindings from the old bindings array into the new one. Finally, it
253		* frees the old array and updates the env struct to reference the new
254		* array. If an error occurs during rebalancing, the environment remains
255		* unmodified and a nonzero error code is returned. */
256		static xl_error
257		_resize_rebalance(struct xl_env *env)
258		{
259		struct xl_binding *new_binds;
260		size_t new_cap;
261		size_t i;
262		size_t reinserted;
263		xl_error err;
264
265		if (env->cap == 0)
266		new_cap = ENV_INIT_CAP;
267		else
268		new_cap = ENV_CAP_SCALE * env->cap;
269
270		new_binds = calloc(new_cap, sizeof(struct xl_binding));
271		if (new_binds == NULL)
272		return xl_raise(ERR_NO_MEMORY, "env resize");
273
274		err = OK;
275		for (i = 0, reinserted = 0; i < env->cap && reinserted < env->n; i++)
276		{
277		if (env->bindings[i].uri == NULL)
278		continue;
279
280		err = _insert(new_binds, new_cap, &env->bindings[i], false);
281		if (err != OK)
282		break;
283		}
284
285		/* if an error occurs, the environment remains unchanged. */
286		if (err != OK)
287		{
288		free(new_binds);
289		return err;
290		}
291
292		free(env->bindings);
293		env->bindings = new_binds;
294		env->cap = new_cap;
295		return OK;
296		}
297
298		no_ignore static xl_error
299		_set(
300		struct xl_env *env,
301		struct xl_uri *uri,
302		union xl_value_or_graph value,
303		struct xl_value *type,
304		bool overwrite)
305		{
306		struct xl_binding new_binding;
307		struct xl_env_watch_list watch, to_free;
308		xl_error err, ignore;
309
310		err = OK;
311		if (unlikely(env->cap == 0))
312		err = _resize_rebalance(env);
313		else if (unlikely((float) env->n / (float) env->cap > ENV_MAX_LOAD))
314		err = _resize_rebalance(env);
315		if (err != OK)
316		return err;
317
318		new_binding.uri = uri;
319		new_binding.value = value;
320		new_binding.type = type;
321
322		/* Take a reference to the value. We do this before we know whether the
323		* insert succeeded, because the insert can result in a release, which
324		* itself can result in a GC. We want to make sure that this doesn't get
325		* GCed if we are going to keep this thing, so we take a reference now
326		* and release it if the insert fails later. */
327		err = xl_take(value.any);
328		if (err != OK)
329		return err;
330		err = xl_take(type);
331		if (err != OK)
332		return err;
333		err = xl_take(uri);
334		if (err != OK)
335		return err;
336
337		err = _insert(env->bindings, env->cap, &new_binding, overwrite);
338		if (err != OK)
339		{
340		/* We're on the clean-up codepath, and we want the returned
341		* error to be the actual error, not whatever went wrong during
342		* the release, so we drop this error on the ground.
343		*
344		* (I like that it takes this much effort to ignore an
345		* unignorable parameter) */
346		ignore = xl_release(value.any);
347		unused(ignore);
348		ignore = xl_release(type);
349		unused(ignore);
350		ignore = xl_release(uri);
351		unused(ignore);
352
353		return err;
354		}
355		env->n++;
356
357		watch = env->watches;
358		while (watch != NULL)
359		{
360		if (xl_uri_eq(watch->watch->uri, uri))
361		{
362		err = watch->watch->cb(
363		watch->watch->arg,
364		watch->watch->target_env,
365		watch->watch->uri);
366		if (err != OK)
367		return err;
368
369		watch->watch->fired = true;
370		}
371
372		to_free = NULL;
373		if (watch->watch->fired)
374		{
375		watch->watch->refcount--;
376
377		to_free = watch;
378		if (watch->prev != NULL)
379		watch->prev->next = watch->next;
380		if (watch->next != NULL)
381		watch->next->prev = watch->prev;
382		if (env->watches == watch)
383		env->watches = watch->prev;
384		}
385
386		watch = watch->prev;
387
388		if (to_free != NULL && to_free->watch->refcount == 0)
389		free(to_free->watch);
390		if (to_free != NULL)
391		free(to_free);
392		}
393
394		return OK;
395		}
396
397		no_ignore xl_error
398		xl_env_set(
399		struct xl_env *env,
400		struct xl_uri *uri,
401		union xl_value_or_graph value,
402		struct xl_value *type)
403		{
404		return _set(env, uri, value, type, false);
405		}
406
407		no_ignore xl_error
408		xl_env_overwrite(
409		struct xl_env *env,
410		struct xl_uri *uri,
411		union xl_value_or_graph value,
412		struct xl_value *type)
413		{
414		return _set(env, uri, value, type, true);
415		}
416
417		no_ignore xl_error
418		xl_env_watch(
419		xl_env_cb callback,
420		struct xl_env *env,
421		struct xl_uri *uri,
422		void *callback_arg)
423		{
424		struct xl_env_watch *watcher;
425		struct xl_env_watch_list *watchlist;
426
427		watcher = calloc(1, sizeof(struct xl_env_watch));
428		if (watcher == NULL)
429		return xl_raise(ERR_NO_MEMORY, "env watch alloc");
430
431		watcher->uri = uri;
432		watcher->cb = callback;
433		watcher->arg = callback_arg;
434		watcher->target_env = env;
435		watcher->fired = false;
436
437		while (env != NULL)
438		{
439		watchlist = calloc(1, sizeof(struct xl_env_watch_list));
440		if (watchlist == NULL)
441		return xl_raise(ERR_NO_MEMORY, "env watchlist alloc");
442
443		watchlist->watch = watcher;
444		watchlist->prev = env->watches;
445		watchlist->next = NULL;
446		if (env->watches != NULL)
447		env->watches->next = watchlist;
448		env->watches = watchlist;
449
450		watcher->refcount++;
451		env = env->parent;
452		}
453
454		return OK;
455		}

-60

~~libexpel/error.c~~ less more

0		/*
1		* error.c: error tracking for expel runtime
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include <stdio.h>
20		#include <stdlib.h>
21
22		#include "ubik/ubik.h"
23		#include "ubik/util.h"
24
25		xl_error
26		xl_error_new(
27		const xl_word code,
28		const char *tag,
29		const char *file,
30		const uint32_t lineno,
31		const char *function)
32		{
33		struct xl_error *res;
34
35		res = calloc(1, sizeof(struct xl_error));
36		res->error_code = code;
37		res->tag = tag;
38		res->file = file;
39		res->lineno = lineno;
40		res->function = function;
41		return res;
42		}
43
44		char *
45		xl_error_explain(xl_error err)
46		{
47		char *res;
48		char *err_word_expl;
49		int aspr_res;
50
51		err_word_expl = xl_word_explain(err->error_code);
52		aspr_res = asprintf(&res, "error %s at %s:%u: %s",
53		err_word_expl, err->file, err->lineno, err->tag);
54
55		if (aspr_res < 0)
56		res = NULL;
57		free(err_word_expl);
58		return res;
59		}

-306

~~libexpel/eval.c~~ less more

0		/*
1		* eval.c: evaluate nodes in directed acyclic graphs of computation
2		* Copyright (C) 2015, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include "ubik/assert.h"
20		#include "ubik/dagc.h"
21		#include "ubik/env.h"
22		#include "ubik/ubik.h"
23		#include "ubik/types.h"
24		#include "ubik/util.h"
25		#include "ubik/value.h"
26
27		no_ignore static xl_error
28		_eval_apply(struct xl_env env, struct xl_dagc_apply node)
29		{
30		xl_error err;
31		struct xl_dagc_input *input;
32		struct xl_dagc *result;
33		struct xl_dagc *proto;
34		size_t i;
35
36		unused(env);
37
38		if ((*node->func->known.tag & TAG_TYPE_MASK) != TAG_GRAPH)
39		{
40		err = xl_type_match_polyfunc(
41		&proto, node->func->known.tree, node->arg->known_type);
42		if (err != OK)
43		return err;
44		}
45		else
46		{
47		proto = node->func->known.graph;
48		}
49
50		if (proto->in_arity == 0)
51		return xl_raise(ERR_BAD_TYPE, "apply: graph has no inputs");
52
53		err = xl_dagc_copy(&result, proto);
54		if (err != OK)
55		return err;
56		node->head.known.graph = result;
57
58		err = xl_take(result);
59		if (err != OK)
60		return err;
61
62		/* Take an input node off the front, shift the remaining ones left. */
63		input = (struct xl_dagc_input *) result->inputs[0];
64		result->in_arity--;
65		for (i = 0; i < result->in_arity; i++)
66		result->inputs[i] = result->inputs[i + 1];
67
68		input->head.flags = XL_DAGC_FLAG_COMPLETE;
69
70		input->head.known_type = node->arg->known_type;
71		err = xl_take(input->head.known_type);
72		if (err != OK)
73		return err;
74
75		input->head.known = node->arg->known;
76		err = xl_take(input->head.known.any);
77		if (err != OK)
78		return err;
79
80		err = xl_value_new(&node->head.known_type);
81		if (err != OK)
82		return err;
83		err = xl_type_func_apply(node->head.known_type, node->func->known_type);
84		if (err != OK)
85		return err;
86
87		node->head.flags \|= XL_DAGC_FLAG_COMPLETE;
88		return OK;
89		}
90
91		no_ignore static xl_error
92		_eval_const(struct xl_env env, struct xl_dagc_const node)
93		{
94		xl_error err;
95		unused(env);
96
97		/* We end up having two references for a single value from a single
98		* node; this is so we don't have to worry about whether things are
99		* populated when we eventually free the graph. */
100		node->head.known_type = node->type;
101		err = xl_take(node->type);
102		if (err != OK)
103		return err;
104
105		node->head.known = node->value;
106		err = xl_take(node->head.known.any);
107		if (err != OK)
108		return err;
109
110		node->head.flags \|= XL_DAGC_FLAG_COMPLETE;
111		return OK;
112		}
113
114		no_ignore static xl_error
115		_eval_ref(struct xl_env env, struct xl_dagc_ref node)
116		{
117		xl_error err;
118		unused(env);
119
120		node->head.known_type = node->referrent->known_type;
121		err = xl_take(node->head.known_type);
122		if (err != OK)
123		return err;
124
125		node->head.known.any = node->referrent->known.any;
126		err = xl_take(node->head.known.any);
127		if (err != OK)
128		return err;
129
130		node->head.flags \|= XL_DAGC_FLAG_COMPLETE;
131		return OK;
132		}
133
134		no_ignore static xl_error
135		_mark_load_complete(
136		void *node_void,
137		struct xl_env *env,
138		struct xl_uri *uri)
139		{
140		struct xl_dagc_node *node;
141		unused(env);
142		unused(uri);
143
144		node = (struct xl_dagc_node *) node_void;
145		node->flags &= ~XL_DAGC_FLAG_WAIT_DATA;
146		return OK;
147		}
148
149		no_ignore static xl_error
150		_eval_load(struct xl_env env, struct xl_dagc_load node)
151		{
152		union xl_value_or_graph value;
153		struct xl_value *type;
154		xl_error err;
155
156		err = xl_env_get(&value, &type, env, node->loc);
157		if (err != OK)
158		{
159		/* native funcs never reappear; they're gone forever. */
160		if (node->loc->scope == SCOPE_NATIVE)
161		return err;
162
163		if (err->error_code == ERR_ABSENT)
164		{
165		free(err);
166		node->head.flags \|= XL_DAGC_FLAG_WAIT_DATA;
167		err = xl_env_watch(
168		_mark_load_complete, env, node->loc, node);
169		if (err != OK)
170		return err;
171		return OK;
172		}
173		return err;
174		}
175
176		err = xl_take(value.any);
177		if (err != OK)
178		return err;
179
180		err = xl_take(type);
181		if (err != OK)
182		return err;
183
184		node->head.known_type = type;
185		node->head.known = value;
186
187		node->head.flags \|= XL_DAGC_FLAG_COMPLETE;
188		return OK;
189		}
190
191		no_ignore static xl_error
192		_eval_cond(struct xl_env env, struct xl_dagc_cond cond)
193		{
194		struct xl_dagc_node *res;
195		xl_error err;
196		bool condition;
197
198		unused(env);
199
200		err = xl_value_as_bool(&condition, cond->condition->known.tree);
201		if (err != OK)
202		return err;
203
204		res = condition ? cond->if_true : cond->if_false;
205
206		if (res->known.any == NULL)
207		{
208		/* If this is true, we just got done evaluating the condition
209		* but we haven't scheduled the if_true/if_false nodes. We set
210		* our wait flag on the appropriate node and let the scheduler
211		* pick it up and reevaluate us later. */
212		cond->head.flags \|= condition
213		? XL_DAGC_FLAG_WAIT_D2
214		: XL_DAGC_FLAG_WAIT_D3;
215		return OK;
216		}
217
218		cond->head.known_type = res->known_type;
219		cond->head.known = res->known;
220
221		err = xl_take(cond->head.known_type);
222		if (err != OK)
223		return err;
224		err = xl_take(cond->head.known.any);
225		if (err != OK)
226		return err;
227
228		cond->head.flags \|= XL_DAGC_FLAG_COMPLETE;
229		return OK;
230		}
231
232		no_ignore static xl_error
233		_eval_store(struct xl_env env, struct xl_dagc_store node)
234		{
235		xl_error err;
236
237		node->head.known_type = node->value->known_type;
238		node->head.known = node->value->known;
239
240		err = xl_take(node->head.known.any);
241		if (err != OK)
242		return err;
243
244		err = xl_take(node->head.known_type);
245		if (err != OK)
246		return err;
247
248		node->head.flags \|= XL_DAGC_FLAG_COMPLETE;
249		return xl_env_set(
250		env, node->loc, node->value->known, node->value->known_type);
251		}
252
253		no_ignore static xl_error
254		_eval_input(struct xl_env env, struct xl_dagc_input node)
255		{
256		unused(env);
257		unused(node);
258
259		node->head.flags \|= XL_DAGC_FLAG_COMPLETE;
260		return OK;
261		}
262
263		no_ignore xl_error
264		xl_dagc_node_eval(
265		struct xl_env *env,
266		struct xl_dagc_node *node)
267		{
268		xl_error err;
269
270		xl_assert(!(node->flags & XL_DAGC_WAIT_MASK));
271
272		switch (node->node_type)
273		{
274		case DAGC_NODE_APPLY:
275		err = _eval_apply(env, (struct xl_dagc_apply *) node);
276		break;
277		case DAGC_NODE_CONST:
278		err = _eval_const(env, (struct xl_dagc_const *) node);
279		break;
280		case DAGC_NODE_LOAD:
281		err = _eval_load(env, (struct xl_dagc_load *) node);
282		break;
283		case DAGC_NODE_STORE:
284		err = _eval_store(env, (struct xl_dagc_store *) node);
285		break;
286		case DAGC_NODE_INPUT:
287		err = _eval_input(env, (struct xl_dagc_input *) node);
288		break;
289		case DAGC_NODE_COND:
290		err = _eval_cond(env, (struct xl_dagc_cond *) node);
291		break;
292		case DAGC_NODE_REF:
293		err = _eval_ref(env, (struct xl_dagc_ref *) node);
294		break;
295		case DAGC_NODE_NATIVE:
296		return xl_raise(ERR_BAD_TYPE, "node_eval: can't eval native");
297		default:
298		return xl_raise(ERR_UNKNOWN_TYPE, "node_eval");
299		}
300
301		if (err != OK)
302		return err;
303
304		return OK;
305		}

-92

~~libexpel/explain.c~~ less more

0		/*
1		* explain.c: human descriptions of runtime objects
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		#include <inttypes.h>
20		#include <stdio.h>
21		#include <stdlib.h>
22
23		#include "ubik/dagc.h"
24		#include "ubik/ubik.h"
25		#include "ubik/uri.h"
26		#include "ubik/util.h"
27
28		char *
29		xl_node_explain(struct xl_dagc_node *node)
30		{
31		union xl_dagc_any_node *n;
32		char *res;
33		char *node_type;
34		char *id;
35		char *uri;
36		int aspr_res;
37
38		node_type = xl_word_explain(node->node_type);
39		id = xl_word_explain(node->id);
40
41		n = (union xl_dagc_any_node *) node;
42
43		if (node->node_type == DAGC_NODE_CONST)
44		{
45		if (*n->as_const.value.tag ==
46		(TAG_VALUE \| TAG_LEFT_WORD \| TAG_RIGHT_WORD))
47		{
48		aspr_res = asprintf(
49		&res,
50		"%s %s @%hx = (0x%02" PRIX64 ", 0x%02" PRIX64 ")",
51		node_type, id, (short)((uintptr_t) n),
52		n->as_const.value.tree->left.w,
53		n->as_const.value.tree->right.w);
54		}
55		else
56		{
57		aspr_res = asprintf(
58		&res, "%s %s @%hx tag = 0x%hx",
59		node_type, id, (short)((uintptr_t) n),
60		*n->as_const.value.tag);
61		}
62		}
63		else if (node->node_type == DAGC_NODE_LOAD)
64		{
65		uri = xl_uri_explain(n->as_load.loc);
66		aspr_res = asprintf(
67		&res, "%s %s @%hx uri %s",
68		node_type, id, (short)((uintptr_t) n), uri);
69		free(uri);
70		}
71		else if (node->node_type == DAGC_NODE_STORE)
72		{
73		uri = xl_uri_explain(n->as_store.loc);
74		aspr_res = asprintf(
75		&res, "%s %s @%hx uri %s",
76		node_type, id, (short)((uintptr_t) n), uri);
77		free(uri);
78		}
79		else
80		{
81		aspr_res = asprintf(
82		&res, "%s %s @%hx",
83		node_type, id, (short)((uintptr_t) n));
84		}
85
86		if (aspr_res < 0)
87		res = NULL;
88		free(node_type);
89		free(id);
90		return res;
91		}

-589

~~libexpel/gc.c~~ less more

0		/*
1		* refcount.c: reference counting implementation
2		* Copyright (C) 2016, Haldean Brown
3		*
4		* This program is free software; you can redistribute it and/or modify
5		* it under the terms of the GNU General Public License as published by
6		* the Free Software Foundation; either version 2 of the License, or
7		* (at your option) any later version.
8		*
9		* This program is distributed in the hope that it will be useful,
10		* but WITHOUT ANY WARRANTY; without even the implied warranty of
11		* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12		* GNU General Public License for more details.
13		*
14		* You should have received a copy of the GNU General Public License along
15		* with this program; if not, write to the Free Software Foundation, Inc.,
16		* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17		*/
18
19		/* Define XL_GC_DEBUG to have garbage collection information
20		* printed to stderr. */
21
22		#include <stdio.h>
23		#define gc_out stderr
24
25		#include <inttypes.h>
26		#include <stdbool.h>
27		#include <stdlib.h>
28		#include <string.h>
29
30		#include "ubik/assert.h"
31		#include "ubik/dagc.h"
32		#include "ubik/ubik.h"
33		#include "ubik/gc.h"
34		#include "ubik/pointerset.h"
35		#include "ubik/stream.h"
36		#include "ubik/uri.h"
37		#include "ubik/util.h"
38		#include "ubik/vector.h"
39		#include "ubik/value.h"
40
41		static struct xl_gc_info *gc_stats;
42
43		static struct xl_vector graph_alloc = {0};
44		static struct xl_vector graph_freed = {0};
45
46		static struct xl_vector value_alloc = {0};
47		static struct xl_vector value_freed = {0};
48
49		static struct xl_uri *graph_trace = NULL;
50		static char *graph_trace_str = NULL;
51
52		void
53		xl_gc_start()
54		{
55		char *trace_uri_str;
56		char *buf;
57		xl_error err;
58
59		if (unlikely(gc_stats != NULL))
60		free(gc_stats);
61		gc_stats = calloc(1, sizeof(struct xl_gc_info));
62		xl_assert(gc_stats != NULL);
63
64		trace_uri_str = getenv("EXPEL_TRACE_GRAPH");
65		if (trace_uri_str != NULL)
66		{
67		graph_trace = calloc(1, sizeof(struct xl_uri));
68		if (graph_trace == NULL)
69		{
70		fprintf(gc_out, "couldn't trace: alloc uri failed\n");
71		return;
72		}
73
74		err = xl_uri_parse(graph_trace, trace_uri_str);
75		if (err != OK)
76		{
77		buf = xl_error_explain(err);
78		fprintf(gc_out, "couldn't trace: parse uri failed: %s\n", buf);
79		free(buf);
80		free(graph_trace);
81		graph_trace = NULL;
82		return;
83		}
84
85		err = xl_take(graph_trace);
86		if (err != OK)
87		{
88		buf = xl_error_explain(err);
89		fprintf(gc_out, "couldn't trace: take uri failed: %s\n", buf);
90		free(buf);
91		free(graph_trace);
92		free(graph_trace->name);
93		if (graph_trace->source != NULL)
94		free(graph_trace->source);
95		graph_trace = NULL;
96		return;
97		}
98
99		graph_trace_str = trace_uri_str;
100		fprintf(gc_out, "tracing %s\n", graph_trace_str);
101		}
102		}
103
104		void
105		xl_gc_teardown()
106		{
107		xl_error err;
108
109		#if XL_GC_DEBUG && XL_GC_DEBUG_V
110		size_t i;
111		bool present;
112		bool any_leaked;
113		struct xl_dagc *graph;
114		struct xl_value *value;
115		char *buf;
116		struct xl_stream s;
117
118		err = xl_stream_wfilep(&s, gc_out);
119		if (err != OK)
120		{
121		fprintf(gc_out, "couldn't open stream to gc output\n");
122		return;
123		}
124
125		fprintf(gc_out, "========================================\ngc stats:\n");
126		fprintf(gc_out, "alloc %lu vals, %lu freed, %ld remaining\n",
127		gc_stats->n_val_allocs,
128		gc_stats->n_val_frees,
129		(int64_t) gc_stats->n_val_allocs - gc_stats->n_val_frees);
130		fprintf(gc_out, "alloc %lu graphs, %lu freed, %ld remaining\n",
131		gc_stats->n_graph_allocs,
132		gc_stats->n_graph_frees,
133		(int64_t) gc_stats->n_graph_allocs - gc_stats->n_graph_frees);
134
135		fprintf(gc_out, "========================================\nleaked graphs:\n");
136		any_leaked = false;
137		for (i = 0; i < graph_alloc.n; i++)
138		{
139		graph = (struct xl_dagc *) graph_alloc.elems[i];
140		err = xl_pointer_set_present(&present, &graph_freed, graph);
141		if (err != OK \|\| present)
142		continue;
143		any_leaked = true;
144
145		fprintf(gc_out, "%016" PRIxPTR ":\n", (uintptr_t) graph);
146		fprintf(gc_out, "\t%lu leaked refs\n", graph->refcount);
147
148		if (graph->identity == NULL)
149		buf = NULL;
150		else
151		buf = xl_uri_explain(graph->identity);
152		fprintf(gc_out, "\tidentity %s\n", buf);
153		if (buf != NULL)
154		free(buf);
155
156		fprintf(gc_out, "\tin arity %lu\n", graph->in_arity);
157		}
158		if (!any_leaked)
159		fprintf(gc_out, "none!\n");
160
161		fprintf(gc_out, "========================================\nleaked values:\n");
162		any_leaked = false;
163		for (i = 0; i < value_alloc.n; i++)
164		{
165
166		value = (struct xl_value *) value_alloc.elems[i];
167		err = xl_pointer_set_present(&present, &value_freed, value);
168		if (err != OK \|\| present)
169		continue;
170		any_leaked = true;
171
172		fprintf(gc_out, "%016" PRIxPTR ":\n", (uintptr_t) value);
173		fprintf(gc_out, "\t%lu leaked refs\n", value->refcount);
174		fprintf(gc_out, "\t");
175		err = xl_value_print(&s, value);
176		if (err != OK)
177		fprintf(gc_out, "...couldn't print value");
178		fprintf(gc_out, "\n");
179		}
180		if (!any_leaked)
181		fprintf(gc_out, "none!\n");
182		fprintf(gc_out, "========================================\n");
183		#endif
184
185		xl_vector_free(&graph_alloc);
186		xl_vector_free(&graph_freed);
187		xl_vector_free(&value_alloc);
188		xl_vector_free(&value_freed);
189
190		xl_gc_free_all();
191		free(gc_stats);
192		gc_stats = NULL;
193
194		if (graph_trace != NULL)
195		{
196		err = xl_release(graph_trace);
197		if (err != OK)
198		fprintf(gc_out, "couldn't free graph trace\n");
199		graph_trace = NULL;
200		}
201		}
202
203		void
204		xl_gc_get_stats(struct xl_gc_info *stats)
205		{
206		memcpy(stats, gc_stats, sizeof(struct xl_gc_info));
207		}
208
209		void
210		xl_gc_free_all()
211		{
212		}
213
214		no_ignore xl_error
215		xl_dagc_alloc(
216		struct xl_dagc **graph,
217		size_t n_nodes,
218		size_t size,
219		void *copy_from)
220		{
221		size_t i;
222		union xl_dagc_any_node *node_memory;
223
224		#if XL_GC_DEBUG && XL_GC_DEBUG_V
225		xl_error err;
226		#endif
227
228		*graph = calloc(1, size);
229		if (*graph == NULL)
230		return xl_raise(ERR_NO_MEMORY, "graph allocation");
231
232		#if XL_GC_DEBUG
233		#if XL_GC_DEBUG_V
234		fprintf(gc_out, "alloc graph %hx\n",
235		(uint16_t) ((uintptr_t) *graph));
236		err = xl_pointer_set_add(NULL, &graph_alloc, *graph);
237		if (err != OK)
238		return err;
239		#endif
240		gc_stats->n_graph_allocs++;
241		#endif
242
243		if (copy_from != NULL)
244		memcpy(*graph, copy_from, size);
245
246		/* Every node is a different size in this regime of ours, which means we
247		* can't just allocate a list of xl_dagc_nodes and call it a day; they
248		* would all be too small. But we want the API of the graph to make it
249		* look like everything is a node, so here's what we do; we allocate a
250		* big memory region that we're going to use for all of our nodes, and
251		* then we make references into that region that are all spaced
252		* max-node-sized apart. While this means there's an extra indirection
253		* for each access to a node, sequential node access is rare and the API
254		* niceness is worth it. */
255		node_memory = calloc(n_nodes, sizeof(union xl_dagc_any_node));
256		if (node_memory == NULL)
257		return xl_raise(ERR_NO_MEMORY, "graph allocation");
258
259		(graph)->nodes = calloc(n_nodes, sizeof(struct xl_dagc_node ));
260		if ((*graph)->nodes == NULL)
261		return xl_raise(ERR_NO_MEMORY, "graph allocation");
262
263		for (i = 0; i < n_nodes; i++)
264		{
265		(graph)->nodes[i] = (struct xl_dagc_node ) &node_memory[i];
266		}
267		(*graph)->n = n_nodes;
268		return OK;
269		}
270
271		/* Creates a new value. */
272		no_ignore xl_error
273		xl_value_new(struct xl_value **v)
274		{
275		#if XL_GC_DEBUG && XL_GC_DEBUG_V
276		xl_error err;
277		#endif
278
279		xl_assert(gc_stats != NULL);
280
281		*v = calloc(1, sizeof(struct xl_value));
282		if (*v == NULL)
283		return xl_raise(ERR_NO_MEMORY, "new value");
284		(*v)->tag = TAG_VALUE;
285		(*v)->refcount = 1;
286
287		#if XL_GC_DEBUG
288		gc_stats->n_val_allocs++;
289
290		#if XL_GC_DEBUG_V
291		err = xl_pointer_set_add(NULL, &value_alloc, *v);
292		if (err != OK)
293		return err;
294		#endif
295		#endif
296
297		return OK;
298		}
299
300		/* Takes a reference to the given tree. */
301		no_ignore xl_error
302		xl_take(void *p)
303		{
304		struct xl_value *v;
305		struct xl_dagc *g;
306		struct xl_uri *u;
307		xl_tag tag;
308
309		tag = ((xl_tag ) p);
310
311		if ((tag & TAG_TYPE_MASK) == TAG_VALUE)
312		{
313		v = (struct xl_value *) p;
314		if (unlikely(v->refcount == UINT64_MAX))
315		return xl_raise(ERR_REFCOUNT_OVERFLOW, "take");
316		v->refcount++;
317		return OK;
318		}
319		if ((tag & TAG_TYPE_MASK) == TAG_GRAPH)
320		{
321		g = (struct xl_dagc *) p;
322		if (unlikely(g->refcount == UINT64_MAX))
323		return xl_raise(ERR_REFCOUNT_OVERFLOW, "take");
324		g->refcount++;
325
326		if (g->identity != NULL && graph_trace != NULL
327		&& unlikely(xl_uri_eq(g->identity, graph_trace)))
328		{
329		fprintf(gc_out, "\ntaking ref to traced %s\n", graph_trace_str);
330		fprintf(gc_out, "addr 0x%" PRIxPTR " arity %lu new ref %lu\n",
331		(uintptr_t) g, g->in_arity, g->refcount);
332		xl_trace_print();
333		}
334		return OK;
335		}
336		if ((tag & TAG_TYPE_MASK) == TAG_URI)
337		{
338		u = (struct xl_uri *) p;
339		if (unlikely(u->refcount == UINT64_MAX))
340		return xl_raise(ERR_REFCOUNT_OVERFLOW, "take");
341		u->refcount++;
342		return OK;
343		}
344		return xl_raise(ERR_BAD_TAG, "take");
345		}
346
347		/* Releases a reference to the given tree. */
348		no_ignore static xl_error
349		_release_value(struct xl_value *v)
350		{
351		xl_error err;
352
353		if (unlikely(v->refcount == 0))
354		return xl_raise(ERR_REFCOUNT_UNDERFLOW, "release");
355		v->refcount--;
356
357		err = OK;
358
359		if (v->refcount == 0)
360		{
361		if (v->tag & (TAG_LEFT_NODE \| TAG_LEFT_GRAPH))
362		err = xl_release(v->left.any);
363		if (err == OK && (v->tag & (TAG_RIGHT_NODE \| TAG_RIGHT_GRAPH)))
364		err = xl_release(v->right.any);
365
366		#if XL_GC_DEBUG
367		gc_stats->n_val_frees++;
368		#if XL_GC_DEBUG_V
369		err = xl_pointer_set_add(NULL, &value_freed, v);
370		if (err != OK)
371		return err;
372		#endif
373		#endif
374
375		free(v);
376		}
377
378		return err;
379		}
380
381		no_ignore static xl_error
382		_release_node(struct xl_dagc_node *node)
383		{
384		union xl_dagc_any_node *n;
385		xl_error err;
386
387		n = (union xl_dagc_any_node *) node;
388
389		switch (node->node_type)
390		{
391		case DAGC_NODE_APPLY:
392		case DAGC_NODE_COND:
393		case DAGC_NODE_INPUT:
394		case DAGC_NODE_NATIVE:
395		case DAGC_NODE_REF:
396		break;
397
398		case DAGC_NODE_CONST:
399		err = xl_release(n->as_const.type);
400		if (err != OK)
401		return err;
402		err = xl_release(n->as_const.value.any);
403		if (err != OK)
404		return err;
405		break;
406
407		case DAGC_NODE_LOAD:
408		err = xl_release(n->as_load.loc);
409		if (err != OK)
410		return err;
411		break;
412
413		case DAGC_NODE_STORE:
414		err = xl_release(n->as_store.loc);
415		if (err != OK)
416		return err;
417		break;
418
419		default:
420		return xl_raise(ERR_UNKNOWN_TYPE, "release node: node type");
421		}
422
423		if (node->known_type != NULL)
424		{
425		err = xl_release(node->known_type);
426		if (err != OK)
427		return err;
428		}
429		if (node->known.any != NULL)
430		{
431		err = xl_release(node->known.any);
432		if (err != OK)
433		return err;
434		}
435		return OK;
436		}
437
438		no_ignore static xl_error
439		_release_graph(struct xl_dagc *g)
440		{
441		size_t i;
442		xl_error err;
443		uint64_t self_refs;
444		struct xl_dagc_const *n;
445
446		#if XL_GC_DEBUG && XL_GC_DEBUG_V
447		char *buf;
448		#endif
449
450		if (unlikely(g->refcount == 0))
451		return xl_raise(ERR_REFCOUNT_UNDERFLOW, "release");
452		g->refcount--;
453
454		if (g->identity != NULL && graph_trace != NULL
455		&& unlikely(xl_uri_eq(g->identity, graph_trace)))
456		{
457		fprintf(gc_out, "\nreleasing ref to traced %s\n",
458		graph_trace_str);
459		fprintf(gc_out, "addr 0x%" PRIxPTR " arity %lu new ref %lu\n",
460		(uintptr_t) g, g->in_arity, g->refcount);
461		xl_trace_print();
462		}
463
464		self_refs = 0;
465		for (i = 0; i < g->n; i++)
466		{
467		if (g->nodes[i]->known.graph == g)
468		self_refs++;
469
470		n = (struct xl_dagc_const *) g->nodes[i];
471		if (n->head.node_type != DAGC_NODE_CONST)
472		continue;
473		if (n->value.graph == g)
474		self_refs++;
475		}
476
477		if (g->refcount > self_refs)
478		return OK;
479
480		for (i = 0; i < g->n; i++)
481		{
482		err = _release_node(g->nodes[i]);
483		if (err != OK)
484		return err;
485		}
486		/* This is tricky; the nodes are allocated all at once, even though it
487		* looks like they're all allocated on their own. Check out
488		* xl_dagc_graph_alloc for more deets. */
489		free(g->nodes[0]);
490		free(g->nodes);
491
492		for (i = 0; i < g->n; i++)
493		free(g->adjacency[i].parents);
494		free(g->adjacency);
495
496		free(g->inputs);
497		free(g->terminals);
498
499		#if XL_GC_DEBUG
500		#if XL_GC_DEBUG_V
501		fprintf(gc_out, "free graph %hx\n",
502		(uint16_t) ((uintptr_t) g));
503		fprintf(gc_out, "\tarity %lu\n", g->in_arity);
504		if (g->identity != NULL)
505		{
506		buf = xl_uri_explain(g->identity);
507		fprintf(gc_out, "\tidentity %s (%lu)\n",
508		buf, g->identity->refcount);
509		free(buf);
510		}
511		else
512		fprintf(gc_out, "\tidentity null\n");
513		err = xl_pointer_set_add(NULL, &graph_freed, g);
514		if (err != OK)
515		return err;
516		#endif
517		gc_stats->n_graph_frees++;
518		#endif
519
520		if (g->identity != NULL)
521		{
522		err = xl_release(g->identity);
523		if (err != OK)
524		return err;
525		}
526
527