git.haldean.org expel / f0f96db
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
0 expelc/expelc
1 expelc/expeli
2 runexpel/runexpel
0 ub/ubic
1 ub/ubi
2 ubik/ubik
33
44 dist
55 build
0 SUBDIRS = include libexpel expelc runexpel test/unit test/pyasm test/prog
0 SUBDIRS = include libubik ub ubik test/unit test/pyasm test/prog
0 Architecture of the Expel Runtime ======================================
0 Architecture of the Ubik Runtime =======================================
11 Haldean Brown First draft: Nov 2015
22 Last updated: Mar 2016
33
44
55 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
77 is incorrect; on the other hand, don't trust anything in this document.
88
99
1010 Structure of the project -----------------------------------------------
1111
1212 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
1818 implementation. And then there's pyasm, which is a hilarious "assembler"
1919 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
2121 to stay.
2222
2323 There are unit tests and "integration tests"; unit tests are haphazard
2525 test/pyasm/*.xlpy) are pretty comprehensive. You can run all of the
2626 tests by running `make check`.
2727
28 To build and test expel, run the following commands:
28 To build and test ubik, run the following commands:
2929
3030 ./configure
3131 make check
3232
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
3434 instead of from a tarball), you will need to run:
3535
3636 autoreconf --install
3737
3838 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
4141 these to your system path (along with the headers and static library),
4242 use:
4343
4848 It does some simple checks to make sure that you're not doing anything
4949 dumb.
5050
51 For completeness, building Expel requires:
51 For completeness, building Ubik requires:
5252
5353 - GCC 4.9 or later (it's possible that the build works with other
5454 versions of GCC and with clang, but they're untested)
5656 - Flex 2.6 or later
5757 - GNU autoconf 2.69 or later
5858
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
6060 document is more interesting, I promise.
6161
6262
6363 Runtime representations ------------------------------------------------
6464
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
6666 values (called "words"). Everything is expressed in this way, from
6767 integers to types to functions; this homogeneity of data representation
6868 allows us to simplify otherwise-complicated tasks and has a satisfying
6969 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.
7171
7272 Each node in the tree has a left value, a right value, and a tag. Each
7373 value can be one of two things: a pointer to another node or a word; the
109109 they are identified only by an integer constant; derived types (quite
110110 predictably) require quite a bit more information about the type itself.
111111
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.
113113 Each of these has a base type code and comes with a tree encoding. The
114114 full list of base type codes is:
115115
170170 appear on the left of a typed value is a type descriptor value, and
171171 could appear on the right of a type node.
172172
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
174174 identified. Resources all have a name, author, version and scope; all of
175175 these are encoded in the URI tree. The left of a URI tree is the
176176 constant word `uri`, and the right is a cons-cell list, where the first
184184
185185 Building logic ---------------------------------------------------------
186186
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
188188 (DAGC); nodes in this graph then reference values stored as trees. There
189189 are four kinds of nodes in a DAGC:
190190
213213 evaluating them just calls the associated native
214214 code block. That code block then fills in the result
215215 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
217217 supported; this is only a construct used internally
218218 in the runtime.
219219 `ref` This node has the value of another node in the
230230 terminal nodes is found, and all nodes in that set are evaluated in
231231 turn. This gives the result for the DAGC. Once evaluated, the DAGC is
232232 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
234234 zero-arity function is equivalent to a value.
235235
236236 Logic is then built up by creating a number of graphs and referencing
239239 completed. Once all required input nodes have been completed, the DAGC
240240 can be evaluated.
241241
242 An expel bytecode blob contains some number of graphs; the various
242 An ubik bytecode blob contains some number of graphs; the various
243243 graphs can reference each other, and in general their ordering in the
244244 bytecode does not matter. There is only one exception: when evaluating a
245245 bytecode blob, the first graph is considered to represent the desired
249249
250250 Encoding in-flight and at-rest -----------------------------------------
251251
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
253253 network operations and for on-disk storage. The format begins with a
254254 header, and then contains a number of encoded graphs.
255255
368368 Byte index Field
369369 0-7 Node index of referrent node
370370
371 Expel bytecode blobs may have arbitrary data following the data encoded
371 Ubik bytecode blobs may have arbitrary data following the data encoded
372372 by the standard; conforming parsers will ignore the data that follows
373373 the encoded graphs. This is provided as a means for tools to attach
374374 metadata onto the end of the bytecode if so desired.
375375
376376 Compilation ------------------------------------------------------------
377377
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
379379 compiler executable can be built using:
380380
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
383383
384384 The process of creating an executable is divided into two phases, not
385385 unlike compilation for C and other native languages: compilation and
390390 the details away from the user, but they still get the advantage of
391391 fast, incremental builds.
392392
393 Compilation begins by loading the given Expel file and generating code
393 Compilation begins by loading the given Ubik file and generating code
394394 for the module (see below). In general, at the end of this process there
395395 are still unresolved references; we collect all of the imports that
396396 provide those references, and find the files that provide the requisite
11 # Process this file with autoconf to produce a configure script.
22
33 AC_PREREQ([2.69])
4 AC_INIT([expel], [0.1], [expel@haldean.org])
4 AC_INIT([ubik], [0.1], [ubik@haldean.org])
55
66 # Use automake to compile Makefile.ac to Makefile.in
77 AM_INIT_AUTOMAKE([foreign -Wall -Werror])
88
99 # Make sure we're running in the right directory
10 AC_CONFIG_SRCDIR([libexpel/rt.c])
10 AC_CONFIG_SRCDIR([libubik/rt.c])
1111
1212 AC_CONFIG_HEADERS([config.h])
1313
4444 AC_FUNC_REALLOC
4545 AC_CHECK_FUNCS([backtrace backtrace_symbols_fd bzero clock_gettime fmemopen getcwd memmove memset strdup])
4646
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
4949 test/pyasm/Makefile])
5050 AC_OUTPUT
+0
-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
+0
-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
+0
-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
+0
-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
+0
-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 $< $@
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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 }
+0
-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