├── .gitignore ├── README.md ├── block_list.c ├── btree.c ├── datalog.opam ├── datalog ├── dune ├── graphviz.ml ├── ruleset.ml └── ruleset.mli ├── display-names ├── dune ├── fresh.ml └── fresh.mli ├── display_names.opam ├── edge.csv ├── emptytuple.mlog ├── expr.mlog ├── ext.mlog ├── idealised-algol ├── block_list.ml ├── btree.ml ├── c.ml ├── c.mli ├── dune ├── stack.ml └── syntax.ml ├── idealised_algol.opam ├── ifds.mlog ├── ifds2.mlog ├── modules.opam ├── modules ├── README.md ├── dune ├── evaluator.ml ├── evaluator.mli ├── ident.ml ├── ident.mli ├── modules_grammar.mly ├── path.ml ├── path.mli ├── subst.ml ├── subst.mli ├── syntax.ml ├── syntax.mli ├── typing.ml ├── typing.mli ├── typing_environment.ml └── typing_environment.mli ├── modulog-bin.opam ├── modulog-bin ├── driver.ml └── dune ├── modulog.opam ├── modulog ├── checked_syntax.ml ├── checked_syntax.mli ├── checker.ml ├── checker.mli ├── core_syntax.ml ├── datalog_grammar.mly ├── dune ├── lexer.mll ├── location.ml ├── location.mli ├── parser.messages ├── parser_driver.ml ├── std.ml ├── syntax.ml ├── syntax.mli ├── to_rules.ml └── to_rules.mli ├── newtype.mlog ├── notes.md ├── paths.mlog ├── paths2.mlog ├── pointsto.mlog ├── rec-unsafe.mlog ├── rec.mlog ├── relation_machine ├── codegen.ml ├── codegen_csv.ml ├── codegen_double_buf.ml ├── codegen_indexed_table.ml ├── codegen_inttuple.ml ├── dune ├── indexes.ml ├── indexes.mli ├── interpreter.ml ├── interpreter.mli ├── minimalpathcover.ml ├── minimalpathcover.mli ├── of_rules.ml ├── of_rules.mli ├── syntax.ml └── syntax.mli ├── safety_test.mlog ├── simple.mlog ├── with_test1.mlog ├── with_test2.mlog ├── with_test3.mlog ├── with_test4.mlog └── with_test5.mlog /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | *.s 4 | /_build 5 | .merlin 6 | /*.install -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ModuLog : Modular Datalog 2 | 3 | This is an implementation of Datalog with an OCaml like module system, 4 | including module signatures and higher order modules via functors. The 5 | addition of a module system endows Datalog with two previously missing 6 | features: code reuse and type abstraction. Modulog was motivated by 7 | previous attempts to use the C preprocessor or other text munging to 8 | do hacky code reuse in Datalog for points to analysis. 9 | 10 | At the moment Modulog has the following features: 11 | 12 | - Basic Datalog (no negation, aggregation, etc.) 13 | - An OCaml inspired module system, based on Leroy's [modular 14 | modules](http://caml.inria.fr/pub/papers/xleroy-modular_modules-jfp.pdf). This 15 | is implemented in a core-language generic way, so it could 16 | plausibly be reused for 17 | - An bottom-up interpreter that can read input data from CSV files. 18 | - Compilation to C, currently incomplete (doesn't support reading 19 | external input yet). 20 | 21 | Example: 22 | 23 | ``` 24 | module type Edges = sig 25 | type vertex 26 | 27 | pred edge : vertex * vertex 28 | end 29 | 30 | module MyEdges = struct 31 | type vertex = int 32 | 33 | define edge : vertex * vertex 34 | edge(1, 2) 35 | edge(2, 3) 36 | edge(3, 4) 37 | edge(4, 1) 38 | end 39 | 40 | module Path (E : Edges) = struct 41 | 42 | type vertex = E.vertex 43 | 44 | define path : E.vertex * E.vertex 45 | path(?X,?Y) :- E.edge(?X,?Y) 46 | path(?X,?Z) :- path(?X,?Y), E.edge(?Y,?Z) 47 | 48 | end 49 | 50 | module P = Path (MyEdges) 51 | ``` 52 | 53 | Still to do: 54 | 55 | - Finish the C output to be able to read in initial data from CSV 56 | files. 57 | - More expressive datatype language. 58 | 59 | ## Related work 60 | 61 | - [*A calculus for the construction of modular prolog 62 | programs*](https://www.sciencedirect.com/science/article/pii/0743106692900422) 63 | by Donald T. Sannella and Lincoln A. Wallen, J. Logic Programming, 64 | vol 12, issues 1-2, January 1992, pages 147-177. 65 | 66 | - [*QL: Object-oriented Queries on Relational 67 | Data*](https://doi.org/10.4230/LIPIcs.ECOOP.2016.2) by Pavel 68 | Avgustinov, Oege de Moor, Michael Peyton Jones, and Max Schäfer, 69 | ECOOP 2016: 2:1-2:25. DOI: 10.4230/LIPIcs.ECOOP.2016.2 70 | -------------------------------------------------------------------------------- /block_list.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #define BLOCK_SIZE 16 5 | 6 | typedef struct _list_node list_node; 7 | 8 | struct _list_node { 9 | int occupied; 10 | int values[BLOCK_SIZE]; 11 | list_node *next; 12 | }; 13 | 14 | void insert (list_node **head, int value) 15 | { 16 | if (*head == NULL) { 17 | *head = malloc (sizeof(list_node)); 18 | 19 | if (*head == NULL) { 20 | fprintf (stderr, "Failed to allocate memory for node"); 21 | exit (EXIT_FAILURE); 22 | } 23 | 24 | (*head)->occupied = 1; 25 | (*head)->values[0] = value; 26 | (*head)->next = NULL; 27 | } else if ((*head)->occupied == BLOCK_SIZE) { 28 | list_node *new_head = malloc (sizeof(list_node)); 29 | 30 | if (new_head == NULL) { 31 | fprintf (stderr, "Failed to allocate memory for node"); 32 | exit (EXIT_FAILURE); 33 | } 34 | 35 | new_head->occupied = 1; 36 | new_head->values[0] = value; 37 | new_head->next = *head; 38 | 39 | *head = new_head; 40 | } else { 41 | (*head)->values[(*head)->occupied] = value; 42 | (*head)->occupied++; 43 | } 44 | } 45 | 46 | void iterate (list_node *node) 47 | { 48 | while (node != NULL) { 49 | for (int i = 0; i < node->occupied; i++) 50 | printf ("%d\n", node->values[i]); 51 | 52 | node = node->next; 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /btree.c: -------------------------------------------------------------------------------- 1 | /* Lets write a btree! Keys will be ints. */ 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | struct mykey { 12 | uint32_t a1; 13 | uint32_t a2; 14 | uint32_t a3; 15 | uint32_t a4; 16 | }; 17 | 18 | int mykey_cmp (struct mykey x, struct mykey y) 19 | { 20 | return 21 | x.a1 != y.a1 ? (x.a1 < y.a1 ? -1 : 1) : 22 | x.a2 != y.a2 ? (x.a2 < y.a2 ? -1 : 1) : 23 | x.a3 != y.a3 ? (x.a3 < y.a3 ? -1 : 1) : 24 | x.a4 != y.a4 ? (x.a4 < y.a4 ? -1 : 1) : 25 | 0; 26 | } 27 | 28 | int mykey_eq (struct mykey x, struct mykey y) 29 | { 30 | return x.a1 == y.a1 && x.a2 == y.a2 && x.a3 == y.a3 && x.a4 == y.a4; 31 | } 32 | 33 | int mykey_lt (struct mykey x, struct mykey y) 34 | { 35 | return 36 | x.a1 < y.a1 37 | || (x.a1 == y.a1 38 | && (x.a2 < y.a2 39 | || (x.a2 == y.a2 40 | && (x.a3 < y.a3 41 | || (x.a3 == y.a3 42 | && x.a4 < y.a4))))); 43 | } 44 | 45 | 46 | 47 | #define MIN_CHILDREN 8 48 | 49 | typedef struct _node node; 50 | 51 | struct _node { 52 | bool leaf; 53 | short nkeys; 54 | int key[2*MIN_CHILDREN-1]; 55 | node *children[0]; 56 | }; 57 | 58 | node *allocate_node (bool leaf) 59 | { 60 | size_t size = sizeof(node) + (leaf?0:sizeof(node*)*2*MIN_CHILDREN); 61 | node *x = malloc (size); 62 | if (x == NULL) { 63 | fprintf (stderr, "Failed to allocate node"); 64 | exit (EXIT_FAILURE); 65 | } 66 | 67 | x->leaf = leaf; 68 | 69 | return x; 70 | } 71 | 72 | void print_tree (node * node, int indent) 73 | { 74 | if (node->leaf) { 75 | for (int i = 0; i < indent*2; i++) putchar (' '); 76 | putchar ('['); 77 | for (int i = 0; i < node->nkeys; i++) printf (" %d", node->key[i]); 78 | printf (" ]\n"); 79 | } else { 80 | for (int i = 0; i < indent*2; i++) putchar (' '); 81 | printf ("[\n"); 82 | for (int i = 0; i <= node->nkeys; i++) { 83 | print_tree (node->children[i], indent+1); 84 | if (i != node->nkeys) { 85 | for (int i = 0; i < indent*2; i++) putchar (' '); 86 | printf ("%d\n", node->key[i]); 87 | } 88 | } 89 | for (int i = 0; i < indent*2; i++) putchar (' '); 90 | printf ("]\n"); 91 | } 92 | } 93 | 94 | 95 | node* create() 96 | { 97 | node *x = allocate_node (true); 98 | 99 | x->nkeys = 0; 100 | 101 | return x; 102 | } 103 | 104 | 105 | /* this seems to slow things down at the moment, but might be faster 106 | * if key comparisons become more expensive. */ 107 | int bin_search (int *keys, int lo, int hi, int key) 108 | { 109 | while (lo <= hi) { 110 | int mid = (hi + lo)/2; 111 | if (keys[mid] == key) 112 | return mid; 113 | else if (keys[mid] > key) 114 | hi = mid-1; 115 | else 116 | lo = mid+1; 117 | } 118 | return hi+1; 119 | } 120 | 121 | 122 | bool member(int key, node *x) 123 | { 124 | int i; 125 | 126 | while (true) { 127 | for (i = 0; i < x->nkeys && x->key[i] < key; i++); 128 | 129 | if (i < x->nkeys && x->key[i] == key) 130 | return true; 131 | 132 | if (x->leaf) 133 | return false; 134 | 135 | x = x->children[i]; 136 | } 137 | } 138 | 139 | bool member_range (int from, int to, node *x) 140 | { 141 | int i; 142 | 143 | while (true) { 144 | for (i = 0; i < x->nkeys && x->key[i] < from; i++); 145 | 146 | if (i < x->nkeys && x->key[i] <= to) 147 | return true; 148 | 149 | if (x->leaf) 150 | return false; 151 | 152 | x = x->children[i]; 153 | } 154 | } 155 | 156 | /* iterate_range (from, to, x) prints out all the keys stored in [x] 157 | * between [from] and [to], inclusive. 158 | */ 159 | void iterate_range (int from, int to, node *x) 160 | { 161 | node *stack[30]; 162 | int stack_child[30]; 163 | int stackptr = 0; 164 | int i; 165 | 166 | /* FIXME: could also store a parent pointer/index in each node 167 | * (except the root). At a cost of one pointer and a small 168 | * integer per node. But then the parent index/pointers would 169 | * need to be updated during split child. 170 | * 171 | * Alternatively, use a B+-tree. When inserting, push the keys 172 | * down to the leaves. This means that, when splitting in 173 | * split_child, we don't take the key at MIN_CHILDREN-1 out of 174 | * the left child. 175 | */ 176 | 177 | /* Find 'from', or first key larger */ 178 | 179 | while (true) { 180 | for (i = 0; i < x->nkeys && x->key[i] < from; i++); 181 | 182 | if (x->leaf) break; 183 | 184 | /* only push a stack frame if we are not at the last 185 | * position -- tail recursion optimisation */ 186 | if (i < x->nkeys) { 187 | stack[stackptr] = x; 188 | stack_child[stackptr] = i; 189 | stackptr++; 190 | } 191 | 192 | x = x->children[i]; 193 | } 194 | 195 | /* We are now at a leaf node at the first key >= from; scan 196 | * through the keys until we hit the first key that is >= to. */ 197 | 198 | while (true) { 199 | for (; i < x->nkeys && x->key[i] <= to; i++) 200 | printf ("%d ", x->key[i]); 201 | 202 | if (i != x->nkeys || stackptr == 0) 203 | break; 204 | 205 | x = stack[stackptr-1]; 206 | i = stack_child[stackptr-1]; 207 | 208 | if (!(x->key[i] <= to)) 209 | break; 210 | 211 | printf ("%d ", x->key[i]); 212 | 213 | if (i == x->nkeys-1) 214 | stackptr--; 215 | else 216 | stack_child[stackptr-1] = i + 1; 217 | 218 | x = x->children[i+1]; 219 | while (!x->leaf) { 220 | stack[stackptr] = x; 221 | stack_child[stackptr] = 0; 222 | stackptr++; 223 | x = x->children[0]; 224 | } 225 | 226 | i = 0; 227 | } 228 | } 229 | 230 | void iterate_all (node *x) 231 | { 232 | node *stack[20]; 233 | int stack_child[20]; 234 | int stackptr = 0; 235 | int i; 236 | 237 | while (!x->leaf) { 238 | stack[stackptr] = x; 239 | stack_child[stackptr] = 0; 240 | stackptr++; 241 | x = x->children[0]; 242 | } 243 | 244 | while (true) { 245 | for (i = 0; i < x->nkeys; i++) 246 | printf ("%d ", x->key[i]); 247 | 248 | if (stackptr == 0) 249 | break; 250 | 251 | x = stack[stackptr-1]; 252 | i = stack_child[stackptr-1]; 253 | 254 | printf ("%d ", x->key[i]); 255 | 256 | if (i == x->nkeys-1) 257 | stackptr--; 258 | else 259 | stack_child[stackptr-1] = i + 1; 260 | 261 | x = x->children[i+1]; 262 | 263 | while (!x->leaf) { 264 | stack[stackptr] = x; 265 | stack_child[stackptr] = 0; 266 | stackptr++; 267 | x = x->children[0]; 268 | } 269 | } 270 | } 271 | 272 | void split_child (node *x, int i) 273 | { 274 | node *y = x->children[i]; 275 | node *z = allocate_node (y->leaf); 276 | 277 | z->nkeys = MIN_CHILDREN - 1; 278 | 279 | /* 280 | for (int j = 0; j < MIN_CHILDREN - 1; j++) 281 | z->key[j] = y->key[j+MIN_CHILDREN]; 282 | */ 283 | memcpy (&(z->key[0]), &(y->key[MIN_CHILDREN]), (MIN_CHILDREN-1) * sizeof(int)); 284 | 285 | if (!y->leaf) 286 | memcpy (&(z->children[0]), &(y->children[MIN_CHILDREN]), MIN_CHILDREN * sizeof(node*)); 287 | // for (int j = 0; j < MIN_CHILDREN; j++) 288 | // z->children[j] = y->children[j+MIN_CHILDREN]; 289 | 290 | /* FIXME: for B+-trees, if y is a leaf, set y->nkeys = 291 | * MIN_CHILDREN to keep the middle node in the leaf. Then also 292 | * update the next pointer (i.e. children[0]). */ 293 | y->nkeys = MIN_CHILDREN - 1; 294 | 295 | memmove (&(x->children[i+2]), &(x->children[i+1]), (x->nkeys - i) * sizeof(node*)); 296 | /* for (int j = x->nkeys; j > i; j--) { */ 297 | /* printf ("Moving child %d -> %d\n",j,j+1); */ 298 | /* x->children[j+1] = x->children[j]; */ 299 | /* } */ 300 | 301 | memmove (&(x->key[i+1]), &(x->key[i]), (x->nkeys - i) * sizeof(int)); 302 | /* for (int j = x->nkeys - 1; j >= i; j--) */ 303 | /* x->key[j+1] = x->key[j]; */ 304 | 305 | x->children[i+1] = z; 306 | x->key[i] = y->key[MIN_CHILDREN-1]; 307 | x->nkeys++; 308 | } 309 | 310 | void insert_nonfull (node *x, int key) 311 | { 312 | int i; 313 | 314 | while (!x->leaf) { 315 | for (i = 0; i < x->nkeys && x->key[i] < key; i++); 316 | 317 | if (x->children[i]->nkeys == 2*MIN_CHILDREN-1) { 318 | split_child (x, i); 319 | if (x->key[i] < key) 320 | i++; 321 | } 322 | 323 | x = x->children[i]; 324 | } 325 | 326 | /* found the leaf node for insertion */ 327 | 328 | /* for (i = 0; i < x->nkeys && x->key[i] < key; i++); */ 329 | /* memmove (&(x->key[i+1]), &(x->key[i]), (x->nkeys - i) * sizeof(int)); */ 330 | /* x->key[i] = key; */ 331 | 332 | i = x->nkeys - 1; 333 | while (i >= 0 && key < x->key[i]) { 334 | x->key[i+1] = x->key[i]; 335 | i--; 336 | } 337 | 338 | x->key[i+1] = key; 339 | 340 | x->nkeys++; 341 | } 342 | 343 | 344 | void insert(int key, node **root) 345 | { 346 | if ((*root)->nkeys == 2*MIN_CHILDREN-1) { 347 | node *s = allocate_node (false); 348 | 349 | s->nkeys = 0; 350 | s->children[0] = *root; 351 | 352 | split_child (s, 0); 353 | 354 | *root = s; 355 | } 356 | 357 | insert_nonfull (*root, key); 358 | } 359 | 360 | /**********************************************************************/ 361 | /* the other kind of insertion: rebuild the tree as we go back up */ 362 | 363 | void insert2 (int key, node **root) 364 | { 365 | /* 1. search to find the leaf node to insert into */ 366 | /* 2. if the node is now full, then split it in its parent and 367 | * insert the new item at the end of the left hand one. */ 368 | /* carry on splitting as we go back up the stack */ 369 | 370 | /* if we are doing a bulk load in sorted order, we can maintain 371 | * the stack in between insertions, and use it to restart the 372 | * insertion process. We'll have to restart after a split, but 373 | * usually we'll be saving time. */ 374 | 375 | node* stack[30]; 376 | int stack_child[30]; 377 | int stackptr = 0; 378 | 379 | int i; 380 | 381 | node *x = *root; 382 | 383 | /* search down the tree, remembering the nodes we passed. */ 384 | while (!x->leaf) { 385 | for (i = 0; i < x->nkeys && x->key[i] < key; i++); 386 | 387 | stack[stackptr] = x; 388 | stack_child[stackptr] = i; 389 | stackptr++; 390 | 391 | x = x->children[i]; 392 | } 393 | 394 | if (x->nkeys == 2*MIN_CHILDREN-1) { 395 | /* leaf is full, need to split. */ 396 | 397 | /* make a new leaf node and copy over the top half of the 398 | * elements, using the new middle element as the median. */ 399 | /* insert the new element into the appropriate side. */ 400 | 401 | 402 | 403 | /* now unwind the stack, with the knowledge that we need to insert a 404 | * new key and trailing child. If the next one up the stack 405 | * becomes too full, then do the same splitting */ 406 | while (stackptr != 0) { 407 | node *y = stack[stackptr-1]; 408 | i = stack_child[stackptr-1]; 409 | stackptr--; 410 | 411 | if (y->nkeys == 2*MIN_CHILDREN-1) { 412 | /* split this node */ 413 | 414 | } else { 415 | /* shunt the other keys and children up */ 416 | /* insert median key and new child here */ 417 | break; 418 | } 419 | } 420 | 421 | } else { 422 | /* leaf has space: insert here */ 423 | i = x->nkeys - 1; 424 | while (i >= 0 && key < x->key[i]) { 425 | x->key[i+1] = x->key[i]; 426 | i--; 427 | } 428 | 429 | x->key[i+1] = key; 430 | x->nkeys++; 431 | 432 | /* if we keep the stack here, then we won't have to recurse 433 | * back down if we want to insert a new key that is slightly 434 | * larger than this one. Need to write some code that can 435 | * advance from one key to the next (like the iterate 436 | * code). */ 437 | } 438 | } 439 | 440 | /**********************************************************************/ 441 | /* bulk loading: 442 | * 443 | * if we have a sorted list of items to insert, then repeatedly doing 444 | * insertions using 'insert' will be slow. 445 | * 446 | * after doing an insertion, we know 447 | */ 448 | 449 | int main(int argc, char* argv[]) 450 | { 451 | printf ("sizeof(node) = %zd\n", sizeof(node)); 452 | printf ("offsetof(struct _node, leaf) = %zd\n", offsetof(struct _node, leaf)); 453 | printf ("offsetof(struct _node, nkeys) = %zd\n", offsetof(struct _node, nkeys)); 454 | printf ("offsetof(struct _node, key) = %zd\n", offsetof(struct _node, key)); 455 | printf ("offsetof(struct _node, children) = %zd\n", offsetof(struct _node, children)); 456 | 457 | node *tree = create (); 458 | 459 | int N = 100000000; 460 | 461 | // for (int i = N/2-1; i >= 0; i--) 462 | for (int i = 0; i < N/2; i++) 463 | insert (i*2, &tree); 464 | 465 | //print_tree (tree, 0); 466 | 467 | iterate_range (17, 17, tree); 468 | printf ("\n"); 469 | 470 | iterate_range (17, 35, tree); 471 | printf ("\n"); 472 | 473 | for (int i = 0; i < N; i++) { 474 | bool result = member (i, tree); 475 | if ((i % 2 == 0 && !result) || (i % 2 == 1 && result)) { 476 | fprintf (stderr, "Failed to find %d in intermediate tree\n", i); 477 | exit (EXIT_FAILURE); 478 | } 479 | } 480 | 481 | if (member_range (14, 14, tree)) 482 | printf ("tree contains elements in range 14-14\n"); 483 | else 484 | printf ("tree does not contain elements in range 14-14\n"); 485 | if (member_range (15, 18, tree)) 486 | printf ("tree contains elements in range 15-18\n"); 487 | else 488 | printf ("tree does not contain elements in range 15-18\n"); 489 | if (member_range (15, 15, tree)) 490 | printf ("tree contains elements in range 15-15\n"); 491 | else 492 | printf ("tree does not contain elements in range 15-15\n"); 493 | 494 | for (int i = 0; i < N/2; i++) 495 | insert (i*2+1, &tree); 496 | 497 | if (member_range (14, 14, tree)) 498 | printf ("tree contains elements in range 14-14\n"); 499 | else 500 | printf ("tree does not contain elements in range 14-14\n"); 501 | if (member_range (15, 18, tree)) 502 | printf ("tree contains elements in range 15-18\n"); 503 | else 504 | printf ("tree does not contain elements in range 15-18\n"); 505 | if (member_range (15, 15, tree)) 506 | printf ("tree contains elements in range 15-15\n"); 507 | else 508 | printf ("tree does not contain elements in range 15-15\n"); 509 | 510 | iterate_range (17, 17, tree); 511 | printf ("\n"); 512 | 513 | iterate_range (17, 35, tree); 514 | printf ("\n"); 515 | 516 | // print_tree (tree, 0); 517 | 518 | // iterate_all (tree); 519 | // printf ("\n"); 520 | 521 | for (int i = 0; i < N; i++) { 522 | if (!member(i, tree)) { 523 | fprintf (stderr, "Failed to find %d in final tree\n", i); 524 | exit (EXIT_FAILURE); 525 | } 526 | } 527 | } 528 | -------------------------------------------------------------------------------- /datalog.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "datalog" 3 | version: "0.3" 4 | maintainer: "Robert Atkey " 5 | authors: "Robert Atkey " 6 | license: "MIT" 7 | build: [["jbuilder" "build" "-p" name "-j" jobs "@install"]] 8 | available: [ ocaml-version >= "4.04.0" ] 9 | -------------------------------------------------------------------------------- /datalog/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datalog) 3 | (public_name datalog) 4 | (libraries ocamlgraph fmt display_names) 5 | (flags (:standard -w -49+44-9-27-34-32))) 6 | 7 | -------------------------------------------------------------------------------- /datalog/graphviz.ml: -------------------------------------------------------------------------------- 1 | let dot_of_ruleset fmt ruleset = 2 | let module G = struct 3 | include Ruleset.As_graph 4 | 5 | let graph_attributes _ = 6 | [ ] 7 | 8 | let default_vertex_attributes _ = 9 | [ `Shape `Box 10 | ; `Fontname "Ubuntu Mono" 11 | ; `Fontsize 8 12 | ] 13 | 14 | let vertex_name id = 15 | Printf.sprintf "rule%d" (Ruleset.rule_id id) 16 | 17 | let vertex_attributes id = 18 | let rule = Ruleset.rule_of_id id ruleset in 19 | [ `Label (Format.asprintf "@[%a@]" Ruleset.pp_rule rule) ] 20 | 21 | let default_edge_attributes _ = [] 22 | 23 | let edge_attributes edge = [] 24 | 25 | let get_subgraph _ = 26 | None 27 | end in 28 | let module Dot_of_ruleset = Graph.Graphviz.Dot (G) in 29 | Dot_of_ruleset.fprint_graph fmt ruleset 30 | -------------------------------------------------------------------------------- /datalog/ruleset.ml: -------------------------------------------------------------------------------- 1 | type predicate_name = 2 | { ident : string 3 | ; arity : int 4 | } 5 | 6 | module PredicateName = struct 7 | type t = predicate_name 8 | 9 | let compare x y = 10 | match Pervasives.compare x.ident y.ident with 11 | | 0 -> Pervasives.compare x.arity y.arity 12 | | c -> c 13 | end 14 | 15 | type expr = 16 | | Var of string 17 | | Lit of int32 18 | | Underscore 19 | 20 | type atom = 21 | | Atom of { pred : predicate_name; args : expr list } 22 | 23 | type rule = 24 | { pred : predicate_name 25 | ; args : expr list 26 | ; rhs : atom list 27 | } 28 | 29 | (**********************************************************************) 30 | let pp_expr fmt = function 31 | | Var vnm -> 32 | Format.fprintf fmt "?%s" vnm 33 | | Lit i -> 34 | Format.fprintf fmt "%ld" i 35 | | Underscore -> 36 | Format.fprintf fmt "_" 37 | 38 | let pp_exprs = 39 | Fmt.list ~sep:(Fmt.always ", ") pp_expr 40 | 41 | let pp_atom fmt = function 42 | | Atom { pred; args } -> 43 | Format.fprintf fmt "%s(%a)" 44 | pred.ident 45 | pp_exprs args 46 | 47 | let pp_rhs = 48 | Fmt.list ~sep:(Fmt.always ",@ ") pp_atom 49 | 50 | let pp_rule fmt = function 51 | | { pred; args; rhs=[] } -> 52 | Format.fprintf fmt 53 | "%s(@[%a@])." 54 | pred.ident 55 | pp_exprs args 56 | | { pred; args; rhs } -> 57 | Format.fprintf fmt 58 | "@[%s(@[%a@]) :-@ %a.@]" 59 | pred.ident 60 | pp_exprs args 61 | pp_rhs rhs 62 | 63 | (**********************************************************************) 64 | module PredicateNameMap = Map.Make (PredicateName) 65 | 66 | type predicate_info = 67 | { kind : [`Intensional | `Extensional of string] 68 | ; output : string list 69 | } 70 | 71 | type ruleset = 72 | { rules : rule array 73 | ; rules_of_pred : int list PredicateNameMap.t 74 | ; pred_info : predicate_info PredicateNameMap.t 75 | } 76 | 77 | let pp_output = 78 | Fmt.(list (fmt "@ output %S")) 79 | 80 | let pp_pred_info fmt (name, {kind; output}) = 81 | match kind with 82 | | `Intensional -> 83 | Format.fprintf fmt 84 | "@[int %s/%d%a@]" 85 | name.ident 86 | name.arity 87 | pp_output output 88 | | `Extensional filename -> 89 | Format.fprintf fmt 90 | "@[ext %s/%d from %S%a@]" 91 | name.ident 92 | name.arity 93 | filename 94 | pp_output output 95 | 96 | let pp fmt set = 97 | Format.fprintf fmt "@[%a@]@,@,@[" 98 | Fmt.(iter_bindings PredicateNameMap.iter pp_pred_info) set.pred_info; 99 | set.rules |> Array.iteri begin fun i rule -> 100 | pp_rule fmt rule; 101 | if i < Array.length set.rules - 1 then 102 | Format.pp_print_cut fmt () 103 | end; 104 | Format.pp_close_box fmt () 105 | 106 | type rule_id = int 107 | 108 | let rule_id i = i 109 | 110 | let rule_of_id i set = set.rules.(i) 111 | 112 | let predicates {pred_info} = 113 | PredicateNameMap.bindings pred_info 114 | 115 | (**********************************************************************) 116 | module Builder = struct 117 | type t = 118 | { rules_so_far : rule list 119 | ; next_rule_id : int 120 | ; index_so_far : int list PredicateNameMap.t 121 | ; predicates_so_far : predicate_info PredicateNameMap.t 122 | } 123 | 124 | type error = 125 | | Undeclared_predicate of predicate_name 126 | | Arity_mismatch of 127 | { pred : predicate_name 128 | ; used_arity : int 129 | } 130 | | Definition_of_extensional_predicate of predicate_name 131 | | Predicate_already_declared of predicate_name 132 | 133 | let empty = 134 | { rules_so_far = [] 135 | ; next_rule_id = 0 136 | ; index_so_far = PredicateNameMap.empty 137 | ; predicates_so_far = PredicateNameMap.empty 138 | } 139 | 140 | let update_index pred f map = 141 | let existing = 142 | match PredicateNameMap.find pred map with 143 | | exception Not_found -> [] 144 | | rule_ids -> rule_ids 145 | in 146 | PredicateNameMap.add pred (f existing) map 147 | 148 | let rec check_atoms pred_info = function 149 | | [] -> 150 | Ok () 151 | | Atom {pred;args} :: atoms -> 152 | let used_arity = List.length args in 153 | if pred.arity <> used_arity then 154 | Error (Arity_mismatch { pred; used_arity }) 155 | else 156 | check_atoms pred_info atoms 157 | 158 | let add_rule ({pred;args;rhs} as rule) t = 159 | match check_atoms t.predicates_so_far rhs with 160 | | Error e -> Error e 161 | | Ok () -> 162 | match PredicateNameMap.find pred t.predicates_so_far with 163 | | exception Not_found -> 164 | Error (Undeclared_predicate pred) 165 | | {kind=`Extensional _} -> 166 | Error (Definition_of_extensional_predicate pred) 167 | | _ -> 168 | let used_arity = List.length args in 169 | if pred.arity <> used_arity then 170 | Error (Arity_mismatch {pred; used_arity}) 171 | else 172 | let id = t.next_rule_id in 173 | Ok { t with rules_so_far = rule :: t.rules_so_far 174 | ; next_rule_id = id + 1 175 | ; index_so_far = 176 | update_index pred (List.cons id) t.index_so_far 177 | } 178 | 179 | let add_predicate name info t = 180 | match PredicateNameMap.find name t.predicates_so_far with 181 | | exception Not_found -> 182 | Ok { t with predicates_so_far = 183 | PredicateNameMap.add name info t.predicates_so_far 184 | } 185 | | info' -> 186 | if info = info' then 187 | Ok t 188 | else 189 | Error (Predicate_already_declared name) 190 | 191 | let add_output name filename t = 192 | match PredicateNameMap.find name t.predicates_so_far with 193 | | exception Not_found -> 194 | (* FIXME: is silently ignoring it the right thing to do? *) 195 | t 196 | | info -> 197 | { t with 198 | predicates_so_far = 199 | PredicateNameMap.add name 200 | { info with output = filename :: info.output } 201 | t.predicates_so_far } 202 | 203 | let finish { rules_so_far; next_rule_id; index_so_far; predicates_so_far } = 204 | let rules_of_pred = index_so_far 205 | and pred_info = predicates_so_far in 206 | if next_rule_id = 0 then 207 | { rules = [||]; rules_of_pred; pred_info } 208 | else 209 | let rules = Array.make next_rule_id (List.hd rules_so_far) in 210 | (* Do this backwards to maintain the numbering *) 211 | let rec insert_all i = function 212 | | [] -> () 213 | | r::rs -> rules.(i) <- r; insert_all (i-1) rs 214 | in 215 | insert_all (next_rule_id - 1) rules_so_far; 216 | { rules; rules_of_pred; pred_info } 217 | end 218 | 219 | type builder = Builder.t 220 | 221 | (**********************************************************************) 222 | module As_graph = struct 223 | type t = ruleset 224 | 225 | module V = struct 226 | type t = rule_id 227 | let compare (x : t) (y : t) = Pervasives.compare x y 228 | let hash (x : t) = x 229 | let equal (x : t) y = x = y 230 | end 231 | 232 | type vertex = V.t 233 | 234 | let graph_of_vertex (ruleset, _) = ruleset 235 | 236 | module E = struct 237 | type t = V.t * V.t 238 | let src = fst 239 | let dst = snd 240 | end 241 | 242 | type edge = E.t 243 | 244 | let iter_vertex f ruleset = 245 | for i = 0 to Array.length ruleset.rules - 1 do 246 | f i 247 | done 248 | 249 | let iter_succ f ruleset rule_id = 250 | let rule = ruleset.rules.(rule_id) in 251 | rule.rhs |> List.iter begin fun (Atom {pred}) -> 252 | match PredicateNameMap.find pred ruleset.rules_of_pred with 253 | | exception Not_found -> () 254 | | rule_ids -> List.iter f rule_ids 255 | end 256 | 257 | let iter_edges_e f ruleset = 258 | iter_vertex (fun src -> iter_succ (fun tgt -> f (src,tgt)) ruleset src) ruleset 259 | end 260 | 261 | (** A rule is self recursive if it mentions the head predicate in the 262 | right hand side. *) 263 | let rule_is_self_recursive rule_id ruleset = 264 | let rule = ruleset.rules.(rule_id) in 265 | List.exists (fun (Atom {pred}) -> pred = rule.pred) rule.rhs 266 | 267 | module SCC = Graph.Components.Make (As_graph) 268 | 269 | let form_of_component ruleset = function 270 | | [] -> 271 | assert false 272 | | [id] -> 273 | if rule_is_self_recursive id ruleset then 274 | `Recursive [rule_of_id id ruleset] 275 | else 276 | `Direct (rule_of_id id ruleset) 277 | | rules -> 278 | `Recursive (List.map (fun id -> rule_of_id id ruleset) rules) 279 | 280 | let components ruleset = 281 | List.map (form_of_component ruleset) (SCC.scc_list ruleset) 282 | -------------------------------------------------------------------------------- /datalog/ruleset.mli: -------------------------------------------------------------------------------- 1 | (** Datalog programs as sets of rules. *) 2 | 3 | (** {1 Datalog programs} *) 4 | 5 | type predicate_name = 6 | { ident : string 7 | ; arity : int 8 | } 9 | 10 | type expr = 11 | | Var of string 12 | | Lit of int32 13 | | Underscore 14 | 15 | type atom = 16 | | Atom of { pred : predicate_name; args : expr list } 17 | 18 | type rule = 19 | { pred : predicate_name 20 | ; args : expr list 21 | ; rhs : atom list 22 | } 23 | 24 | type ruleset 25 | 26 | type rule_id 27 | 28 | val rule_id : rule_id -> int 29 | 30 | val rule_of_id : rule_id -> ruleset -> rule 31 | 32 | type predicate_info = 33 | { kind : [`Intensional | `Extensional of string] 34 | ; output : string list 35 | } 36 | 37 | val predicates : ruleset -> (predicate_name * predicate_info) list 38 | 39 | val components : ruleset -> [> `Direct of rule | `Recursive of rule list ] list 40 | 41 | (** {2 Pretty printing} *) 42 | 43 | val pp_rule : rule Fmt.t 44 | 45 | val pp : ruleset Fmt.t 46 | 47 | (** {2 Construction of rulesets} *) 48 | 49 | type builder 50 | 51 | module Builder : sig 52 | type t = builder 53 | 54 | type error = 55 | | Undeclared_predicate of predicate_name 56 | | Arity_mismatch of 57 | { pred : predicate_name 58 | ; used_arity : int 59 | } 60 | | Definition_of_extensional_predicate of predicate_name 61 | | Predicate_already_declared of predicate_name 62 | 63 | val empty : t 64 | 65 | val add_predicate : predicate_name -> predicate_info -> t -> (t, error) result 66 | 67 | val add_rule : rule -> t -> (t, error) result 68 | 69 | val add_output : predicate_name -> string -> t -> t 70 | 71 | val finish : t -> ruleset 72 | end 73 | 74 | (** {2 Graph representation} *) 75 | 76 | (** Graph representation of a set of datalog rules. Each vertex is a 77 | rule. There exists an edge [r1 -> r2] if the head of [r2] is 78 | mentioned on th right-hand side of [r1]. *) 79 | module As_graph : sig 80 | type t = ruleset 81 | 82 | module V : sig 83 | type t = rule_id 84 | val equal : t -> t -> bool 85 | val hash : t -> int 86 | val compare : t -> t -> int 87 | end 88 | 89 | module E : sig 90 | type t 91 | val src : t -> V.t 92 | val dst : t -> V.t 93 | end 94 | 95 | val iter_vertex : (V.t -> unit) -> t -> unit 96 | 97 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 98 | 99 | val iter_edges_e : (E.t -> unit) -> t -> unit 100 | end 101 | -------------------------------------------------------------------------------- /display-names/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name display_names) 3 | (public_name display_names) 4 | (synopsis "Library for computing nice names for display.")) 5 | 6 | -------------------------------------------------------------------------------- /display-names/fresh.ml: -------------------------------------------------------------------------------- 1 | let get_number_suffix str = 2 | let rec find_split i = 3 | if i = 0 then 0 4 | else match str.[i-1] with 5 | | '0' .. '9' -> find_split (i-1) 6 | | _ -> i 7 | in 8 | let l = String.length str in 9 | let i = find_split l in 10 | if i = l then 11 | (str, None) 12 | else 13 | (String.sub str 0 i, 14 | Some (int_of_string (String.sub str i (l - i)))) 15 | 16 | let choose used base = 17 | if not (used base) then 18 | base 19 | else 20 | (* 1. split base into prefix + 00s + digit suffix *) 21 | let base, num = get_number_suffix base in 22 | let create_candidate = function 23 | | None -> base, Some 1 24 | | Some i -> base ^ string_of_int i, Some (i+1) 25 | in 26 | let rec find suffix = 27 | let candidate, suffix = create_candidate suffix in 28 | if used candidate then find suffix 29 | else candidate 30 | in 31 | find num 32 | -------------------------------------------------------------------------------- /display-names/fresh.mli: -------------------------------------------------------------------------------- 1 | 2 | (** [choose used base] returns a string [s] such that [used s = 3 | false]. The argument [base] is used as a hint for the form of the 4 | string to be generated. In order for this function to terminate, 5 | [used] must be finitely supported. *) 6 | val choose : (string -> bool) -> string -> string 7 | -------------------------------------------------------------------------------- /display_names.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "datalog" 3 | version: "0.3" 4 | maintainer: "Robert Atkey " 5 | authors: "Robert Atkey " 6 | license: "MIT" 7 | build: [["jbuilder" "build" "-p" name "-j" jobs "@install"]] 8 | available: [ ocaml-version >= "4.04.0" ] 9 | -------------------------------------------------------------------------------- /emptytuple.mlog: -------------------------------------------------------------------------------- 1 | type t = () 2 | 3 | define 4 | predicate : t 5 | predicate (()) 6 | -------------------------------------------------------------------------------- /expr.mlog: -------------------------------------------------------------------------------- 1 | module type INPUT = sig 2 | type index 3 | 4 | type token 5 | 6 | pred is_index : index 7 | 8 | pred token_at : index * token * index 9 | end 10 | 11 | module type GRAMMAR = sig 12 | type non_terminal 13 | type token 14 | type rhs 15 | 16 | constant start : non_terminal 17 | 18 | (* naturally gives regular right-hand sides! 19 | 20 | the 'rhs' is a state in some state machine where the transitions 21 | are non-terminals or tokens. If it is 'infinite' state, then we'd 22 | have data driven parsers? *) 23 | 24 | pred nt_to_rhs : non_terminal * rhs 25 | 26 | pred rhs_nt : rhs * non_terminal * rhs 27 | pred rhs_tok : rhs * token * rhs 28 | pred rhs_stop : rhs 29 | end 30 | 31 | module ExprGrammar = struct 32 | type non_terminal = { `E } 33 | 34 | constant start : non_terminal = `E 35 | 36 | type token = { `x | `plus } 37 | 38 | type rhs = { `E1_0 | `E1_1 | `E2_0 | `E2_1 | `E2_2 | `E2_3 } 39 | 40 | define nt_to_rhs : non_terminal * rhs 41 | nt_to_rhs (`E, `E1_0) 42 | nt_to_rhs (`E, `E2_0) 43 | 44 | define rhs_tok : rhs * token * rhs 45 | rhs_tok (`E1_0, `x, `E1_1) 46 | rhs_tok (`E2_1, `plus, `E2_2) 47 | 48 | define rhs_nt : rhs * non_terminal * rhs 49 | rhs_nt (`E2_0, `E, `E2_1) 50 | rhs_nt (`E2_2, `E, `E2_3) 51 | 52 | define rhs_stop : rhs 53 | rhs_stop (`E1_1) 54 | rhs_stop (`E2_3) 55 | end 56 | 57 | (* Basically computes the intersection of a CFG with a regular language... *) 58 | module Recogniser (G : GRAMMAR) (I : INPUT with type token = G.token) = 59 | struct 60 | 61 | (* parse (i, nt, j) if the symbol 'nt' is recognised between 'i' and 62 | 'j' in the input. *) 63 | 64 | define 65 | parse : I.index * G.non_terminal * I.index 66 | parse (?i, ?nt, ?j) :- 67 | G.nt_to_rhs (?nt, ?rhs), parse_rhs (?i, ?rhs, ?j) 68 | 69 | and 70 | parse_rhs : I.index * G.rhs * I.index 71 | parse_rhs (?i, ?rhs, ?i) :- 72 | G.rhs_stop (?rhs), I.is_index (?i) 73 | parse_rhs (?i, ?rhs, ?j) :- 74 | G.rhs_tok (?rhs, ?tok, ?rhs'), 75 | I.token_at (?i, ?tok, ?i'), 76 | parse_rhs (?i', ?rhs', ?j) 77 | parse_rhs (?i, ?rhs, ?j) :- 78 | G.rhs_nt (?rhs, ?nt, ?rhs'), 79 | parse (?i, ?nt, ?i'), parse_rhs (?i', ?rhs', ?j) 80 | 81 | define 82 | parse_between : I.index * I.index 83 | parse_between (?i, ?j) :- parse (?i, G.start, ?j) 84 | 85 | end 86 | 87 | module TestInput = struct 88 | type index = int 89 | 90 | type token = { `x | `plus } 91 | 92 | define is_index : index 93 | is_index (0) 94 | is_index (1) 95 | is_index (2) 96 | is_index (3) 97 | 98 | define token_at : index * token * index 99 | token_at (0,`x,1) 100 | token_at (1,`plus,2) 101 | token_at (2,`x,3) 102 | end 103 | 104 | module R = Recogniser (ExprGrammar) (TestInput) 105 | -------------------------------------------------------------------------------- /ext.mlog: -------------------------------------------------------------------------------- 1 | type vertex = int 2 | 3 | external edge : vertex * vertex 4 | 5 | define 6 | path : vertex * vertex 7 | path(?X,?Y) :- edge(?X,?Y) 8 | path(?X,?Z) :- path(?X,?Y), edge(?Y, ?Z) 9 | 10 | output path "path.csv" 11 | -------------------------------------------------------------------------------- /idealised-algol/block_list.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | module S : Syntax.S 3 | 4 | type handle 5 | 6 | val declare : name:string -> arity:int -> (handle -> S.comm) -> S.comm 7 | 8 | (** the two handles ought to have the same arity *) 9 | val move : src:handle -> tgt:handle -> S.comm 10 | 11 | (** the length of the list and arity must match *) 12 | val insert : handle -> int32 S.exp array -> S.comm 13 | 14 | val is_empty : handle -> bool S.exp 15 | 16 | val iterate : handle -> (int32 S.exp array -> S.comm) -> S.comm 17 | end 18 | 19 | module Make (S : Syntax.S) () : S with module S = S = struct 20 | module S = S 21 | 22 | let int32_of_int = Int32.of_int 23 | let int32_to_int = Int32.to_int 24 | let int32_mul = Int32.mul 25 | 26 | open! S 27 | open S.RawPtr 28 | open S.RawArray 29 | 30 | let block_size = 16l 31 | 32 | type list_node 33 | let list_node : list_node Struct.t typ = Struct.make "list_node" 34 | let occupied = Struct.field list_node "occupied" S.Int32.t 35 | let next = Struct.field list_node "next" (ptr list_node) 36 | let values = Struct.field list_node "values" (array S.Int32.t 1l) 37 | let () = Struct.seal list_node 38 | 39 | type handle = 40 | { arity : int32 41 | ; name : string 42 | ; var : list_node Struct.t ptr var 43 | } 44 | 45 | let is_empty {var} = 46 | var =*= null 47 | 48 | let free_list p = 49 | while_ (p =!*= null) ~do_:begin%monoid 50 | declare ~name:"ahead" (ptr list_node) ~init:p#->next @@ fun ahead -> 51 | begin%monoid 52 | free p; 53 | p := ahead 54 | end 55 | end 56 | 57 | let move ~src:{var=src;arity=a1} ~tgt:{var=tgt;arity=a2} = 58 | if a1 <> a2 then 59 | invalid_arg "Block_list.Make.move: mismatched arities"; 60 | begin%monoid 61 | declare ~name:"cursor" (ptr list_node) ~init:tgt free_list; 62 | tgt := src; 63 | src := null; 64 | end 65 | 66 | let write val_array offset vals = 67 | let open! S.Int32 in 68 | vals |> 69 | Array.mapi begin fun i v -> 70 | let i = int32_of_int i in 71 | val_array#@(offset + const i) := v 72 | end |> 73 | Array.fold_left (^^) empty 74 | 75 | let read val_array offset arity = 76 | let open! Int32 in 77 | Array.init (int32_to_int arity) 78 | (fun i -> val_array#@(offset + const (int32_of_int i))) 79 | 80 | let new_block v ~arity ~vals ~next:nxt = 81 | let length = int32_mul arity block_size in 82 | let open! S.Int32 in 83 | begin%monoid 84 | malloc_ext v list_node (const length) S.Int32.t; 85 | v#->occupied := const 1l; 86 | v#->next := nxt; 87 | write (v#->values) (const 0l) vals 88 | end 89 | 90 | let insert {var=head; arity} vals = 91 | if Array.length vals <> int32_to_int arity then 92 | invalid_arg "Block_list.Make.insert: arity mismatch"; 93 | if_ (head =*= null) 94 | ~then_:begin%monoid 95 | new_block head ~arity ~vals ~next:null 96 | end 97 | ~else_:begin%monoid 98 | let open! S.Int32 in 99 | if_ (head#->occupied == const block_size) 100 | ~then_:begin%monoid 101 | declare (ptr list_node) @@ fun new_head -> begin%monoid 102 | new_block new_head ~arity ~vals ~next:head; 103 | head := new_head 104 | end 105 | end 106 | ~else_:begin%monoid 107 | write head#->values (head#->occupied * const arity) vals; 108 | head#->occupied := head#->occupied + const 1l 109 | end 110 | end 111 | 112 | let iterate {var=head; arity} body = 113 | declare ~name:"cursor" (ptr list_node) ~init:head @@ fun node -> 114 | begin%monoid 115 | while_ (node =!*= null) 116 | ~do_:begin%monoid 117 | let open! S.Int32 in 118 | declare ~name:"i" S.Int32.t ~init:(const 0l) @@ fun i -> 119 | begin%monoid 120 | while_ (i < (node#->occupied * const arity)) 121 | ~do_:begin%monoid 122 | body (read node#->values i arity); 123 | i := i + const arity 124 | end; 125 | node := node#->next 126 | end 127 | end 128 | end 129 | 130 | let declare ~name ~arity k = 131 | let arity = int32_of_int arity in 132 | declare ~name (ptr list_node) ~init:null @@ fun var -> 133 | begin%monoid 134 | k { arity; name; var }; 135 | free_list var 136 | end 137 | end 138 | -------------------------------------------------------------------------------- /idealised-algol/btree.ml: -------------------------------------------------------------------------------- 1 | (* FIXME: add 'next' pointers to avoid the use of a stack for 2 | iteration? I think this requires putting all keys at the leaves as 3 | well as in the internal nodes. As it stands, this implementation is 4 | good for membership queries, but requires an auxillary stack for 5 | iteration. 6 | 7 | An intermediate solution would be to maintain parent pointers so 8 | the stack needn't store the parent pointers. *) 9 | 10 | 11 | module type PARAMETERS = sig 12 | val min_children : int32 13 | end 14 | 15 | module type KEY = sig 16 | module Syn : Syntax.S 17 | 18 | type t 19 | 20 | val t : t Syn.typ 21 | 22 | val lt : t Syn.exp -> t Syn.exp -> bool Syn.exp 23 | val le : t Syn.exp -> t Syn.exp -> bool Syn.exp 24 | val eq : t Syn.exp -> t Syn.exp -> bool Syn.exp 25 | end 26 | 27 | module type S = sig 28 | module Syn : Syntax.S 29 | 30 | type key 31 | 32 | type handle 33 | 34 | val declare : (handle -> Syn.comm) -> Syn.comm 35 | 36 | val insert : key Syn.exp -> handle -> Syn.comm 37 | 38 | val ifmember : key Syn.exp -> handle -> Syn.comm -> Syn.comm -> Syn.comm 39 | 40 | val ifmember_range : 41 | key Syn.exp -> 42 | key Syn.exp -> 43 | handle -> 44 | Syn.comm -> 45 | Syn.comm -> 46 | Syn.comm 47 | 48 | val iterate_range : 49 | key Syn.exp -> 50 | key Syn.exp -> 51 | handle -> 52 | (key Syn.exp -> Syn.comm) -> 53 | Syn.comm 54 | 55 | val iterate_all : 56 | handle -> 57 | (key Syn.exp -> Syn.comm) -> 58 | Syn.comm 59 | 60 | val move : src:handle -> tgt:handle -> Syn.comm 61 | 62 | val is_empty : handle -> bool Syn.exp 63 | end 64 | 65 | module Make 66 | (Syn : Syntax.S) 67 | (P : PARAMETERS) 68 | (K : KEY with module Syn = Syn) 69 | () 70 | : S with module Syn = Syn 71 | and type key = K.t = 72 | struct 73 | module Syn = Syn 74 | 75 | let min_keys = Int32.sub P.min_children 1l 76 | let max_keys = Int32.(sub (mul P.min_children 2l) 1l) 77 | let child_slots = Int32.mul P.min_children 2l 78 | 79 | open! Syn 80 | open Syn.RawPtr 81 | open Syn.RawArray 82 | 83 | type node 84 | let node : node Struct.t typ = Struct.make "node" 85 | let leaf = Struct.field node "leaf" Syn.Bool.t 86 | let nkeys = Struct.field node "nkeys" Syn.Int32.t 87 | let keys = Struct.field node "keys" (array K.t max_keys) 88 | let children = Struct.field node "children" (array (ptr node) child_slots) 89 | let () = Struct.seal node 90 | 91 | type handle = node Struct.t ptr var 92 | 93 | type key = K.t 94 | 95 | let incr (i : _ var) = 96 | let open! Syn.Int32 in 97 | i := i + const 1l 98 | 99 | let decr (i : _ var) = 100 | let open! Syn.Int32 in 101 | i := i - const 1l 102 | 103 | let int32 = Syn.Int32.const 104 | 105 | let find_key = 106 | declare_func 107 | ~name:"find_key" 108 | ~typ:(("i", Syn.Int32.t) @&-> ("x",ptr node) @-> ("key",K.t) @-> return_void) 109 | ~body:begin fun i x key -> 110 | let open! Syn.Bool in 111 | let open! Syn.Int32 in 112 | begin%monoid 113 | i := int32 0l; 114 | while_ (i < x#->nkeys && K.lt x#->keys#@i key) 115 | ~do_:(incr i) 116 | end 117 | end 118 | 119 | let with_nodeptr ~name init body = 120 | Syn.declare ~name (ptr node) ~init body 121 | 122 | let alloc_node body = 123 | declare ~name:"node" (ptr node) @@ fun x -> begin%monoid 124 | malloc x node; 125 | body x 126 | end 127 | 128 | let with_int body = 129 | declare ~name:"i" Syn.Int32.t ~init:(int32 0l) body 130 | 131 | let loop body = 132 | while_ Bool.true_ ~do_:body 133 | 134 | module Stk = Stack.Make (Syn) 135 | 136 | (* FIXME: compute this from the min_children and a reasonable 137 | estimate of the maximum size of any tree. *) 138 | let max_stack_depth = 40l 139 | 140 | 141 | let free tree = 142 | with_nodeptr ~name:"cursor" tree @@ fun cursor -> 143 | Stk.with_stack max_stack_depth (ptr node) Syn.Int32.t @@ fun stk -> 144 | begin%monoid 145 | while_ (Bool.not cursor#->leaf) 146 | ~do_:begin%monoid 147 | stk#push cursor (int32 0l); 148 | cursor := cursor#->children#@(int32 0l) 149 | end; 150 | 151 | loop begin%monoid 152 | free cursor; 153 | 154 | ifthen stk#is_empty ~then_:break; 155 | 156 | cursor := fst stk#top; 157 | 158 | let open! Syn.Int32 in 159 | 160 | if_ (snd stk#top == cursor#->nkeys - int32 1l) 161 | ~then_:begin%monoid 162 | stk#pop; 163 | with_nodeptr ~name:"old_cursor" cursor @@ fun old_cursor -> 164 | begin%monoid 165 | cursor := cursor#->children#@(cursor#->nkeys); 166 | free old_cursor 167 | end 168 | end 169 | ~else_:begin%monoid 170 | incr (snd stk#top); 171 | cursor := cursor#->children#@(snd stk#top) 172 | end; 173 | 174 | while_ (Syn.Bool.not cursor#->leaf) 175 | ~do_:begin%monoid 176 | stk#push cursor (int32 0l); 177 | cursor := cursor#->children#@(int32 0l) 178 | end 179 | end 180 | end 181 | 182 | let declare body = 183 | alloc_node @@ fun x -> begin%monoid 184 | x#->leaf := Bool.true_; 185 | x#->nkeys := int32 0l; 186 | body x; 187 | free x 188 | end 189 | 190 | (************************************************************) 191 | let ifmember key t yes no = 192 | with_nodeptr ~name:"cursor" t @@ fun x -> 193 | with_int @@ fun i -> 194 | loop begin%monoid 195 | let open! Syn.Bool in 196 | let open! Syn.Int32 in 197 | find_key i (to_exp x) key; 198 | ifthen (i < x#->nkeys && K.eq x#->keys#@i key) 199 | ~then_:begin%monoid yes; break end; 200 | ifthen x#->leaf 201 | ~then_:begin%monoid no; break end; 202 | x := x#->children#@i 203 | end 204 | 205 | (************************************************************) 206 | let ifmember_range from upto t yes no = 207 | with_nodeptr ~name:"cursor" t @@ fun x -> 208 | with_int @@ fun i -> 209 | loop begin%monoid 210 | let open! Syn.Bool in 211 | let open! Syn.Int32 in 212 | find_key i (to_exp x) from; 213 | ifthen (i < x#->nkeys && K.le x#->keys#@i upto) 214 | ~then_:begin%monoid yes; break end; 215 | ifthen x#->leaf ~then_:begin%monoid no; break end; 216 | x := x#->children#@i 217 | end 218 | 219 | (************************************************************) 220 | let iterate_range from upto (tree : handle) body = 221 | with_nodeptr ~name:"cursor" tree @@ fun x -> 222 | Stk.with_stack max_stack_depth (ptr node) Syn.Int32.t @@ fun stk -> 223 | with_int @@ fun i -> 224 | begin%monoid 225 | let open! Syn.Int32 in 226 | (* recurse down the tree *) 227 | loop begin%monoid 228 | find_key i (to_exp x) from; 229 | ifthen x#->leaf ~then_:break; 230 | ifthen (i < x#->nkeys) ~then_:(stk#push x i); 231 | x := x#->children#@i 232 | end; 233 | loop begin%monoid 234 | let open! Bool in 235 | while_ (i < x#->nkeys && K.le x#->keys#@i upto) 236 | ~do_:begin%monoid 237 | body x#->keys#@i; 238 | incr i 239 | end; 240 | 241 | ifthen (i != x#->nkeys || stk#is_empty) 242 | ~then_:break; 243 | 244 | x := fst stk#top; 245 | i := snd stk#top; 246 | 247 | ifthen (not (K.le x#->keys#@i upto)) 248 | ~then_:break; 249 | 250 | body x#->keys#@i; 251 | 252 | if_ (i == x#->nkeys - int32 1l) 253 | ~then_:stk#pop 254 | ~else_:(incr (snd stk#top)); 255 | 256 | x := x#->children#@(i + int32 1l); 257 | 258 | while_ (not x#->leaf) 259 | ~do_:begin%monoid 260 | stk#push x (int32 0l); 261 | x := x#-> children#@(int32 0l) 262 | end; 263 | 264 | i := int32 0l; 265 | end 266 | end 267 | 268 | (************************************************************) 269 | let iterate_all tree body = 270 | with_nodeptr ~name:"cursor" tree @@ fun x -> 271 | Stk.with_stack max_stack_depth (ptr node) Syn.Int32.t @@ fun stk -> 272 | begin%monoid 273 | while_ (Bool.not x#->leaf) 274 | ~do_:begin%monoid 275 | stk#push x (int32 0l); 276 | x := x#->children#@(int32 0l) 277 | end; 278 | loop begin%monoid 279 | Syn.declare ~name:"i" Syn.Int32.t ~init:(int32 0l) @@ fun i -> begin%monoid 280 | let open! Syn.Int32 in 281 | while_ (i < x#->nkeys) 282 | ~do_:begin%monoid 283 | body x#->keys#@i; 284 | incr i 285 | end; 286 | 287 | ifthen stk#is_empty 288 | ~then_:break; 289 | 290 | x := fst stk#top; 291 | i := snd stk#top; 292 | 293 | body x#->keys#@i; 294 | 295 | if_ (i == x#->nkeys - int32 1l) 296 | ~then_:stk#pop 297 | ~else_:(incr (snd stk#top)); 298 | 299 | x := x#->children#@(i + const 1l); 300 | 301 | while_ (Syn.Bool.not x#->leaf) 302 | ~do_:begin%monoid 303 | stk#push x (int32 0l); 304 | x := x#->children#@(int32 0l) 305 | end; 306 | end 307 | end 308 | end 309 | 310 | (************************************************************) 311 | (* Insertion *) 312 | 313 | let move_keys_up x i = 314 | let open! Syn.Int32 in 315 | Syn.declare ~name:"j" Syn.Int32.t ~init:(x#->nkeys - const 1l) @@ fun j -> 316 | while_ (j >= i) ~do_:begin%monoid 317 | x#->keys#@(j + const 1l) := x#->keys#@j; 318 | decr j 319 | end 320 | 321 | let copy ~n ~src ~dst = 322 | let open! Syn.Int32 in 323 | Syn.declare ~name:"j" Syn.Int32.t ~init:(int32 0l) @@ fun j -> 324 | while_ (j < n) ~do_:begin%monoid 325 | dst j := src j; 326 | incr j 327 | end 328 | 329 | let split_child = 330 | declare_func 331 | ~name:"split_child" 332 | ~typ:(("x", ptr node) @-> ("i", Syn.Int32.t) @-> return_void) 333 | ~body:begin fun x i -> 334 | with_nodeptr ~name:"child" x#->children#@i @@ fun y -> 335 | alloc_node @@ fun z -> 336 | begin%monoid 337 | let open Syn.Int32 in 338 | z#->leaf := y#->leaf; 339 | z#->nkeys := const min_keys; 340 | 341 | (* copy the keys over *) 342 | copy 343 | ~n:(const min_keys) 344 | ~src:(fun j -> y#->keys#@(j + const P.min_children)) 345 | ~dst:(fun j -> z#->keys#@j); 346 | 347 | (* copy the children over (if not a leaf node) *) 348 | ifthen (Bool.not y#->leaf) ~then_:begin 349 | copy ~n:(const P.min_children) 350 | ~src:(fun j -> y#->children#@(j + const P.min_children)) 351 | ~dst:(fun j -> z#->children#@j) 352 | end; 353 | 354 | (* truncate y *) 355 | y#->nkeys := const min_keys; 356 | 357 | (* shunt x's children up *) 358 | begin 359 | Syn.declare ~name:"i" Syn.Int32.t ~init:(x#->nkeys) @@ fun j -> 360 | begin%monoid 361 | while_ (j > i) ~do_:begin%monoid 362 | x#->children#@(j + const 1l) := x#->children#@j; 363 | decr j 364 | end 365 | end 366 | end; 367 | 368 | move_keys_up x i; 369 | 370 | x#->children#@(i + const 1l) := z; 371 | x#->keys#@i := y#->keys#@(const min_keys); 372 | incr (x #-> nkeys) 373 | end 374 | end 375 | 376 | let node_is_full x = 377 | let open! Syn.Int32 in 378 | x#->nkeys == const max_keys 379 | 380 | let insert_nonfull = 381 | declare_func ~name:"insert_nonfull" 382 | ~typ:(("x", ptr node) @-> ("key", K.t) @-> return_void) 383 | ~body:begin fun x' key -> 384 | with_nodeptr ~name:"insert_cursor" x' @@ fun x -> 385 | with_int @@ fun i -> 386 | begin%monoid 387 | while_ (Bool.not x#->leaf) ~do_:begin%monoid 388 | find_key i (to_exp x) key; 389 | ifthen (node_is_full x#->children#@i) 390 | ~then_:begin%monoid 391 | split_child (to_exp x) (to_exp i); 392 | ifthen (K.lt x#->keys#@i key) 393 | ~then_:(incr i) 394 | end; 395 | x:= x#->children#@i 396 | end; 397 | 398 | find_key i (to_exp x) key; 399 | move_keys_up x i; 400 | x#->keys#@i := key; 401 | incr (x #-> nkeys) 402 | end 403 | end 404 | 405 | let insert = 406 | declare_func 407 | ~name:"insert" 408 | ~typ:(("key", K.t) @-> ("root", ptr node) @&-> return_void) 409 | ~body:begin fun key root -> 410 | begin%monoid 411 | (* if the root is full, then split it by making a new root 412 | node with a single child, and using split_child *) 413 | ifthen (node_is_full root) ~then_:begin 414 | alloc_node @@ fun s -> 415 | begin%monoid 416 | s#->leaf := Bool.false_; 417 | s#->nkeys := int32 0l; 418 | s#->children#@(int32 0l) := root; 419 | split_child (to_exp s) (int32 0l); 420 | root := s 421 | end 422 | end; 423 | (* Once the root is not full, insert the key into it. *) 424 | insert_nonfull (to_exp root) key 425 | end 426 | end 427 | 428 | let move ~src ~tgt = 429 | begin%monoid 430 | free tgt; 431 | tgt := src; 432 | malloc src node; 433 | src#->leaf := Bool.true_; 434 | src#->nkeys := int32 0l; 435 | end 436 | 437 | let is_empty tree = 438 | let open! Syn.Bool in 439 | let open! Syn.Int32 in 440 | tree#->leaf && tree#->nkeys == const 0l 441 | end 442 | -------------------------------------------------------------------------------- /idealised-algol/c.mli: -------------------------------------------------------------------------------- 1 | (** Generation of C code. *) 2 | 3 | val output : 'a Syntax.program -> 'a -> Format.formatter -> unit 4 | 5 | val compile : string -> 'a Syntax.program -> 'a -> unit 6 | -------------------------------------------------------------------------------- /idealised-algol/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name idealised_algol) 3 | (public_name idealised_algol) 4 | (libraries fmt display_names unix) 5 | (preprocess (pps ppx_monoid)) 6 | (flags (:standard -w -49+44-9-37-27 -safe-string))) 7 | -------------------------------------------------------------------------------- /idealised-algol/stack.ml: -------------------------------------------------------------------------------- 1 | module Make (S : Syntax.S) : sig 2 | open S 3 | 4 | type ('a, 'b) stack_ops = 5 | < push : 'c 'd. ('a,[>`exp] as 'c) expr -> ('b, [>`exp] as 'd) expr -> comm 6 | ; pop : comm 7 | ; top : 'a var * 'b var 8 | ; is_empty : bool exp 9 | > 10 | 11 | val with_stack : int32 -> 'a typ -> 'b typ -> (('a,'b) stack_ops -> comm) -> comm 12 | end = struct 13 | open! S 14 | open S.RawArray 15 | 16 | let incr i = 17 | let open! S.Int32 in 18 | i := i + const 1l 19 | 20 | let decr i = 21 | let open! S.Int32 in 22 | i := i - const 1l 23 | 24 | type ('a, 'b) stack_ops = 25 | < push : 'c 'd. ('a,[>`exp] as 'c) expr -> ('b, [>`exp] as 'd) expr -> comm 26 | ; pop : comm 27 | ; top : 'a var * 'b var 28 | ; is_empty : bool exp 29 | > 30 | 31 | let with_stack max_depth typ1 typ2 body = 32 | declare ~name:"stack1_" (array typ1 max_depth) @@ fun stack1 -> 33 | declare ~name:"stack2_" (array typ2 max_depth) @@ fun stack2 -> 34 | declare ~name:"stackptr" S.Int32.t ~init:(S.Int32.const 0l) @@ fun stackptr -> 35 | body (object 36 | method push : 'c 'd. ('a,[>`exp] as 'c) expr -> ('b, [>`exp] as 'd) expr -> comm = fun x1 x2 -> 37 | begin%monoid 38 | stack1#@stackptr := x1; 39 | stack2#@stackptr := x2; 40 | incr stackptr 41 | end 42 | method pop = 43 | decr stackptr 44 | method top = 45 | let open! S.Int32 in 46 | (stack1#@(stackptr - const 1l), 47 | stack2#@(stackptr - const 1l)) 48 | method is_empty = 49 | let open! S.Int32 in 50 | stackptr == const 0l 51 | end) 52 | end 53 | -------------------------------------------------------------------------------- /idealised-algol/syntax.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | 3 | (**{2 Representation of data types} *) 4 | 5 | type 'a typ 6 | 7 | (** {2 Phrase types} *) 8 | 9 | type ('a,_) expr 10 | type 'a exp = ('a,[`exp]) expr 11 | type 'a var = ('a,[`var|`exp]) expr 12 | 13 | (** Every variable can be used as an expression. *) 14 | val to_exp : 'a var -> 'a exp 15 | 16 | (** Representation of a command. A command represents some process 17 | for altering the current state. *) 18 | type comm 19 | 20 | (** {3 Boolean expressions} *) 21 | 22 | module Bool : sig 23 | val t : bool typ 24 | 25 | val true_ : bool exp 26 | 27 | val false_ : bool exp 28 | 29 | val ( && ) : (bool, [>`exp]) expr -> (bool, [>`exp]) expr -> bool exp 30 | 31 | val ( || ) : (bool, [>`exp]) expr -> (bool, [>`exp]) expr -> bool exp 32 | 33 | val not : (bool, [>`exp]) expr -> bool exp 34 | end 35 | 36 | (** {3 Integer expressions} *) 37 | 38 | module Int32 : sig 39 | val t : int32 typ 40 | 41 | val const : int32 -> int32 exp 42 | 43 | val ( < ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> bool exp 44 | 45 | val ( > ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> bool exp 46 | 47 | val ( >= ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> bool exp 48 | 49 | val ( <= ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> bool exp 50 | 51 | val ( == ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> bool exp 52 | 53 | val ( != ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> bool exp 54 | 55 | val ( + ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> int32 exp 56 | 57 | val ( * ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> int32 exp 58 | 59 | val ( - ) : (int32, [>`exp]) expr -> (int32, [>`exp]) expr -> int32 exp 60 | 61 | val maximum : int32 exp 62 | end 63 | 64 | (** {3 Structs} *) 65 | 66 | module Struct : sig 67 | type 'a t 68 | 69 | type ('s, 'a) field 70 | 71 | (* Creation of types; a Ctypes style interface *) 72 | val make : string -> 's t typ 73 | 74 | val field : 's t typ -> string -> 'a typ -> ('s, 'a) field 75 | 76 | val seal : 's t typ -> unit 77 | 78 | (** Structure field access. *) 79 | val (#.) : ('s t, [>`exp]) expr -> ('s, 'a) field -> ('a,[<`exp|`var]) expr 80 | 81 | type exp_box = Exp : 'a exp -> exp_box 82 | 83 | (** Structure literals. *) 84 | val const : 's t typ -> exp_box array -> 's t exp 85 | end 86 | 87 | 88 | (** {2 Commands} 89 | 90 | Commands can update the state in some way. *) 91 | 92 | (** The command that does nothing. *) 93 | val empty : comm 94 | 95 | (** Sequencing of commands. *) 96 | val (^^) : comm -> comm -> comm 97 | 98 | (** Assignment *) 99 | val (:=) : 'a var -> ('a,[>`exp]) expr -> comm 100 | 101 | (** While loops. *) 102 | val while_ : bool exp -> do_:comm -> comm 103 | 104 | (** Breaking out of a while loop. *) 105 | val break : comm 106 | 107 | (** If then else. *) 108 | val if_ : (bool, [>`exp]) expr -> then_:comm -> else_:comm -> comm 109 | 110 | (** If then. *) 111 | val ifthen : (bool, [>`exp]) expr -> then_:comm -> comm 112 | 113 | (** Declare a new variable. Takes an optional name hint and initial 114 | value. *) 115 | val declare : ?name:string -> 'a typ -> ?init:('a,[>`exp]) expr -> ('a var -> comm) -> comm 116 | 117 | module Stdio : sig 118 | 119 | type out_ch 120 | type in_ch 121 | 122 | val stdout : out_ch exp 123 | val with_file_output : string -> (out_ch exp -> comm) -> comm 124 | 125 | val stdin : in_ch exp 126 | val with_file_input : string -> (in_ch exp -> comm) -> comm 127 | 128 | type 'a fmt 129 | 130 | val stop : comm fmt 131 | val int32 : 'a fmt -> (int32 exp -> 'a) fmt 132 | val lit : string -> 'a fmt -> 'a fmt 133 | 134 | val printf : out_ch exp -> 'a fmt -> 'a 135 | val scanf : in_ch exp -> 'a fmt -> parsed:'a -> eof:comm -> comm 136 | 137 | end 138 | 139 | (** {2 Raw arrays} *) 140 | 141 | module RawArray : sig 142 | 143 | type 'a array 144 | 145 | val array : 'a typ -> int32 -> 'a array typ 146 | 147 | (** Array indexing. *) 148 | val (#@) : ('a array, [>`exp]) expr -> (int32, [>`exp]) expr -> ('a,[<`exp|`var]) expr 149 | 150 | end 151 | 152 | (** {3 Raw pointer manipulation}*) 153 | 154 | module RawPtr : sig 155 | 156 | type 'a ptr 157 | 158 | (** Representation of pointers to memory containing a value of some 159 | other type. *) 160 | val ptr : 'a typ -> 'a ptr typ 161 | 162 | (** Null pointer. *) 163 | val null : 'a ptr exp 164 | 165 | (** Pointer dereferencing. *) 166 | val deref : ('a ptr, [>`exp]) expr -> ('a,[<`exp|`var]) expr 167 | 168 | (** Pointer equality *) 169 | val (=*=) : ('a ptr, [>`exp]) expr -> ('a ptr, [>`exp]) expr -> bool exp 170 | 171 | (** Pointer disequality *) 172 | val (=!*=) : ('a ptr, [>`exp]) expr -> ('a ptr, [>`exp]) expr -> bool exp 173 | 174 | (** Combined pointer dereference and structure field access. *) 175 | val (#->) : ('s Struct.t ptr, [>`exp]) expr -> ('s, 'a) Struct.field -> ('a,[<`exp|`var]) expr 176 | 177 | (** Heap allocate some memory to hold values of a given type. *) 178 | val malloc : 'a ptr var -> 'a typ -> comm 179 | 180 | (** Heap allocate some memory to holds values of a given type, and 181 | dynamically some extra memory. *) 182 | val malloc_ext : 'a ptr var -> 'a typ -> (int32,[>`exp]) expr -> _ typ -> comm 183 | (* TODO: distinguish arbitrary length from fixed length structures somehow. *) 184 | 185 | (** Free heap allocated memory that came from malloc. *) 186 | val free : ('a ptr, [>`exp]) expr -> comm 187 | 188 | end 189 | 190 | (** {3 Function declarations} *) 191 | 192 | type 'a arg_spec 193 | 194 | val return_void : comm arg_spec 195 | 196 | val return : 'a typ -> 'a exp arg_spec 197 | 198 | val (@->) : string * 'a typ -> 'b arg_spec -> ('a exp -> 'b) arg_spec 199 | 200 | val (@&->) : string * 'a typ -> 'b arg_spec -> ('a var -> 'b) arg_spec 201 | 202 | val declare_func : name:string -> typ:'t arg_spec -> body:'t -> 't 203 | end 204 | 205 | type 'a program = 206 | { generate : 'comm. (module S with type comm = 'comm) -> 'a -> 'comm } 207 | -------------------------------------------------------------------------------- /idealised_algol.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "idealised_algol" 3 | version: "0.3" 4 | maintainer: "Robert Atkey " 5 | authors: "Robert Atkey " 6 | license: "MIT" 7 | build: [["jbuilder" "build" "-p" name "-j" jobs "@install"]] 8 | depends: ["fmt"] 9 | available: [ ocaml-version >= "4.04.0" ] 10 | -------------------------------------------------------------------------------- /ifds.mlog: -------------------------------------------------------------------------------- 1 | module type IFDS_PROGRAM = sig 2 | type procedure 3 | type point 4 | type entry_fact 5 | type fact 6 | 7 | edge : point * fact * point * fact 8 | 9 | start_edge : procedure * entry_fact * point * fact 10 | 11 | call : point * fact * procedure * entry_fact 12 | 13 | return : point * fact * point * fact * point * fact 14 | 15 | initial : procedure * entry_fact 16 | end 17 | 18 | module type IFDS = sig 19 | module P : IFDS_PROGRAM 20 | 21 | intra : P.procedure * P.entry_fact * P.point * P.fact 22 | 23 | callsite : P.point * P.fact * P.procedure * P.entry_fact 24 | end 25 | 26 | (* How to implement merging of internal_facts? Identify 'type internal_fact' as 27 | mergable (a new kind!), and change the meaning of the relation in that case? *) 28 | module IFDS = functor (P : IFDS_PROGRAM) -> struct 29 | 30 | define 31 | intra : P.procedure * P.entry_fact * P.point * P.fact 32 | intra (?p, ?ef, ?n, ?s) :- invoked (?p, ?ef), P.start_edge (?p, ?ef, ?n, ?s) 33 | intra (?p, ?ef, ?n, ?s) :- intra (?p, ?ef, ?n', ?s'), P.edge (?n', ?s', ?n, ?s) 34 | intra (?p, ?ef, ?n, ?s) :- intra (?p, ?ef, ?n', ?s'), callreturn (?n', ?s', ?n, ?s) 35 | 36 | and 37 | invoked : P.procedure * P.entry_fact 38 | invoked (?p, ?ef) :- P.initial (?p, ?ef) 39 | invoked (?p, ?ef) :- callsite(?n, ?s, ?p, ?ef) 40 | 41 | and 42 | callsite : P.point * P.fact * P.procedure * P.entry_fact 43 | callsite (?n, ?s, ?p', ?ef') :- 44 | intra (?p, ?ef, ?n, ?s), 45 | P.call (?n, ?s, ?p', ?ef') 46 | 47 | and 48 | callreturn : P.point * P.fact * P.point * P.fact 49 | callreturn(?n, ?s, ?n', ?s') :- 50 | callsite (?n, ?s, ?p, ?ef), 51 | intra (?p, ?ef, ?ne, ?se), 52 | P.return (?n, ?s, ?ne, ?se, ?n', ?s') 53 | 54 | end -------------------------------------------------------------------------------- /ifds2.mlog: -------------------------------------------------------------------------------- 1 | module type IFDS_PROGRAM = sig 2 | type procedure 3 | 4 | type point 5 | 6 | (* intra-procedural edges *) 7 | edge : point * point 8 | 9 | (* edge from a procedure call to first node in procedure *) 10 | start_edge : procedure * point 11 | 12 | (* call edge from one procedure to another *) 13 | call : point * procedure 14 | 15 | (* return (callsite, exitnode, returnnode) *) 16 | return : point * point * point 17 | 18 | (* set of procedures that are called initially *) 19 | initial : procedure 20 | end 21 | 22 | module type IFDS_PROGRAM_EXT = sig 23 | type procedure 24 | type point 25 | type entry_fact 26 | type fact 27 | 28 | edge : point * fact * point * fact 29 | 30 | start_edge : procedure * entry_fact * point * fact 31 | 32 | call : point * fact * procedure * entry_fact 33 | 34 | return : point * fact * point * fact * point * fact 35 | 36 | initial : procedure * entry_fact 37 | end 38 | 39 | module IFDS_of_Extended (P : IFDS_PROGRAM_EXT) = struct 40 | type procedure = P.procedure * P.entry_fact 41 | type point = P.point * P.fact 42 | 43 | define 44 | edge : point * point 45 | edge ((?n,?s), (?n',?s')) :- P.edge (?n, ?s, ?n', ?s') 46 | 47 | define 48 | start_edge : procedure * point 49 | start_edge ((?p, ?ef), (?n, ?s)) :- P.start_edge (?p, ?ef, ?n, ?s) 50 | 51 | define 52 | call : point * procedure 53 | call ((?n, ?s), (?p, ?ef)) :- P.call (?n, ?s, ?p, ?ef) 54 | 55 | define 56 | return : point * point * point 57 | return ((?nc,?sc), (?ne, ?se), (?nr, ?sr)) :- 58 | P.return (?nc, ?sc, ?ne, ?se, ?nr, ?sr) 59 | 60 | define 61 | initial : procedure 62 | initial ((?p, ?ef)) :- P.initial (?p, ?ef) 63 | end 64 | 65 | module IFDS (P : IFDS_PROGRAM) = struct 66 | 67 | define 68 | intra : P.procedure * P.point 69 | intra (?Proc, ?Node) :- invoked (?Proc), P.start_edge (?Proc, ?Node) 70 | intra (?Proc, ?Node) :- intra (?Proc, ?Node'), P.edge (?Node', ?Node) 71 | intra (?Proc, ?Node) :- intra (?Proc, ?Node'), callreturn (?Node', ?Node) 72 | 73 | and 74 | invoked : P.procedure 75 | invoked (?Proc) :- P.initial (?Proc) 76 | invoked (?Proc) :- callsite (?Node, ?Proc) 77 | 78 | and 79 | callsite : P.point * P.procedure 80 | callsite (?Node, ?CalledProc) :- 81 | intra (?Proc, ?Node), P.call (?Node, ?CalledProc) 82 | 83 | and 84 | callreturn : P.point * P.point 85 | callreturn (?CallNode, ?ReturnNode) :- 86 | callsite (?CallNode, ?CalledProc), 87 | intra (?CalledProc, ?ExitNode), 88 | P.return (?CallNode, ?ExitNode, ?ReturnNode) 89 | 90 | end 91 | 92 | module Test (P : IFDS_PROGRAM_EXT) = struct 93 | module P' = IFDS_of_Extended (P) 94 | module A = IFDS (P') 95 | end 96 | 97 | (* A nonsense example program *) 98 | module P = struct 99 | 100 | type procedure = int 101 | 102 | type point = int * int 103 | 104 | define 105 | edge : point * point 106 | edge ((1,4),(2,5)) 107 | edge ((1,2),(4,3)) 108 | 109 | define 110 | start_edge : procedure * point 111 | start_edge (2,(1,4)) 112 | 113 | define 114 | call : point * procedure 115 | call ((2,5),2) 116 | 117 | define 118 | return : point * point * point 119 | 120 | define 121 | initial : procedure 122 | initial (1) 123 | end 124 | 125 | module A = IFDS (P) 126 | -------------------------------------------------------------------------------- /modules.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "modules" 3 | version: "0.1" 4 | maintainer: "Robert Atkey " 5 | authors: "Robert Atkey " 6 | license: "MIT" 7 | build: [["jbuilder" "build" "-p" name "-j" jobs "@install"]] 8 | available: [ ocaml-version >= "4.04.0" ] 9 | -------------------------------------------------------------------------------- /modules/README.md: -------------------------------------------------------------------------------- 1 | # Modular Modules 2 | 3 | A implementation of Leroy's [modular 4 | modules](http://caml.inria.fr/pub/papers/xleroy-modular_modules-jfp.pdf), 5 | an OCaml like module language parameterised by the implementation of 6 | the core language. Given a core language type checker, this library 7 | adds facilities for modules, module signatures and functors. 8 | 9 | With respect to Leroy's paper, this implementation differs in several 10 | ways that make it more practical for a realistic language 11 | implementation: 12 | 13 | - A partial grammar with an OCaml inspired syntax, which can be 14 | integrated with the core language's grammar via 15 | [Menhir](http://cristal.inria.fr/~fpottier/menhir/)'s multi-file 16 | grammar support. 17 | - Pretty printing of the module language, given a pretty printer for 18 | the core language. 19 | - Support for multiple values bindings in a single structure item 20 | declaration, which allows recursively defined values. 21 | - Error reporting, with pretty printing of errors and line/column 22 | numbers. 23 | - An evaluator, for 'executing' the module language to produce a 24 | module-free program with all functors instantiated. 25 | - An implementation of recursive modules, based on ([Leroy's design 26 | notes for OCaml's recursive 27 | modules](http://caml.inria.fr/pub/papers/xleroy-recursive_modules-03.pdf)), 28 | but slightly simpler. 29 | 30 | Still to do (no particular order): 31 | 32 | - Multi-file programs (like OCaml's separate compilation support). 33 | - `include` and `open` support. 34 | - Copy the proposed `private` entries from OCaml 4.08 [see Leo's blog 35 | post](https://blog.janestreet.com/plans-for-ocaml-408/). 36 | -------------------------------------------------------------------------------- /modules/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name modules) 3 | (public_name modules) 4 | (flags (:standard -w -49+44-9-27))) 5 | 6 | (install 7 | (section lib) 8 | (package modules) 9 | (files modules_grammar.mly)) 10 | -------------------------------------------------------------------------------- /modules/evaluator.ml: -------------------------------------------------------------------------------- 1 | module type EVAL_ENV = sig 2 | type eval_value 3 | 4 | type eval_type 5 | 6 | type t 7 | 8 | type value = private [> `Value of eval_value | `Type of eval_type ] 9 | 10 | val empty : t 11 | 12 | val add_values : (Ident.t * eval_value) list -> t -> t 13 | 14 | val find : Path.t -> t -> value option 15 | end 16 | 17 | module type CORE_EVAL = sig 18 | module Core : Syntax.CORE_SYNTAX 19 | 20 | type 'a eval 21 | 22 | val return : 'a -> 'a eval 23 | 24 | val (>>=) : 'a eval -> ('a -> 'b eval) -> 'b eval 25 | 26 | type eval_value 27 | 28 | type eval_type 29 | 30 | module Eval (Env : EVAL_ENV 31 | with type eval_value = eval_value 32 | and type eval_type = eval_type) : 33 | sig 34 | 35 | val eval_type : Env.t -> Core.kind -> Core.def_type -> eval_type 36 | 37 | val eval_decl : Env.t -> string list -> Ident.t -> Core.val_type -> eval_value eval 38 | 39 | val eval_term : Env.t -> string list -> Core.term -> (Ident.t * eval_value) list eval 40 | 41 | end 42 | end 43 | 44 | module Make 45 | (Mod : Syntax.MOD_SYNTAX) 46 | (Core_eval : CORE_EVAL with module Core = Mod.Core) = 47 | struct 48 | 49 | open Mod 50 | 51 | module Env = struct 52 | type eval_value = Core_eval.eval_value 53 | type eval_type = Core_eval.eval_type 54 | 55 | type t = value Ident.Table.t 56 | 57 | and value = 58 | [ `Value of eval_value 59 | | `Type of eval_type 60 | | `Structure of (string * value) list 61 | | `Functor of t * Ident.t * Mod.mod_term 62 | ] 63 | 64 | let empty = 65 | Ident.Table.empty 66 | 67 | let add = Ident.Table.add 68 | 69 | let add_values = 70 | List.fold_right 71 | (fun (id, value) -> add id (`Value value)) 72 | 73 | let rec find lident t = 74 | match lident with 75 | | Path.Pident ident -> 76 | Ident.Table.find ident t 77 | | Path.Pdot (root, field) -> 78 | match find root t with 79 | | None -> 80 | None 81 | | Some (`Structure bindings) -> 82 | (try Some (List.assoc field bindings) 83 | with Not_found -> None) 84 | | Some _ -> 85 | failwith "identifier not found" 86 | end 87 | 88 | let return = Core_eval.return 89 | and (>>=) = Core_eval.(>>=) 90 | 91 | module Eval = Core_eval.Eval (Env) 92 | 93 | let rec declare_modtype env path = function 94 | | {modtype_data=Modtype_signature sigitems} -> 95 | declare_signature env path [] sigitems >>= fun bindings -> 96 | return (`Structure bindings) 97 | 98 | | _ -> 99 | failwith "internal error: expecting a signature type" 100 | 101 | and declare_signature env path rev_bindings = function 102 | | [] -> 103 | return (List.rev rev_bindings) 104 | 105 | | {sigitem_data=Sig_value (ident, val_type)} :: items -> 106 | Eval.eval_decl env path ident val_type >>= fun value -> 107 | declare_signature env path ((Ident.name ident, `Value value) :: rev_bindings) items 108 | 109 | | {sigitem_data=Sig_type _} :: items -> 110 | (* FIXME: probably shouldn't ignore this -- the typecheck ought 111 | to reject uses of abstract types in signatures of recursive 112 | modules. *) 113 | declare_signature env path rev_bindings items 114 | 115 | | {sigitem_data=Sig_module (ident, modty)} :: items -> 116 | let sub_path = Ident.name ident :: path in 117 | declare_modtype env sub_path modty >>= fun value -> 118 | let env = Env.add ident value env in 119 | let rev_bindings = (Ident.name ident, value) :: rev_bindings in 120 | declare_signature env path rev_bindings items 121 | 122 | | {sigitem_data=Sig_modty _} :: items -> 123 | declare_signature env path rev_bindings items 124 | 125 | let rec declare_recbindings env path new_env rev_bindings = function 126 | | [] -> 127 | return (new_env, rev_bindings) 128 | 129 | | (ident, modty, _) :: rec_bindings -> 130 | let sub_path = Ident.name ident :: path in 131 | declare_modtype env sub_path modty >>= fun value -> 132 | let rev_bindings = (Ident.name ident, value) :: rev_bindings in 133 | let new_env = Env.add ident value new_env in 134 | declare_recbindings env path new_env rev_bindings rec_bindings 135 | 136 | let rec eval_structure env path rev_bindings = function 137 | | [] -> 138 | return (List.rev rev_bindings) 139 | 140 | | {stritem_data=Str_value term} :: items -> 141 | Eval.eval_term env path term >>= fun bindings -> 142 | let env = Env.add_values bindings env in 143 | let rev_bindings = 144 | List.fold_right 145 | (fun (ident, value) -> 146 | List.cons (Ident.name ident, `Value value)) 147 | bindings 148 | rev_bindings 149 | in 150 | eval_structure env path rev_bindings items 151 | 152 | | {stritem_data=Str_type (ident, kind, typ)} :: items -> 153 | let typ = Eval.eval_type env kind typ in 154 | let value = `Type typ in 155 | let env = Env.add ident value env in 156 | let rev_bindings = (Ident.name ident, value) :: rev_bindings in 157 | eval_structure env path rev_bindings items 158 | 159 | | {stritem_data=Str_module (ident, modl)} :: items -> 160 | let sub_path = Ident.name ident :: path in 161 | eval_modterm env sub_path modl >>= fun value -> 162 | let env = Env.add ident value env in 163 | let rev_bindings = (Ident.name ident, value) :: rev_bindings in 164 | eval_structure env path rev_bindings items 165 | 166 | | {stritem_data=Str_modty _} :: items -> 167 | eval_structure env path rev_bindings items 168 | 169 | | {stritem_data=Str_modrec bindings} :: items -> 170 | declare_recbindings env path env rev_bindings bindings 171 | >>= fun (env, rev_bindings) -> 172 | eval_recbindings env path bindings 173 | >>= fun () -> 174 | eval_structure env path rev_bindings items 175 | 176 | and eval_recbindings env path = function 177 | | [] -> 178 | return () 179 | | (ident, modty, modl) :: rec_bindings -> 180 | let sub_path = Ident.name ident :: path in 181 | eval_modterm env sub_path modl >>= fun _ -> 182 | eval_recbindings env path rec_bindings 183 | 184 | and eval_modterm env path = function 185 | | {modterm_data=Mod_longident lid} -> 186 | (match Env.find lid env with 187 | | Some value -> 188 | return value 189 | | None -> 190 | failwith 191 | "internal error: module identifier not found during evaluation") 192 | 193 | | {modterm_data=Mod_structure items} -> 194 | eval_structure env path [] items >>= fun bindings -> 195 | return (`Structure bindings) 196 | 197 | | {modterm_data=Mod_functor (arg_name, _, body)} -> 198 | return (`Functor (env, arg_name, body)) 199 | 200 | | {modterm_data=Mod_apply (funct, arg)} -> 201 | (eval_modterm env path funct >>= function 202 | | `Functor (clo_env, arg_name, body) -> 203 | eval_modterm env path arg >>= fun value -> 204 | let env = Env.add arg_name value clo_env in 205 | eval_modterm env path body 206 | | _ -> 207 | failwith "internal error: not a functor in application") 208 | 209 | | {modterm_data=Mod_constraint (modl, _)} -> 210 | eval_modterm env path modl 211 | 212 | let eval_structure str = 213 | eval_structure Env.empty [] [] str >>= fun _ -> return () 214 | 215 | end 216 | -------------------------------------------------------------------------------- /modules/evaluator.mli: -------------------------------------------------------------------------------- 1 | (** Evaluation of the module language. *) 2 | 3 | module type EVAL_ENV = sig 4 | type eval_value 5 | 6 | type eval_type 7 | 8 | type value = private [> `Value of eval_value | `Type of eval_type ] 9 | 10 | type t 11 | 12 | val empty : t 13 | 14 | val add_values : (Ident.t * eval_value) list -> t -> t 15 | 16 | val find : Path.t -> t -> value option 17 | end 18 | 19 | module type CORE_EVAL = sig 20 | module Core : Syntax.CORE_SYNTAX 21 | 22 | type 'a eval 23 | 24 | val return : 'a -> 'a eval 25 | 26 | val (>>=) : 'a eval -> ('a -> 'b eval) -> 'b eval 27 | 28 | type eval_value 29 | 30 | type eval_type 31 | 32 | module Eval (Env : EVAL_ENV 33 | with type eval_value = eval_value 34 | and type eval_type = eval_type) : 35 | sig 36 | 37 | val eval_type : Env.t -> Core.kind -> Core.def_type -> eval_type 38 | 39 | val eval_decl : Env.t -> string list -> Ident.t -> Core.val_type -> eval_value eval 40 | 41 | val eval_term : Env.t -> string list -> Core.term -> (Ident.t * eval_value) list eval 42 | 43 | end 44 | end 45 | 46 | module Make 47 | (Mod : Syntax.MOD_SYNTAX) 48 | (Core_eval : CORE_EVAL with module Core = Mod.Core) : 49 | sig 50 | val eval_structure : Mod.structure -> unit Core_eval.eval 51 | end 52 | -------------------------------------------------------------------------------- /modules/ident.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { name : string 3 | ; stamp : int 4 | } 5 | 6 | let currstamp = ref 0 7 | 8 | let create s = 9 | incr currstamp; 10 | {name = s; stamp = !currstamp} 11 | 12 | let name id = 13 | id.name 14 | 15 | let full_name id = Printf.sprintf "%s/%d" id.name id.stamp 16 | 17 | let equal id1 id2 = 18 | id1.stamp = id2.stamp 19 | 20 | module OT = struct 21 | type nonrec t = t 22 | let compare x y = 23 | compare x.stamp y.stamp 24 | end 25 | 26 | module Table = struct 27 | include Map.Make (OT) 28 | let find key table = 29 | try Some (find key table) with Not_found -> None 30 | end 31 | 32 | let pp pp {name;stamp} = 33 | Format.fprintf pp "%s/%d" name stamp 34 | -------------------------------------------------------------------------------- /modules/ident.mli: -------------------------------------------------------------------------------- 1 | (** Stamped identifiers *) 2 | 3 | (** The type of stamped identifiers. *) 4 | type t 5 | 6 | (** [create name] creates a new stamped identifier with name [name] 7 | that is distinct from all other identifiers. *) 8 | val create : string -> t 9 | 10 | (** [name ident] returns the name of the identifier [ident]. This will 11 | be the same name as the one passed to {!create} when creating this 12 | identifier. *) 13 | val name : t -> string 14 | 15 | (** [full_name ident] returns a string representation of the 16 | identifier [ident] that uniquely identifies this identifier amongst 17 | all others created during this run of the program. *) 18 | val full_name : t -> string 19 | 20 | (** [pp fmt ident] pretty prints the {!full_name} of [ident] on the 21 | formatter [fmt]. *) 22 | val pp : Format.formatter -> t -> unit 23 | 24 | (** [equal ident1 ident2] returns [true] when [ident1] and [ident2] 25 | are the same identifier, and [false] otherwise. Note that two 26 | identifiers can have the same name (as returned by {!name}) but not 27 | be equal. *) 28 | val equal : t -> t -> bool 29 | 30 | (** Immutable tables that bind identifiers to arbitrary data. *) 31 | module Table : sig 32 | type key = t 33 | 34 | (** Tables binding identifiers to data. *) 35 | type 'a t 36 | 37 | (** An empty identifier indexed table. *) 38 | val empty : 'a t 39 | 40 | (** [add ident data t] returns a the table [t] extended with a 41 | binding of [ident] to [data]. *) 42 | val add : key -> 'a -> 'a t -> 'a t 43 | 44 | (** [find ident t] returns [Some data] if [data] is bound to [ident] 45 | in [t], and [None] otherwise. *) 46 | val find : key -> 'a t -> 'a option 47 | end 48 | 49 | -------------------------------------------------------------------------------- /modules/modules_grammar.mly: -------------------------------------------------------------------------------- 1 | (* 2 | Requirements: 3 | - Tokens: DOT, IDENT, FUNCTOR, LPAREN, COLON, RPAREN, ARROW, SIG, END, WITH 4 | MODULE, STRUCT, TYPE, EQUALS, REC 5 | - Non terminals: longident, str_value, str_type(NAME), sig_value, sig_type 6 | - An implementation of MOD_SYNTAX_RAW is open 7 | 8 | Provides: 9 | - Non terminals: sig_item, str_item 10 | 11 | *) 12 | 13 | %% 14 | 15 | (* the module language *) 16 | 17 | mod_type: 18 | | FUNCTOR; LPAREN; id=IDENT; COLON; mty1=mod_type; RPAREN; ARROW; mty2=mod_type 19 | { { modtype_loc = Location.mk $startpos $endpos 20 | ; modtype_data = Modtype_functor (id, mty1, mty2) } } 21 | | mty=mod_type2 22 | { mty } 23 | 24 | mod_type2: 25 | | lid=longident 26 | { { modtype_loc = Location.mk $startpos $endpos 27 | ; modtype_data = Modtype_longident lid } } 28 | | SIG; s=list(sig_item); END 29 | { { modtype_loc = Location.mk $startpos $endpos 30 | ; modtype_data = Modtype_signature s } } 31 | | mty=mod_type2; WITH; ty_constraint=str_type(separated_nonempty_list(DOT, IDENT)) 32 | { let path, kind, ty = ty_constraint in 33 | { modtype_loc = Location.mk $startpos $endpos 34 | ; modtype_data = Modtype_withtype (mty, path, kind, ty) } } 35 | | LPAREN; mty=mod_type; RPAREN 36 | { mty } 37 | 38 | %public 39 | sig_item: 40 | | v=sig_value 41 | { let (id, ty) = v in 42 | { sigitem_loc = Location.mk $startpos $endpos 43 | ; sigitem_data = Sig_value (id, ty) } } 44 | | t=sig_type 45 | { let (id, kind, manifest) = t in 46 | { sigitem_loc = Location.mk $startpos $endpos 47 | ; sigitem_data = Sig_type (id, { kind; manifest }) } } 48 | | MODULE; id=IDENT; mty=functor_type_decls 49 | { { sigitem_loc = Location.mk $startpos $endpos 50 | ; sigitem_data = Sig_module (id, mty) } } 51 | | MODULE; TYPE; id=IDENT; EQUALS; mty=mod_type 52 | { { sigitem_loc = Location.mk $startpos $endpos 53 | ; sigitem_data = Sig_modty (id, mty) } } 54 | 55 | functor_type_decls: 56 | | COLON; mty=mod_type 57 | { mty } 58 | | LPAREN; id=IDENT; COLON; mty1=mod_type; RPAREN; mty2=functor_type_decls 59 | { { modtype_loc = Location.mk $startpos $endpos 60 | ; modtype_data = Modtype_functor (id, mty1, mty2) } } 61 | 62 | mod_term: 63 | | FUNCTOR; LPAREN; id=IDENT; COLON; mty=mod_type; RPAREN; ARROW; modl=mod_term 64 | { { modterm_loc = Location.mk $startpos $endpos 65 | ; modterm_data = Mod_functor (id, mty, modl) } } 66 | | m=mod_term2 67 | { m } 68 | 69 | mod_term2: 70 | | mod1=mod_term2; LPAREN; mod2=mod_term; RPAREN 71 | { { modterm_loc = Location.mk $startpos $endpos 72 | ; modterm_data = Mod_apply (mod1, mod2) } } 73 | | lid=longident 74 | { { modterm_loc = Location.mk $startpos $endpos 75 | ; modterm_data = Mod_longident lid } } 76 | | STRUCT; items=list(str_item); END 77 | { { modterm_loc = Location.mk $startpos $endpos 78 | ; modterm_data = Mod_structure items } } 79 | | LPAREN; modl=mod_term; COLON; mty=mod_type; RPAREN 80 | { { modterm_loc = Location.mk $startpos $endpos 81 | ; modterm_data = Mod_constraint (modl, mty) } } 82 | | LPAREN; m=mod_term; RPAREN 83 | { m } 84 | 85 | %public 86 | str_item: 87 | | d=str_value 88 | { { stritem_loc = Location.mk $startpos $endpos 89 | ; stritem_data = Str_value d } } 90 | | t=str_type(IDENT) 91 | { let (id, kind, ty) = t in 92 | { stritem_loc = Location.mk $startpos $endpos 93 | ; stritem_data = Str_type (id, kind, ty) } } 94 | | MODULE; id=IDENT; modl=functor_decls 95 | { { stritem_loc = Location.mk $startpos $endpos 96 | ; stritem_data = Str_module (id, modl) } } 97 | | MODULE; TYPE; id=IDENT; EQUALS; mty=mod_type 98 | { { stritem_loc = Location.mk $startpos $endpos 99 | ; stritem_data = Str_modty (id, mty) } } 100 | | MODULE; REC; bindings=separated_nonempty_list(AND, rec_module_binding) 101 | { { stritem_loc = Location.mk $startpos $endpos 102 | ; stritem_data = Str_modrec bindings } } 103 | 104 | rec_module_binding: 105 | | id=IDENT; COLON; mty=mod_type; EQUALS; modl=mod_term2 106 | { (id, mty, modl) } 107 | 108 | functor_decls: 109 | | EQUALS; modl=mod_term 110 | { modl } 111 | | LPAREN; id=IDENT; COLON; mty=mod_type; RPAREN; modl=functor_decls 112 | { { modterm_loc = Location.mk $startpos $endpos 113 | ; modterm_data = Mod_functor (id, mty, modl) } } 114 | -------------------------------------------------------------------------------- /modules/path.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Pident of Ident.t 3 | | Pdot of t * string 4 | 5 | let rec equal p1 p2 = 6 | match p1, p2 with 7 | | Pident id1, Pident id2 -> 8 | Ident.equal id1 id2 9 | | Pdot (r1, field1), Pdot (r2, field2) -> 10 | equal r1 r2 && field1 = field2 11 | | _, _ -> 12 | false 13 | -------------------------------------------------------------------------------- /modules/path.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Pident of Ident.t 3 | | Pdot of t * string 4 | 5 | val equal : t -> t -> bool 6 | -------------------------------------------------------------------------------- /modules/subst.ml: -------------------------------------------------------------------------------- 1 | type t = Path.t Ident.Table.t 2 | 3 | let identity = Ident.Table.empty 4 | 5 | let add = Ident.Table.add 6 | 7 | let rec path sub = function 8 | | Path.Pident id as p -> 9 | (match Ident.Table.find id sub with 10 | | None -> p 11 | | Some p -> p) 12 | | Path.Pdot (root, field) -> 13 | Path.Pdot (path sub root, field) 14 | -------------------------------------------------------------------------------- /modules/subst.mli: -------------------------------------------------------------------------------- 1 | (** Identifier to Path substitutions *) 2 | 3 | type t 4 | 5 | val identity : t 6 | 7 | val add : Ident.t -> Path.t -> t -> t 8 | 9 | val path : t -> Path.t -> Path.t 10 | -------------------------------------------------------------------------------- /modules/syntax.ml: -------------------------------------------------------------------------------- 1 | module type SOURCE_LOCATION = sig 2 | type t 3 | 4 | val generated : t 5 | 6 | val pp : Format.formatter -> t -> unit 7 | end 8 | 9 | module type NAMES = sig 10 | type ident 11 | 12 | type longident 13 | 14 | val pp_ident : Format.formatter -> ident -> unit 15 | 16 | val pp_longident : Format.formatter -> longident -> unit 17 | end 18 | 19 | module String_names = struct 20 | type ident = string 21 | type longident = 22 | | Lid_ident of ident 23 | | Lid_dot of longident * string 24 | 25 | let pp_ident = Format.pp_print_string 26 | 27 | let rec pp_longident pp = function 28 | | Lid_ident id -> 29 | Format.pp_print_string pp id 30 | | Lid_dot (lid, f) -> 31 | pp_longident pp lid; 32 | Format.pp_print_string pp "."; 33 | Format.pp_print_string pp f 34 | end 35 | 36 | let rec pp_path fmt = function 37 | | [] -> 38 | failwith "internal error: empty path" 39 | | [nm] -> 40 | Format.pp_print_string fmt nm 41 | | nm::nms -> 42 | Format.fprintf fmt "%s.%a" nm pp_path nms 43 | 44 | module Bound_names = struct 45 | type ident = Ident.t 46 | type longident = Path.t 47 | 48 | let pp_ident pp id = 49 | Format.pp_print_string pp (Ident.name id) 50 | 51 | let rec pp_longident pp = function 52 | | Path.Pident id -> pp_ident pp id 53 | | Path.Pdot (lid, f) -> 54 | pp_longident pp lid; 55 | Format.pp_print_string pp "."; 56 | Format.pp_print_string pp f 57 | end 58 | 59 | module type CORE_SYNTAX_RAW = sig 60 | module Location : SOURCE_LOCATION 61 | module Names : NAMES 62 | 63 | type term 64 | type val_type 65 | type def_type 66 | type kind 67 | 68 | val pp_term : Format.formatter -> term -> unit 69 | 70 | val pp_val_decl : Format.formatter -> Names.ident * val_type -> unit 71 | 72 | val pp_def_decl : 73 | Format.formatter -> Names.ident * kind * def_type option -> unit 74 | 75 | val pp_type_constraint : 76 | Format.formatter -> string list * kind * def_type -> unit 77 | end 78 | 79 | module type MOD_SYNTAX_RAW = sig 80 | module Core : CORE_SYNTAX_RAW 81 | 82 | type type_decl = 83 | { kind : Core.kind 84 | ; manifest : Core.def_type option 85 | } 86 | 87 | val pp_type_decl : Format.formatter -> Core.Names.ident * type_decl -> unit 88 | 89 | type mod_type = 90 | { modtype_loc : Core.Location.t 91 | ; modtype_data : modtype_data 92 | } 93 | 94 | and modtype_data = 95 | | Modtype_longident of Core.Names.longident 96 | | Modtype_signature of signature 97 | | Modtype_functor of Core.Names.ident * mod_type * mod_type 98 | | Modtype_withtype of mod_type * string list * Core.kind * Core.def_type 99 | 100 | and signature = 101 | sig_item list 102 | 103 | and sig_item = 104 | { sigitem_loc : Core.Location.t 105 | ; sigitem_data : sigitem_data 106 | } 107 | 108 | and sigitem_data = 109 | | Sig_value of Core.Names.ident * Core.val_type 110 | | Sig_type of Core.Names.ident * type_decl 111 | | Sig_module of Core.Names.ident * mod_type 112 | | Sig_modty of Core.Names.ident * mod_type 113 | 114 | val pp_modtype : Format.formatter -> mod_type -> unit 115 | val pp_signature : Format.formatter -> signature -> unit 116 | val pp_sig_item : Format.formatter -> sig_item -> unit 117 | 118 | type mod_term = 119 | { modterm_loc : Core.Location.t 120 | ; modterm_data : modterm_data 121 | } 122 | 123 | and modterm_data = 124 | | Mod_longident of Core.Names.longident 125 | | Mod_structure of structure 126 | | Mod_functor of Core.Names.ident * mod_type * mod_term 127 | | Mod_apply of mod_term * mod_term 128 | | Mod_constraint of mod_term * mod_type 129 | 130 | and structure = 131 | str_item list 132 | 133 | and str_item = 134 | { stritem_loc : Core.Location.t 135 | ; stritem_data : stritem_data 136 | } 137 | 138 | and stritem_data = 139 | | Str_value of Core.term 140 | | Str_type of Core.Names.ident * Core.kind * Core.def_type 141 | | Str_module of Core.Names.ident * mod_term 142 | | Str_modty of Core.Names.ident * mod_type 143 | | Str_modrec of (Core.Names.ident * mod_type * mod_term) list 144 | 145 | val pp_modterm : Format.formatter -> mod_term -> unit 146 | val pp_structure : Format.formatter -> structure -> unit 147 | end 148 | 149 | module Mod_Syntax_Raw (Core : CORE_SYNTAX_RAW) 150 | : MOD_SYNTAX_RAW with module Core = Core = 151 | struct 152 | module Core = Core 153 | 154 | type type_decl = 155 | { kind : Core.kind 156 | ; manifest : Core.def_type option 157 | } 158 | 159 | type mod_type = 160 | { modtype_loc : Core.Location.t 161 | ; modtype_data : modtype_data 162 | } 163 | 164 | and modtype_data = 165 | | Modtype_longident of Core.Names.longident 166 | | Modtype_signature of signature 167 | | Modtype_functor of Core.Names.ident * mod_type * mod_type 168 | | Modtype_withtype of mod_type * string list * Core.kind * Core.def_type 169 | 170 | and signature = 171 | sig_item list 172 | 173 | and sig_item = 174 | { sigitem_loc : Core.Location.t 175 | ; sigitem_data : sigitem_data 176 | } 177 | 178 | and sigitem_data = 179 | | Sig_value of Core.Names.ident * Core.val_type 180 | | Sig_type of Core.Names.ident * type_decl 181 | | Sig_module of Core.Names.ident * mod_type 182 | | Sig_modty of Core.Names.ident * mod_type 183 | 184 | let pp_type_decl fmt (id, { kind; manifest }) = 185 | Core.pp_def_decl fmt (id, kind, manifest) 186 | 187 | 188 | 189 | let rec pp_modtype fmt = function 190 | | {modtype_data = Modtype_functor (id, mty1, mty2)} -> 191 | Format.fprintf fmt "functor(%a : %a) ->@ %a" 192 | Core.Names.pp_ident id 193 | pp_modtype mty1 194 | pp_modtype mty2 195 | | modty -> 196 | pp_modtype2 fmt modty 197 | 198 | and pp_modtype2 fmt = function 199 | | {modtype_data = Modtype_longident lid} -> 200 | Core.Names.pp_longident fmt lid 201 | | {modtype_data = Modtype_signature sg} -> 202 | Format.fprintf fmt "@[@[sig@ %a@]@ end@]" 203 | pp_signature sg 204 | | {modtype_data = Modtype_withtype (mty, path, kind, deftype)} -> 205 | Format.fprintf fmt "%a with type %a = %a" 206 | pp_modtype2 mty 207 | pp_path path 208 | Core.pp_type_constraint (path, kind, deftype) 209 | | modty -> 210 | Format.fprintf fmt "(%a)" pp_modtype modty 211 | 212 | and pp_signature fmt = function 213 | | [] -> () 214 | | [item] -> 215 | pp_sig_item fmt item 216 | | item :: items -> 217 | pp_sig_item fmt item; 218 | Format.pp_print_space fmt (); 219 | pp_signature fmt items 220 | 221 | and pp_sig_item fmt = function 222 | | { sigitem_data = Sig_value (id, vty) } -> 223 | Core.pp_val_decl fmt (id, vty) 224 | | { sigitem_data = Sig_type (id, decl) } -> 225 | pp_type_decl fmt (id, decl) 226 | | { sigitem_data = Sig_module (id, mty) } -> 227 | Format.fprintf fmt "@[module %a :@ %a@]" 228 | Core.Names.pp_ident id 229 | pp_modtype mty 230 | | { sigitem_data = Sig_modty (id, mty) } -> 231 | Format.fprintf fmt "@[module type %a =@ %a@]" 232 | Core.Names.pp_ident id 233 | pp_modtype mty 234 | 235 | type mod_term = 236 | { modterm_loc : Core.Location.t 237 | ; modterm_data : modterm_data 238 | } 239 | 240 | and modterm_data = 241 | | Mod_longident of Core.Names.longident 242 | | Mod_structure of structure 243 | | Mod_functor of Core.Names.ident * mod_type * mod_term 244 | | Mod_apply of mod_term * mod_term 245 | | Mod_constraint of mod_term * mod_type 246 | 247 | and structure = 248 | str_item list 249 | 250 | and str_item = 251 | { stritem_loc : Core.Location.t 252 | ; stritem_data : stritem_data 253 | } 254 | 255 | and stritem_data = 256 | | Str_value of Core.term 257 | | Str_type of Core.Names.ident * Core.kind * Core.def_type 258 | | Str_module of Core.Names.ident * mod_term 259 | | Str_modty of Core.Names.ident * mod_type 260 | | Str_modrec of (Core.Names.ident * mod_type * mod_term) list 261 | 262 | let rec pp_modterm pp = function 263 | | {modterm_data = Mod_functor (id, mty, modl)} -> 264 | Format.fprintf pp "functor(%a : %a) ->@ %a" 265 | Core.Names.pp_ident id 266 | pp_modtype mty 267 | pp_modterm modl 268 | | modterm -> 269 | pp_modterm2 pp modterm 270 | 271 | and pp_modterm2 fmt = function 272 | | {modterm_data=Mod_longident lid} -> 273 | Core.Names.pp_longident fmt lid 274 | | {modterm_data=Mod_structure items} -> 275 | Format.fprintf fmt "@[struct@ %a@]@ end" 276 | pp_structure items 277 | | {modterm_data = Mod_apply (modl1, modl2)} -> 278 | Format.fprintf fmt "%a (%a)" 279 | pp_modterm2 modl1 280 | pp_modterm modl2 281 | | {modterm_data = Mod_constraint (modl, mty)} -> 282 | Format.fprintf fmt "(%a :@ %a)" 283 | pp_modterm modl 284 | pp_modtype mty 285 | | modterm -> 286 | Format.fprintf fmt "(%a)" pp_modterm modterm 287 | 288 | and pp_structure pp = function 289 | | [] -> () 290 | | [item] -> 291 | pp_str_item pp item 292 | | item :: items -> 293 | pp_str_item pp item; 294 | Format.pp_print_space pp (); 295 | Format.pp_print_cut pp (); 296 | pp_structure pp items 297 | 298 | and pp_str_item fmt = function 299 | | {stritem_data = Str_value term} -> 300 | Core.pp_term fmt term 301 | | {stritem_data = Str_type (id, kind, def_type)} -> 302 | Core.pp_def_decl fmt (id, kind, Some def_type) 303 | | {stritem_data = Str_module (id, modl)} -> 304 | Format.fprintf fmt "@[module %a =@ %a@]" 305 | Core.Names.pp_ident id 306 | pp_modterm modl 307 | | {stritem_data = Str_modty (id, mty)} -> 308 | Format.fprintf fmt "@[module type %a =@ %a@]" 309 | Core.Names.pp_ident id 310 | pp_modtype mty 311 | | {stritem_data = Str_modrec bindings} -> 312 | Format.fprintf fmt "@[@[module rec %a@]" 313 | pp_module_bindings bindings 314 | 315 | and pp_module_bindings fmt = function 316 | | [] -> () 317 | | [(id, modty, modl)] -> 318 | Format.fprintf fmt "%a : %a =@ %a@]" 319 | Core.Names.pp_ident id 320 | pp_modtype modty 321 | pp_modterm modl 322 | | (id, modty, modl)::bindings -> 323 | Format.fprintf fmt "%a : %a =@ %a@]@ @[and %a" 324 | Core.Names.pp_ident id 325 | pp_modtype modty 326 | pp_modterm modl 327 | pp_module_bindings bindings 328 | end 329 | 330 | module type CORE_SYNTAX_CONCRETE = 331 | CORE_SYNTAX_RAW 332 | with type Names.ident = string 333 | and type Names.longident = String_names.longident 334 | 335 | module type CORE_SYNTAX = sig 336 | include CORE_SYNTAX_RAW 337 | with type Names.ident = Ident.t 338 | and type Names.longident = Path.t 339 | 340 | val subst_valtype : Subst.t -> val_type -> val_type 341 | val subst_deftype : Subst.t -> def_type -> def_type 342 | val subst_kind : Subst.t -> kind -> kind 343 | end 344 | 345 | module type MOD_SYNTAX = sig 346 | module Core : CORE_SYNTAX 347 | 348 | include MOD_SYNTAX_RAW with module Core := Core 349 | 350 | val subst_typedecl : Subst.t -> type_decl -> type_decl 351 | 352 | val subst_modtype : Subst.t -> mod_type -> mod_type 353 | end 354 | 355 | module type MOD_SYNTAX_CONCRETE = 356 | MOD_SYNTAX_RAW 357 | with type Core.Names.ident = String_names.ident 358 | and type Core.Names.longident = String_names.longident 359 | 360 | 361 | module Mod_Syntax (Core_syntax : CORE_SYNTAX) 362 | : MOD_SYNTAX with module Core = Core_syntax = 363 | struct 364 | module Core = Core_syntax 365 | 366 | include (Mod_Syntax_Raw (Core_syntax) 367 | : MOD_SYNTAX_RAW with module Core := Core_syntax) 368 | 369 | let subst_typedecl sub decl = 370 | { kind = 371 | Core.subst_kind sub decl.kind 372 | ; manifest = 373 | match decl.manifest with 374 | | None -> None 375 | | Some dty -> Some (Core.subst_deftype sub dty) 376 | } 377 | 378 | let rec subst_modtype sub modtype = 379 | {modtype with 380 | modtype_data = 381 | match modtype.modtype_data with 382 | | Modtype_longident p -> 383 | Modtype_longident (Subst.path sub p) 384 | | Modtype_signature sg -> 385 | Modtype_signature (List.map (subst_sig_item sub) sg) 386 | | Modtype_functor (id, mty1, mty2) -> 387 | Modtype_functor (id, subst_modtype sub mty1, subst_modtype sub mty2) 388 | | Modtype_withtype (mty, path, kind, deftype) -> 389 | Modtype_withtype (subst_modtype sub mty, 390 | path, 391 | Core.subst_kind sub kind, 392 | Core.subst_deftype sub deftype) 393 | } 394 | 395 | and subst_sig_item sub sigitem = 396 | {sigitem with 397 | sigitem_data = 398 | match sigitem.sigitem_data with 399 | | Sig_value (id, vty) -> Sig_value (id, Core.subst_valtype sub vty) 400 | | Sig_type (id, decl) -> Sig_type (id, subst_typedecl sub decl) 401 | | Sig_module (id, mty) -> Sig_module (id, subst_modtype sub mty) 402 | | Sig_modty (id, mty) -> Sig_modty (id, subst_modtype sub mty) 403 | } 404 | end 405 | -------------------------------------------------------------------------------- /modules/syntax.mli: -------------------------------------------------------------------------------- 1 | (** Abstract Syntax of the Module Language. *) 2 | 3 | module type SOURCE_LOCATION = sig 4 | type t 5 | 6 | val generated : t 7 | 8 | val pp : Format.formatter -> t -> unit 9 | end 10 | 11 | module type NAMES = sig 12 | type ident 13 | 14 | type longident 15 | 16 | val pp_ident : Format.formatter -> ident -> unit 17 | 18 | val pp_longident : Format.formatter -> longident -> unit 19 | end 20 | 21 | module String_names : sig 22 | type ident = string 23 | 24 | type longident = 25 | | Lid_ident of ident 26 | | Lid_dot of longident * string 27 | 28 | include NAMES 29 | with type ident := ident 30 | and type longident := longident 31 | end 32 | 33 | val pp_path : Format.formatter -> string list -> unit 34 | 35 | module Bound_names : sig 36 | type ident = Ident.t 37 | 38 | type longident = Path.t 39 | 40 | include NAMES 41 | with type ident := ident 42 | and type longident := longident 43 | end 44 | 45 | module type CORE_SYNTAX_RAW = sig 46 | module Location : SOURCE_LOCATION 47 | 48 | module Names : NAMES 49 | 50 | type term 51 | 52 | type val_type 53 | 54 | type def_type 55 | 56 | type kind 57 | 58 | val pp_term : Format.formatter -> term -> unit 59 | 60 | val pp_val_decl : Format.formatter -> Names.ident * val_type -> unit 61 | 62 | val pp_def_decl : 63 | Format.formatter -> Names.ident * kind * def_type option -> unit 64 | 65 | (* FIXME: make this match the way the grammar is set up *) 66 | val pp_type_constraint : 67 | Format.formatter -> string list * kind * def_type -> unit 68 | end 69 | 70 | module type MOD_SYNTAX_RAW = sig 71 | module Core : CORE_SYNTAX_RAW 72 | 73 | type type_decl = 74 | { kind : Core.kind 75 | ; manifest : Core.def_type option 76 | } 77 | 78 | val pp_type_decl : Format.formatter -> Core.Names.ident * type_decl -> unit 79 | 80 | type mod_type = 81 | { modtype_loc : Core.Location.t 82 | ; modtype_data : modtype_data 83 | } 84 | 85 | and modtype_data = 86 | | Modtype_longident of Core.Names.longident 87 | | Modtype_signature of signature 88 | | Modtype_functor of Core.Names.ident * mod_type * mod_type 89 | | Modtype_withtype of mod_type * string list * Core.kind * Core.def_type 90 | 91 | and signature = 92 | sig_item list 93 | 94 | and sig_item = 95 | { sigitem_loc : Core.Location.t 96 | ; sigitem_data : sigitem_data 97 | } 98 | 99 | and sigitem_data = 100 | | Sig_value of Core.Names.ident * Core.val_type 101 | | Sig_type of Core.Names.ident * type_decl 102 | | Sig_module of Core.Names.ident * mod_type 103 | | Sig_modty of Core.Names.ident * mod_type 104 | 105 | val pp_modtype : Format.formatter -> mod_type -> unit 106 | 107 | val pp_signature : Format.formatter -> signature -> unit 108 | 109 | val pp_sig_item : Format.formatter -> sig_item -> unit 110 | 111 | type mod_term = 112 | { modterm_loc : Core.Location.t 113 | ; modterm_data : modterm_data 114 | } 115 | 116 | and modterm_data = 117 | | Mod_longident of Core.Names.longident 118 | | Mod_structure of structure 119 | | Mod_functor of Core.Names.ident * mod_type * mod_term 120 | | Mod_apply of mod_term * mod_term 121 | | Mod_constraint of mod_term * mod_type 122 | 123 | and structure = 124 | str_item list 125 | 126 | and str_item = 127 | { stritem_loc : Core.Location.t 128 | ; stritem_data : stritem_data 129 | } 130 | 131 | and stritem_data = 132 | | Str_value of Core.term 133 | | Str_type of Core.Names.ident * Core.kind * Core.def_type 134 | | Str_module of Core.Names.ident * mod_term 135 | | Str_modty of Core.Names.ident * mod_type 136 | | Str_modrec of (Core.Names.ident * mod_type * mod_term) list 137 | 138 | val pp_modterm : Format.formatter -> mod_term -> unit 139 | 140 | val pp_structure : Format.formatter -> structure -> unit 141 | end 142 | 143 | module Mod_Syntax_Raw (Core : CORE_SYNTAX_RAW) 144 | : MOD_SYNTAX_RAW with module Core = Core 145 | 146 | (**{2 Abstract syntax with concrete names} *) 147 | 148 | module type CORE_SYNTAX_CONCRETE = 149 | CORE_SYNTAX_RAW 150 | with type Names.ident = string 151 | and type Names.longident = String_names.longident 152 | 153 | module type MOD_SYNTAX_CONCRETE = 154 | MOD_SYNTAX_RAW 155 | with type Core.Names.ident = String_names.ident 156 | and type Core.Names.longident = String_names.longident 157 | 158 | (**{2 Abstract syntax with substitution} 159 | 160 | The {!CORE_SYNTAX} and {!MOD_SYNTAX} signatures constrain the 161 | corresponding [*_RAW] signatures so that the names are fixed to be 162 | {!Ident.t} and {!Path.t}, and add substitution operations that 163 | allow substitution of paths for identifiers. These are the 164 | representations used internally in the type checker. *) 165 | 166 | module type CORE_SYNTAX = sig 167 | include CORE_SYNTAX_RAW 168 | with type Names.ident = Ident.t 169 | and type Names.longident = Path.t 170 | 171 | val subst_valtype : Subst.t -> val_type -> val_type 172 | 173 | val subst_deftype : Subst.t -> def_type -> def_type 174 | 175 | val subst_kind : Subst.t -> kind -> kind 176 | end 177 | 178 | module type MOD_SYNTAX = sig 179 | module Core : CORE_SYNTAX 180 | 181 | include MOD_SYNTAX_RAW with module Core := Core 182 | 183 | val subst_typedecl : Subst.t -> type_decl -> type_decl 184 | 185 | val subst_modtype : Subst.t -> mod_type -> mod_type 186 | end 187 | 188 | module Mod_Syntax (Core_syntax : CORE_SYNTAX) 189 | : MOD_SYNTAX with module Core = Core_syntax 190 | -------------------------------------------------------------------------------- /modules/typing.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | module type TYPING_ENV = sig 4 | type val_type 5 | type def_type 6 | type kind 7 | 8 | type t 9 | 10 | (* FIXME: this is needed to handle mutually recursive values. Could 11 | there be another way? *) 12 | val add_value : string -> val_type -> t -> Ident.t * t 13 | 14 | val find_value : 15 | String_names.longident -> 16 | t -> (Path.t * val_type, Typing_environment.lookup_error) result 17 | 18 | val find_type : 19 | String_names.longident -> 20 | t -> (Path.t * kind, Typing_environment.lookup_error) result 21 | 22 | (* FIXME: this is used to get definitions of types during type 23 | equality checking. *) 24 | val lookup_type : Path.t -> t -> kind * def_type option 25 | end 26 | 27 | module type CORE_TYPING = sig 28 | module Src : CORE_SYNTAX_CONCRETE 29 | module Core : CORE_SYNTAX 30 | 31 | type error 32 | 33 | val pp_error : Format.formatter -> error -> unit 34 | 35 | module Checker (Env : TYPING_ENV 36 | with type val_type = Core.val_type 37 | and type def_type = Core.def_type 38 | and type kind = Core.kind) : 39 | sig 40 | val type_term : Env.t -> Src.term -> (Core.term * (Ident.t * Core.val_type) list, error) result 41 | 42 | val check_deftype : Env.t -> Core.kind -> Src.def_type -> (Core.def_type, error) result 43 | 44 | val check_valtype : Env.t -> Src.val_type -> (Core.val_type, error) result 45 | 46 | val check_kind : Env.t -> Src.kind -> (Core.kind, error) result 47 | 48 | val valtype_match : Env.t -> Core.val_type -> Core.val_type -> bool 49 | 50 | val rec_safe_valtype : Env.t -> Core.val_type -> bool 51 | 52 | val deftype_equiv : Env.t -> Core.kind -> Core.def_type -> Core.def_type -> bool 53 | 54 | val kind_match : Env.t -> Core.kind -> Core.kind -> bool 55 | 56 | val deftype_of_path : Path.t -> Core.kind -> Core.def_type 57 | end 58 | 59 | end 60 | 61 | module type MOD_TYPING = sig 62 | module Src : MOD_SYNTAX_CONCRETE 63 | 64 | module Tgt : MOD_SYNTAX 65 | 66 | module Env : Typing_environment.S with module Mod = Tgt 67 | 68 | type error 69 | 70 | val pp_error : Format.formatter -> error -> unit 71 | 72 | val type_modterm : 73 | Env.t -> Src.mod_term -> (Tgt.mod_term * Tgt.mod_type, error) result 74 | 75 | val type_structure : 76 | Env.t -> Src.structure -> (Tgt.structure * Tgt.signature, error) result 77 | end 78 | 79 | module Mod_typing 80 | (Src : MOD_SYNTAX_CONCRETE) 81 | (Tgt : MOD_SYNTAX with type Core.Location.t = Src.Core.Location.t) 82 | (CT : CORE_TYPING 83 | with module Src = Src.Core 84 | and module Core = Tgt.Core) 85 | : MOD_TYPING 86 | with module Src = Src 87 | and module Tgt = Tgt 88 | -------------------------------------------------------------------------------- /modules/typing_environment.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | type lookup_error = 4 | { path : String_names.longident 5 | ; subpath : String_names.longident 6 | ; reason : [ `not_found | `not_a_structure | `not_a_module 7 | | `not_a_value | `not_a_type | `not_a_module_type] 8 | } 9 | 10 | let pp_lookup_error pp { path; subpath; reason } = 11 | let reason = 12 | match reason with 13 | | `not_found -> "not found" 14 | | `not_a_structure -> "not a structure" 15 | | `not_a_module -> "not a module" 16 | | `not_a_value -> "not a value" (* FIXME: 'value' doesn't always make sense *) 17 | | `not_a_type -> "not a type" 18 | | `not_a_module_type -> "not a module type" 19 | in 20 | if path = subpath then 21 | Format.fprintf pp "The name %a was %s" 22 | String_names.pp_longident path 23 | reason 24 | else 25 | Format.fprintf pp "While looking up %a, the sub path %a was %s" 26 | String_names.pp_longident path 27 | String_names.pp_longident subpath 28 | reason 29 | 30 | module type S = sig 31 | module Mod : MOD_SYNTAX 32 | 33 | type t 34 | 35 | val empty : t 36 | 37 | 38 | val add_value : String_names.ident -> Mod.Core.val_type -> t -> Ident.t * t 39 | 40 | val add_type : String_names.ident -> Mod.type_decl -> t -> Ident.t * t 41 | 42 | val add_module : String_names.ident -> Mod.mod_type -> t -> Ident.t * t 43 | 44 | val add_modty : String_names.ident -> Mod.mod_type -> t -> Ident.t * t 45 | 46 | val add_signature : Mod.signature -> t -> t 47 | 48 | 49 | val add_module_by_ident : Ident.t -> Mod.mod_type -> t -> t 50 | 51 | val bind_value : Ident.t -> Mod.Core.val_type -> t -> t 52 | 53 | val bind_module : Ident.t -> Mod.mod_type -> t -> t 54 | 55 | 56 | val find_value : String_names.longident -> t -> (Path.t * Mod.Core.val_type, lookup_error) result 57 | 58 | val find_type : String_names.longident -> t -> (Path.t * Mod.Core.kind, lookup_error) result 59 | 60 | val find_module : String_names.longident -> t -> (Path.t * Mod.mod_type, lookup_error) result 61 | 62 | val find_modtype : String_names.longident -> t -> (Path.t * Mod.mod_type, lookup_error) result 63 | 64 | 65 | val lookup_modtype : Path.t -> t -> Mod.mod_type 66 | 67 | val lookup_type : Path.t -> t -> Mod.Core.kind * Mod.Core.def_type option 68 | end 69 | 70 | module Make (Mod_syntax : MOD_SYNTAX) : S with module Mod = Mod_syntax = 71 | struct 72 | module Mod = Mod_syntax 73 | 74 | module NameMap = Map.Make (String) 75 | 76 | type binding = 77 | | Value of Mod.Core.val_type 78 | | Type of Mod.type_decl 79 | | Module of Mod.mod_type 80 | | Modty of Mod.mod_type 81 | 82 | 83 | type t = 84 | { bindings : binding Ident.Table.t 85 | ; names : Ident.t NameMap.t 86 | } 87 | 88 | let empty = 89 | { bindings = Ident.Table.empty 90 | ; names = NameMap.empty 91 | } 92 | 93 | let add id binding {bindings; names} = 94 | let ident = Ident.create id in 95 | ident, 96 | { bindings = Ident.Table.add ident binding bindings 97 | ; names = NameMap.add id ident names 98 | } 99 | 100 | let add_value id vty = add id (Value vty) 101 | 102 | let bind_value id vty {bindings; names} = 103 | { bindings = Ident.Table.add id (Value vty) bindings 104 | ; names = NameMap.add (Ident.name id) id names 105 | } 106 | 107 | (* FIXME: why is this different to add_module_by_ident? *) 108 | let bind_module id vty {bindings; names} = 109 | { bindings = Ident.Table.add id (Module vty) bindings 110 | ; names = NameMap.add (Ident.name id) id names 111 | } 112 | 113 | let add_type id decl = add id (Type decl) 114 | 115 | let add_module id mty = add id (Module mty) 116 | 117 | let add_modty id mty = add id (Modty mty) 118 | 119 | let add_by_ident ident binding env = 120 | (* FIXME: why doesn't this update the names field? *) 121 | {env with bindings = Ident.Table.add ident binding env.bindings} 122 | 123 | let add_module_by_ident ident mty env = 124 | add_by_ident ident (Module mty) env 125 | 126 | let add_sigitem item env = 127 | match item.Mod.sigitem_data with 128 | | Mod.Sig_value (id, vty) -> add_by_ident id (Value vty) env 129 | | Mod.Sig_type (id, decl) -> add_by_ident id (Type decl) env 130 | | Mod.Sig_module (id, mty) -> add_by_ident id (Module mty) env 131 | | Mod.Sig_modty (id, mty) -> add_by_ident id (Modty mty) env 132 | 133 | let add_signature = 134 | List.fold_right add_sigitem 135 | 136 | 137 | let rec lid_of_path = function 138 | | Path.Pident id -> String_names.Lid_ident (Ident.name id) 139 | | Path.Pdot (p, f) -> String_names.Lid_dot (lid_of_path p, f) 140 | 141 | 142 | let rec transl_path names = function 143 | | String_names.Lid_ident ident as path -> 144 | (match NameMap.find ident names with 145 | | exception Not_found -> Error (path, `not_found) 146 | | ident -> Ok (Path.Pident ident)) 147 | | String_names.Lid_dot (p, f) -> 148 | (match transl_path names p with 149 | | Error _ as err -> err 150 | | Ok p -> Ok (Path.Pdot (p, f))) 151 | 152 | let rec find path env = match path with 153 | | Path.Pident id -> 154 | (match Ident.Table.find id env with 155 | | None -> 156 | failwith "internal error: path unresolvable" 157 | | Some binding -> 158 | Ok binding) 159 | | Path.Pdot (root, field) -> 160 | match find root env with 161 | | Ok (Module mty) -> 162 | let rec resolve = function 163 | | Mod.{modtype_data=Modtype_signature sg} -> 164 | find_field root field Subst.identity sg 165 | | Mod.{modtype_data=Modtype_longident lid} -> 166 | resolve (lookup_modtype lid env) 167 | | _ -> 168 | Error (lid_of_path root, `not_a_structure) 169 | in 170 | resolve mty 171 | | Ok _ -> 172 | Error (lid_of_path root, `not_a_module) 173 | | Error err -> 174 | Error err 175 | 176 | and find_field p field sub = function 177 | | [] -> 178 | Error (lid_of_path (Path.Pdot (p, field)), `not_found) 179 | | Mod.{sigitem_data=Sig_value (id, vty)} :: rem -> 180 | if Ident.name id = field 181 | then Ok (Value (Mod.Core.subst_valtype sub vty)) 182 | else find_field p field sub rem 183 | | Mod.{sigitem_data=Sig_type (id, decl)} :: rem -> 184 | if Ident.name id = field 185 | then Ok (Type (Mod.subst_typedecl sub decl)) 186 | else 187 | find_field p field (Subst.add id (Path.Pdot (p, Ident.name id)) sub) rem 188 | | Mod.{sigitem_data=Sig_module (id, mty)} :: rem -> 189 | if Ident.name id = field 190 | then Ok (Module (Mod.subst_modtype sub mty)) 191 | else 192 | find_field p field (Subst.add id (Path.Pdot (p, Ident.name id)) sub) rem 193 | | Mod.{sigitem_data=Sig_modty (id, mty)} :: rem -> 194 | if Ident.name id = field 195 | then Ok (Modty (Mod.subst_modtype sub mty)) 196 | else 197 | find_field p field (Subst.add id (Path.Pdot (p, Ident.name id)) sub) rem 198 | 199 | and lookup_modtype path env = 200 | match find path env with 201 | | Ok (Modty mty) -> mty 202 | | _ -> failwith "internal: module type lookup failed" 203 | 204 | let lookup_modtype path {bindings} = 205 | lookup_modtype path bindings 206 | 207 | let lookup_type path {bindings} = 208 | match find path bindings with 209 | | Ok (Type ty) -> ty.kind, ty.manifest 210 | | _ -> failwith "internal: type lookup failed" 211 | 212 | let (>>=) c f = match c with Ok a -> f a | Error e -> Error e 213 | 214 | let reword_lookup_error ~target_path result = 215 | match result with 216 | | Ok value -> 217 | Ok value 218 | | Error (subpath, reason) -> 219 | Error { path = target_path; subpath; reason } 220 | 221 | let find_value lid {bindings;names} = 222 | reword_lookup_error ~target_path:lid begin 223 | transl_path names lid >>= fun path -> 224 | find path bindings >>= function 225 | | Value vty -> Ok (path, vty) 226 | | _ -> Error (lid, `not_a_value) 227 | end 228 | 229 | let find_type lid {bindings;names} = 230 | reword_lookup_error ~target_path:lid begin 231 | transl_path names lid >>= fun path -> 232 | find path bindings >>= function 233 | | Type decl -> Ok (path, decl.kind) 234 | | _ -> Error (lid, `not_a_type) 235 | end 236 | 237 | let find_module lid {bindings;names} = 238 | reword_lookup_error ~target_path:lid begin 239 | transl_path names lid >>= fun path -> 240 | find path bindings >>= function 241 | | Module mty -> Ok (path, mty) 242 | | _ -> Error (lid, `not_a_module) 243 | end 244 | 245 | let find_modtype lid {bindings;names} = 246 | reword_lookup_error ~target_path:lid begin 247 | transl_path names lid >>= fun path -> 248 | find path bindings >>= function 249 | | Modty mty -> Ok (path, mty) 250 | | _ -> Error (lid, `not_a_module_type) 251 | end 252 | end 253 | -------------------------------------------------------------------------------- /modules/typing_environment.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | 3 | type lookup_error = 4 | { path : String_names.longident 5 | ; subpath : String_names.longident 6 | ; reason : [ `not_found | `not_a_structure | `not_a_module 7 | | `not_a_value | `not_a_type | `not_a_module_type] 8 | } 9 | 10 | val pp_lookup_error : Format.formatter -> lookup_error -> unit 11 | 12 | module type S = sig 13 | module Mod : MOD_SYNTAX 14 | 15 | type t 16 | 17 | val empty : t 18 | 19 | 20 | val add_value : String_names.ident -> Mod.Core.val_type -> t -> Ident.t * t 21 | 22 | val add_type : String_names.ident -> Mod.type_decl -> t -> Ident.t * t 23 | 24 | val add_module : String_names.ident -> Mod.mod_type -> t -> Ident.t * t 25 | 26 | val add_modty : String_names.ident -> Mod.mod_type -> t -> Ident.t * t 27 | 28 | 29 | val add_signature : Mod.signature -> t -> t 30 | 31 | val add_module_by_ident : Ident.t -> Mod.mod_type -> t -> t 32 | 33 | val bind_value : Ident.t -> Mod.Core.val_type -> t -> t 34 | 35 | val bind_module : Ident.t -> Mod.mod_type -> t -> t 36 | 37 | 38 | val find_value : String_names.longident -> t -> (Path.t * Mod.Core.val_type, lookup_error) result 39 | 40 | val find_type : String_names.longident -> t -> (Path.t * Mod.Core.kind, lookup_error) result 41 | 42 | val find_module : String_names.longident -> t -> (Path.t * Mod.mod_type, lookup_error) result 43 | 44 | val find_modtype : String_names.longident -> t -> (Path.t * Mod.mod_type, lookup_error) result 45 | 46 | 47 | val lookup_modtype : Path.t -> t -> Mod.mod_type 48 | 49 | val lookup_type : Path.t -> t -> Mod.Core.kind * Mod.Core.def_type option 50 | end 51 | 52 | module Make (Mod_syntax : MOD_SYNTAX) : S with module Mod = Mod_syntax 53 | -------------------------------------------------------------------------------- /modulog-bin.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "modulog-bin" 3 | version: "0.3" 4 | maintainer: "Robert Atkey " 5 | authors: "Robert Atkey " 6 | license: "MIT" 7 | build: [["jbuilder" "build" "-p" name "-j" jobs "@install"]] 8 | available: [ ocaml-version >= "4.04.0" ] 9 | -------------------------------------------------------------------------------- /modulog-bin/driver.ml: -------------------------------------------------------------------------------- 1 | open Modulog.Std 2 | 3 | let (>>=) x f = match x with 4 | | Ok a -> f a 5 | | Error e -> Error e 6 | let (>>!) x f = match x with 7 | | Ok a -> Ok a 8 | | Error e -> f e 9 | 10 | let report_parse_error (pos, message, lexeme) = 11 | Format.printf 12 | "@[Parse error at %a:@ @[%s:@ %a@]@]\n" 13 | Modulog.Location.pp pos 14 | (match lexeme with 15 | | "" -> "At the end of the input" 16 | | lexeme -> Printf.sprintf "On the input '%s'" lexeme) 17 | Fmt.text message; 18 | Error () 19 | 20 | let report_check_error err = 21 | Format.printf 22 | "@[%a@]\n" 23 | Modulog.Checker.pp_error err; 24 | Error () 25 | 26 | let parse_and_check filename = 27 | read_structure_from_file filename >>! report_parse_error 28 | >>= fun structure -> 29 | Modulog.Checker.type_structure structure >>! report_check_error 30 | 31 | let typecheck filename = 32 | parse_and_check filename >>= fun (str, sg) -> 33 | Format.printf 34 | "@[%a@]\n" 35 | Modulog.Checked_syntax.Mod.pp_signature sg; 36 | Ok () 37 | 38 | let relmachine filename with_indexes = 39 | parse_and_check filename >>= fun (str, sg) -> 40 | let rules = Modulog.To_rules.from_structure str in 41 | let code = Relation_machine.Of_rules.translate rules in 42 | Format.printf 43 | "@[%a@]\n%!" 44 | Relation_machine.Syntax.pp_program code; 45 | if with_indexes then begin 46 | let indexes = Relation_machine.Indexes.indexes code in 47 | Format.printf 48 | "\n@[%a@]\n%!" 49 | Relation_machine.Indexes.pp_all_orderings indexes 50 | end; 51 | Ok () 52 | 53 | let gen_c filename = 54 | parse_and_check filename >>= fun (str, sg) -> 55 | let rules = Modulog.To_rules.from_structure str in 56 | let code = Relation_machine.Of_rules.translate rules in 57 | Relation_machine.Codegen.translate code; 58 | Ok () 59 | 60 | let compile filename outname = 61 | (* FIXME: check that filename ends with '.mlog' *) 62 | let outname = 63 | (* FIXME: some kind of validation here *) 64 | match outname with 65 | | None -> 66 | if Filename.check_suffix filename ".mlog" then 67 | Filename.chop_extension filename 68 | else 69 | filename ^ ".exe" 70 | | Some outname -> 71 | outname 72 | in 73 | parse_and_check filename >>= fun (str, sg) -> 74 | let rules = Modulog.To_rules.from_structure str in 75 | let code = Relation_machine.Of_rules.translate rules in 76 | Relation_machine.Codegen.compile outname code; 77 | Ok () 78 | 79 | 80 | let rules filename = 81 | parse_and_check filename >>= fun (str, sg) -> 82 | let rules = Modulog.To_rules.from_structure str in 83 | Format.printf 84 | "@[%a@]\n" 85 | Datalog.Ruleset.pp rules; 86 | Ok () 87 | 88 | let rules_graph filename = 89 | parse_and_check filename >>= fun (str, sg) -> 90 | let rules = Modulog.To_rules.from_structure str in 91 | Format.printf 92 | "@[%a@]\n" 93 | Datalog.Graphviz.dot_of_ruleset rules; 94 | Ok () 95 | 96 | let exec filename = 97 | parse_and_check filename >>= fun (str, sg) -> 98 | let rules = Modulog.To_rules.from_structure str in 99 | let code = Relation_machine.Of_rules.translate rules in 100 | let env = Relation_machine.Interpreter.eval code in 101 | Format.printf 102 | "@[%a@]\n" 103 | Relation_machine.Interpreter.Env.pp env; 104 | Ok () 105 | 106 | (**********************************************************************) 107 | (* The command line interface *) 108 | 109 | open Cmdliner 110 | 111 | let filename_arg = 112 | Arg.(required 113 | & pos 0 (some string) None 114 | & info [] 115 | ~docv:"FILENAME" 116 | ~doc:"Name of modular datalog file to process") 117 | 118 | let with_indexes_opt = 119 | let doc = "Whether to print computed index information" in 120 | Arg.(value & flag & info ["i";"with-indexes"] ~doc) 121 | 122 | let output_file_arg = 123 | let doc = "Output filename" in 124 | Arg.(value & opt (some string) None & info ["o";"output"] ~doc) 125 | 126 | let typecheck_cmd = 127 | let doc = "Typecheck a Modular Datalog program and print the signature" in 128 | Term.(const typecheck $ filename_arg), 129 | Term.info "typecheck" ~doc ~exits:Term.default_exits 130 | 131 | let relmachine_cmd = 132 | let doc = "Compile a Modular Datalog program to the RelMachine" in 133 | Term.(const relmachine $ filename_arg $ with_indexes_opt), 134 | Term.info "relmachine" ~doc ~exits:Term.default_exits 135 | 136 | let gen_c_cmd = 137 | let doc = "Compile a Modular Datalog program to C" in 138 | Term.(const gen_c $ filename_arg), 139 | Term.info "gen_c" ~doc ~exits:Term.default_exits 140 | 141 | let compile_cmd = 142 | let doc = "Compile a Modular Datalog program to an executable via C" in 143 | Term.(const compile $ filename_arg $ output_file_arg), 144 | Term.info "compile" ~doc ~exits:Term.default_exits 145 | 146 | let rules_cmd = 147 | let doc = "Compile a Modular Datalog program to flat datalog rules" in 148 | Term.(const rules $ filename_arg), 149 | Term.info "rules" ~doc ~exits:Term.default_exits 150 | 151 | let rules_graph_cmd = 152 | let doc = "Compile a Modular Datalog program to a graph of datalog rules" in 153 | Term.(const rules_graph $ filename_arg), 154 | Term.info "rules-graph" ~doc ~exits:Term.default_exits 155 | 156 | let exec_cmd = 157 | let doc = "Execute a Modular Datalog program" in 158 | Term.(const exec $ filename_arg), 159 | Term.info "exec" ~doc ~exits:Term.default_exits 160 | 161 | let default_cmd = 162 | let doc = "a Modular Datalog compiler" in 163 | let sdocs = Manpage.s_common_options in 164 | let exits = Term.default_exits in 165 | (*let man = help_secs in*) 166 | Term.(ret (const (`Help (`Pager, None)))), 167 | Term.info "modulog" ~version:"v1.0.0" ~doc ~sdocs ~exits (*~man*) 168 | 169 | let () = 170 | Term.(exit (eval_choice default_cmd [ typecheck_cmd 171 | ; relmachine_cmd 172 | ; gen_c_cmd 173 | ; rules_cmd 174 | ; rules_graph_cmd 175 | ; exec_cmd 176 | ; compile_cmd ])) 177 | -------------------------------------------------------------------------------- /modulog-bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (public_name modulog) 4 | (package modulog-bin) 5 | (flags (:standard -w -49-44-9-27)) 6 | (libraries cmdliner datalog modulog relation_machine)) 7 | -------------------------------------------------------------------------------- /modulog.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "modulog" 3 | version: "0.3" 4 | maintainer: "Robert Atkey " 5 | authors: "Robert Atkey " 6 | license: "MIT" 7 | build: [["jbuilder" "build" "-p" name "-j" jobs "@install"]] 8 | available: [ ocaml-version >= "4.04.0" ] 9 | -------------------------------------------------------------------------------- /modulog/checked_syntax.ml: -------------------------------------------------------------------------------- 1 | module Core = struct 2 | include Core_syntax.Make (Modules.Syntax.Bound_names) 3 | 4 | let rec subst_deftype sub domtype = 5 | { domtype with 6 | domtype_data = 7 | match domtype.domtype_data with 8 | | Type_int -> Type_int 9 | | Type_typename lid -> Type_typename (Modules.Subst.path sub lid) 10 | | Type_tuple tys -> Type_tuple (List.map (subst_deftype sub) tys) 11 | | Type_enum syms -> Type_enum syms 12 | } 13 | 14 | 15 | let subst_valtype sub = function 16 | | Predicate predty -> 17 | Predicate 18 | { predty with 19 | predty_data = List.map (subst_deftype sub) predty.predty_data 20 | } 21 | 22 | | Value domty -> 23 | Value (subst_deftype sub domty) 24 | 25 | let subst_kind sub () = () 26 | end 27 | 28 | module Mod = Modules.Syntax.Mod_Syntax (Core) 29 | -------------------------------------------------------------------------------- /modulog/checked_syntax.mli: -------------------------------------------------------------------------------- 1 | module Core : sig 2 | include module type of (Core_syntax.Make (Modules.Syntax.Bound_names)) 3 | 4 | include Modules.Syntax.CORE_SYNTAX 5 | with type term := term 6 | and type val_type := val_type 7 | and type def_type := def_type 8 | and type kind := kind 9 | and module Location := Location 10 | and module Names := Names 11 | end 12 | 13 | module Mod : Modules.Syntax.MOD_SYNTAX 14 | with type Core.Location.t = Location.t 15 | and type Core.term = Core.term 16 | and type Core.val_type = Core.val_type 17 | and type Core.def_type = Core.def_type 18 | and type Core.kind = Core.kind 19 | -------------------------------------------------------------------------------- /modulog/checker.mli: -------------------------------------------------------------------------------- 1 | type error 2 | 3 | val type_structure : 4 | Syntax.Mod.structure -> 5 | (Checked_syntax.Mod.structure * Checked_syntax.Mod.signature, error) result 6 | 7 | val pp_error : Format.formatter -> error -> unit 8 | -------------------------------------------------------------------------------- /modulog/core_syntax.ml: -------------------------------------------------------------------------------- 1 | module Make (Names : Modules.Syntax.NAMES) = struct 2 | 3 | module Location = Location 4 | 5 | module Names = Names 6 | 7 | open Names 8 | 9 | type expr = 10 | { expr_loc : Location.t 11 | ; expr_data : expr_data 12 | } 13 | 14 | and expr_data = 15 | | Expr_var of string 16 | | Expr_lid of longident 17 | | Expr_literal of int32 18 | | Expr_underscore 19 | | Expr_tuple of expr list 20 | | Expr_enum of string 21 | 22 | type domaintype = 23 | { domtype_loc : Location.t 24 | ; domtype_data : domaintype_data 25 | } 26 | 27 | and domaintype_data = 28 | | Type_int 29 | | Type_typename of longident 30 | | Type_tuple of domaintype list 31 | | Type_enum of string list 32 | 33 | let pp_enum_sym fmt sym = 34 | Format.fprintf fmt "`%s" sym 35 | 36 | let rec pp_domaintype pp = function 37 | | { domtype_data = Type_int } -> 38 | Format.pp_print_string pp "int" 39 | | { domtype_data = Type_typename lid } -> 40 | Names.pp_longident pp lid 41 | | { domtype_data = Type_tuple tys } -> 42 | Format.fprintf pp "(@[%a@])" pp_domaintypes tys 43 | | { domtype_data = Type_enum syms } -> 44 | Format.fprintf pp "@[<2>[ %a ]@]" 45 | (Fmt.list ~sep:(Fmt.always " |@ ") pp_enum_sym) syms 46 | 47 | and pp_domaintypes pp tys = 48 | Fmt.(list ~sep:(always " *@ ") pp_domaintype) pp tys 49 | 50 | type predicate_type = 51 | { predty_loc : Location.t 52 | ; predty_data : domaintype list 53 | } 54 | 55 | type atom = 56 | { atom_loc : Location.t 57 | ; atom_data : atom_data 58 | } 59 | 60 | and atom_data = 61 | | Atom_predicate of { pred : longident 62 | ; args : expr list 63 | } 64 | (* FIXME: equality, inequality, negation *) 65 | 66 | type rule = 67 | { rule_loc : Location.t 68 | ; rule_pred : ident 69 | ; rule_args : expr list 70 | ; rule_rhs : atom list 71 | } 72 | 73 | type declaration = 74 | { decl_loc : Location.t 75 | ; decl_name : ident 76 | ; decl_type : predicate_type 77 | ; decl_rules : rule list 78 | } 79 | 80 | type kind = unit 81 | 82 | type val_type = 83 | | Predicate of predicate_type 84 | | Value of domaintype 85 | 86 | type def_type = domaintype 87 | 88 | type constant_def = 89 | { const_loc : Location.t 90 | ; const_name : Names.ident 91 | ; const_type : domaintype 92 | ; const_expr : expr 93 | } 94 | 95 | type external_decl = 96 | { external_loc : Location.t 97 | ; external_name : Names.ident 98 | ; external_type : predicate_type 99 | } 100 | 101 | type output_decl = 102 | { output_loc : Location.t 103 | ; output_rel : Names.longident 104 | ; output_filename : string 105 | } 106 | 107 | type term = 108 | | External of external_decl 109 | | PredicateDefs of declaration list 110 | | ConstantDef of constant_def 111 | | Output of output_decl 112 | 113 | let pp_kind = 114 | None 115 | 116 | let pp_def_decl fmt = function 117 | | (id, (), Some domty) -> 118 | Format.fprintf fmt "type %a = %a" 119 | Names.pp_ident id 120 | pp_domaintype domty 121 | | (id, (), None) -> 122 | Format.fprintf fmt "type %a" 123 | Names.pp_ident id 124 | 125 | let pp_val_decl fmt = function 126 | | (id, Predicate {predty_data=tys}) -> 127 | Format.fprintf fmt "pred %a : @[%a@]" 128 | Names.pp_ident id 129 | pp_domaintypes tys 130 | | (id, Value domty) -> 131 | Format.fprintf fmt "constant %a : %a" 132 | Names.pp_ident id 133 | pp_domaintype domty 134 | 135 | let rec pp_expr fmt = function 136 | | {expr_data = Expr_var nm} -> Format.fprintf fmt "?%s" nm 137 | | {expr_data = Expr_literal i} -> Format.fprintf fmt "%ld" i 138 | | {expr_data = Expr_underscore} -> Format.pp_print_string fmt "_" 139 | | {expr_data = Expr_tuple es} -> Format.fprintf fmt "(%a)" pp_exprs es 140 | | {expr_data = Expr_enum sym} -> pp_enum_sym fmt sym 141 | | {expr_data = Expr_lid lid} -> Names.pp_longident fmt lid 142 | 143 | and pp_exprs pp = 144 | Fmt.(list ~sep:(always ", ") pp_expr) pp 145 | 146 | let pp_atom pp = function 147 | | {atom_data = Atom_predicate {pred; args}} -> 148 | Format.fprintf pp "%a(%a)" 149 | Names.pp_longident pred 150 | pp_exprs args 151 | 152 | let pp_rule pp {rule_pred; rule_args; rule_rhs} = 153 | Format.pp_open_hovbox pp 4; 154 | Format.fprintf pp "%a(%a)" 155 | Names.pp_ident rule_pred 156 | pp_exprs rule_args; 157 | (match rule_rhs with 158 | | [] -> () 159 | | atoms -> 160 | Format.fprintf pp " :- %a" 161 | Fmt.(list ~sep:(always ",@ ") pp_atom) atoms); 162 | Format.pp_close_box pp () 163 | 164 | let pp_decl pp {decl_name; decl_type; decl_rules} = 165 | Format.fprintf pp "@[%a : @[%a@]@,%a@]" 166 | Names.pp_ident decl_name 167 | pp_domaintypes decl_type.predty_data 168 | Fmt.(list ~sep:(always "@ ") pp_rule) decl_rules 169 | 170 | let pp_pred_defs pp = function 171 | | [] -> () 172 | | decl :: decls -> 173 | Format.pp_open_vbox pp 0; 174 | Format.fprintf pp "define %a" pp_decl decl; 175 | List.iter (Format.fprintf pp "@ @,and %a" pp_decl) decls; 176 | Format.pp_close_box pp () 177 | 178 | let pp_constant_def fmt { const_name; const_type; const_expr } = 179 | Format.fprintf fmt 180 | "constant %a : %a = %a" 181 | Names.pp_ident const_name 182 | pp_domaintype const_type 183 | pp_expr const_expr 184 | 185 | let pp_ext_decl fmt { external_name; external_type } = 186 | Format.fprintf fmt "external %a : @[%a@]@," 187 | Names.pp_ident external_name 188 | pp_domaintypes external_type.predty_data 189 | 190 | let pp_output_decl fmt { output_rel; output_filename } = 191 | (* FIXME: is this the right escaping strategy? *) 192 | Format.fprintf fmt "output %a %S@," 193 | Names.pp_longident output_rel 194 | output_filename 195 | 196 | let pp_term fmt = function 197 | | External ext_decl -> pp_ext_decl fmt ext_decl 198 | | PredicateDefs defs -> pp_pred_defs fmt defs 199 | | ConstantDef c -> pp_constant_def fmt c 200 | | Output decl -> pp_output_decl fmt decl 201 | 202 | let pp_type_constraint fmt (path, (), dty) = 203 | Format.fprintf fmt "%a = %a" 204 | Modules.Syntax.pp_path path 205 | pp_domaintype dty 206 | end 207 | -------------------------------------------------------------------------------- /modulog/datalog_grammar.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open! Syntax.Core 3 | open Syntax.Mod 4 | %} 5 | 6 | %token COMMA 7 | %token COLON_DASH 8 | %token COLON 9 | %token STAR DOT ARROW EQUALS BAR UNDERSCORE PRED OUTPUT 10 | %token MODULE TYPE STRUCT SIG END FUNCTOR INT AND DEFINE CONSTANT WITH EXTERNAL REC 11 | %token LPAREN RPAREN LBRACE RBRACE 12 | %token INT_LITERAL 13 | %token IDENT ENUM_IDENT MV_IDENT STRINGLIT 14 | %token EOF 15 | %token UNKNOWN 16 | 17 | %start program 18 | 19 | %% 20 | 21 | program: 22 | | d=list(str_item); EOF 23 | { d } 24 | 25 | %inline 26 | in_parens(X): 27 | | LPAREN; x=X; RPAREN 28 | { x } 29 | 30 | /* Long identifiers */ 31 | 32 | %public 33 | longident: 34 | | id=IDENT 35 | { Lid_ident id } 36 | | lid=longident; DOT; f=IDENT 37 | { Lid_dot (lid, f) } 38 | 39 | /* Datalog rules */ 40 | 41 | expr: 42 | | v=MV_IDENT 43 | { { expr_loc = Location.mk $startpos $endpos 44 | ; expr_data = Expr_var v } } 45 | | lid=longident 46 | { { expr_loc = Location.mk $startpos $endpos 47 | ; expr_data = Expr_lid lid } } 48 | | i=INT_LITERAL 49 | { { expr_loc = Location.mk $startpos $endpos 50 | ; expr_data = Expr_literal i } } 51 | | UNDERSCORE 52 | { { expr_loc = Location.mk $startpos $endpos 53 | ; expr_data = Expr_underscore } } 54 | | es=in_parens(separated_list(COMMA,expr)) 55 | { { expr_loc = Location.mk $startpos $endpos 56 | ; expr_data = Expr_tuple es } } 57 | | sym=ENUM_IDENT 58 | { { expr_loc = Location.mk $startpos $endpos 59 | ; expr_data = Expr_enum sym } } 60 | 61 | atom: 62 | | pred=longident; args=in_parens(separated_list(COMMA,expr)) 63 | { { atom_loc = Location.mk $startpos $endpos 64 | ; atom_data = Atom_predicate { pred; args } } } 65 | 66 | decl_head: 67 | | name=IDENT; exprs=in_parens(separated_list(COMMA,expr)) 68 | { (name, exprs) } 69 | 70 | rule: 71 | | head=decl_head; COLON_DASH; rhs=separated_nonempty_list(COMMA, atom) 72 | { { rule_loc = Location.mk $startpos $endpos 73 | ; rule_pred = fst head 74 | ; rule_args = snd head 75 | ; rule_rhs = rhs } } 76 | | head=decl_head 77 | { { rule_loc = Location.mk $startpos $endpos 78 | ; rule_pred = fst head 79 | ; rule_args = snd head 80 | ; rule_rhs = [] } } 81 | 82 | pred_decl: 83 | | name=IDENT; COLON; types=predicate_type; rules=list(rule) 84 | { { decl_loc = Location.mk $startpos $endpos 85 | ; decl_name = name 86 | ; decl_type = types 87 | ; decl_rules = rules } } 88 | 89 | %public 90 | str_value: 91 | | DEFINE; d=pred_decl; ds=list(AND; d=pred_decl {d}) 92 | { PredicateDefs (d :: ds) } 93 | | CONSTANT; name=IDENT; COLON; ty=domain_type; EQUALS; e=expr 94 | { ConstantDef { const_loc = Location.mk $startpos $endpos 95 | ; const_name = name 96 | ; const_type = ty 97 | ; const_expr = e 98 | } } 99 | | EXTERNAL; name=IDENT; COLON; types=predicate_type 100 | { External { external_loc = Location.mk $startpos $endpos 101 | ; external_name = name 102 | ; external_type = types 103 | } } 104 | | OUTPUT; name=longident; filename=STRINGLIT 105 | { Output { output_loc = Location.mk $startpos $endpos 106 | ; output_rel = name 107 | ; output_filename = filename 108 | } } 109 | 110 | /* types */ 111 | 112 | domain_type: 113 | | dtys=separated_nonempty_list(STAR, domain_type0) 114 | { match dtys with 115 | | [] -> assert false 116 | | [dty] -> dty 117 | | dtys -> { domtype_loc = Location.mk $startpos $endpos 118 | ; domtype_data = Type_tuple dtys } } 119 | 120 | domain_type0: 121 | | INT 122 | { { domtype_loc = Location.mk $startpos $endpos 123 | ; domtype_data = Type_int } } 124 | | lid=longident 125 | { { domtype_loc = Location.mk $startpos $endpos 126 | ; domtype_data = Type_typename lid } } 127 | | LPAREN; RPAREN 128 | { { domtype_loc = Location.mk $startpos $endpos 129 | ; domtype_data = Type_tuple [] } } 130 | | LPAREN; dty=domain_type; RPAREN 131 | { dty } 132 | | LBRACE; syms=separated_list(BAR, ENUM_IDENT); RBRACE 133 | { { domtype_loc = Location.mk $startpos $endpos 134 | ; domtype_data = Type_enum syms } } 135 | 136 | predicate_type: 137 | | dtys=separated_nonempty_list(STAR, domain_type0) 138 | { { predty_loc = Location.mk $startpos $endpos 139 | ; predty_data = dtys } } 140 | 141 | %public 142 | str_type(NAME): 143 | | TYPE; id=NAME; EQUALS; ty=domain_type 144 | { (id, (), ty) } 145 | 146 | %public 147 | sig_value: 148 | | PRED; id=IDENT; COLON; ty=predicate_type 149 | { (id, Predicate ty) } 150 | | CONSTANT; id=IDENT; COLON; ty=domain_type 151 | { (id, Value ty) } 152 | 153 | %public 154 | sig_type: 155 | | TYPE; id=IDENT 156 | { (id, (), None) } 157 | | TYPE; id=IDENT; EQUALS; ty=domain_type 158 | { (id, (), Some ty ) } 159 | -------------------------------------------------------------------------------- /modulog/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name modulog) 3 | (public_name modulog) 4 | (libraries modules datalog fmt menhirLib) 5 | (flags (:standard -w -49+44-9-27 -safe-string))) 6 | 7 | (rule 8 | (targets parser.ml parser.mli) 9 | (deps datalog_grammar.mly parser.messages) 10 | (action (chdir %{workspace_root} 11 | (run %{bin:menhir} --table 12 | --base modulog/parser 13 | %{dep:datalog_grammar.mly} 14 | %{lib:modules:modules_grammar.mly})))) 15 | 16 | 17 | (rule 18 | (targets parser_messages.ml) 19 | (deps datalog_grammar.mly parser.messages) 20 | (action (with-stdout-to parser_messages.ml 21 | (run %{bin:menhir} 22 | --table 23 | --base modulog/parser 24 | %{dep:datalog_grammar.mly} 25 | %{lib:modules:modules_grammar.mly} 26 | --compile-errors %{dep:parser.messages})))) 27 | 28 | 29 | (ocamllex 30 | lexer) 31 | -------------------------------------------------------------------------------- /modulog/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | } 4 | 5 | let ident = ['A'-'Z''a'-'z']['A'-'Z''a'-'z''_''0'-'9''\'']* 6 | 7 | rule token = parse 8 | [' ''\t'] { token lexbuf } 9 | | '\n' { Lexing.new_line lexbuf; token lexbuf } 10 | | "(*" { comment lexbuf; token lexbuf } 11 | | ',' { COMMA } 12 | | ":-" { COLON_DASH } 13 | | ":" { COLON } 14 | | "*" { STAR } 15 | | "." { DOT } 16 | | "->" { ARROW } 17 | | "=" { EQUALS } 18 | | "external" { EXTERNAL } 19 | | "module" { MODULE } 20 | | "type" { TYPE } 21 | | "struct" { STRUCT } 22 | | "sig" { SIG } 23 | | "end" { END } 24 | | "functor" { FUNCTOR } 25 | | "int" { INT } 26 | | "and" { AND } 27 | | "define" { DEFINE } 28 | | "constant" { CONSTANT } 29 | | "with" { WITH } 30 | | "rec" { REC } 31 | | "pred" { PRED } 32 | | "output" { OUTPUT } 33 | | '(' { LPAREN } 34 | | ')' { RPAREN } 35 | | '{' { LBRACE } 36 | | '}' { RBRACE } 37 | | '|' { BAR } 38 | | ['0'-'9']+ as x { INT_LITERAL (Int32.of_string x) } 39 | | ident as x { IDENT x } 40 | | '`'(ident as x) { ENUM_IDENT x } 41 | | '?'(ident as x) { MV_IDENT x } 42 | | '\"'([^'\"']* as s)'\"' { STRINGLIT s } (* FIXME: handle escaping *) 43 | | '_' { UNDERSCORE } 44 | | _ { UNKNOWN } 45 | | eof { EOF } 46 | 47 | and comment = parse 48 | "*)" { } 49 | | '\n' { Lexing.new_line lexbuf; comment lexbuf } 50 | | "(*" { comment lexbuf; comment lexbuf } 51 | | _ { comment lexbuf } 52 | -------------------------------------------------------------------------------- /modulog/location.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Generated 3 | | FromSource of { loc_start : Lexing.position 4 | ; loc_end : Lexing.position 5 | } 6 | 7 | let mk loc_start loc_end = 8 | FromSource { loc_start; loc_end } 9 | 10 | let of_lexbuf lexbuf = 11 | mk (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf) 12 | 13 | let generated = Generated 14 | 15 | open Lexing 16 | 17 | let pp fmt = function 18 | | Generated -> 19 | Format.pp_print_string fmt "" 20 | | FromSource { loc_start; loc_end } 21 | when loc_start.pos_lnum = loc_end.pos_lnum -> 22 | Format.fprintf fmt 23 | "file %S, line %d, characters %d-%d" 24 | loc_start.pos_fname 25 | loc_start.pos_lnum 26 | (loc_start.pos_cnum-loc_start.pos_bol) 27 | (loc_end.pos_cnum-loc_end.pos_bol) 28 | | FromSource { loc_start; loc_end } -> 29 | Format.fprintf fmt 30 | "file %S, line %d, character %d, to line %d, character %d, " 31 | loc_start.pos_fname 32 | loc_start.pos_lnum 33 | (loc_start.pos_cnum-loc_start.pos_bol) 34 | loc_end.pos_lnum 35 | (loc_end.pos_cnum-loc_end.pos_bol) 36 | 37 | let pp_without_filename fmt = function 38 | | Generated -> 39 | Format.pp_print_string fmt "" 40 | | FromSource { loc_start; loc_end } 41 | when loc_start.pos_lnum = loc_end.pos_lnum -> 42 | Format.fprintf fmt 43 | "line %d, characters %d-%d" 44 | loc_start.pos_lnum 45 | (loc_start.pos_cnum-loc_start.pos_bol) 46 | (loc_end.pos_cnum-loc_end.pos_bol) 47 | | FromSource { loc_start; loc_end } -> 48 | Format.fprintf fmt 49 | "line %d, character %d, to line %d, character %d, " 50 | loc_start.pos_lnum 51 | (loc_start.pos_cnum-loc_start.pos_bol) 52 | loc_end.pos_lnum 53 | (loc_end.pos_cnum-loc_end.pos_bol) 54 | -------------------------------------------------------------------------------- /modulog/location.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val mk : Lexing.position -> Lexing.position -> t 4 | 5 | val of_lexbuf : Lexing.lexbuf -> t 6 | 7 | val generated : t 8 | 9 | val pp : Format.formatter -> t -> unit 10 | 11 | val pp_without_filename : Format.formatter -> t -> unit 12 | 13 | -------------------------------------------------------------------------------- /modulog/parser_driver.ml: -------------------------------------------------------------------------------- 1 | module MI = Parser.MenhirInterpreter 2 | 3 | (* Plan: to use the same idea as CompCert's error messages and use $0, 4 | $1, etc. to refer to items on the parse stack. *) 5 | 6 | (* FIXME: this doesn't handle UTF-8 at all... *) 7 | let shorten s = 8 | if String.length s <= 35 then 9 | s 10 | else 11 | (String.sub s 0 15 12 | ^ "....." 13 | ^ String.sub s (String.length s - 15) 15) 14 | 15 | let extract spos epos = 16 | assert (spos.Lexing.pos_fname = epos.Lexing.pos_fname); 17 | let filename = spos.Lexing.pos_fname in 18 | let spos = spos.Lexing.pos_cnum in 19 | let epos = epos.Lexing.pos_cnum in 20 | assert (spos >= 0); 21 | assert (spos <= epos); 22 | let ch = open_in filename in 23 | seek_in ch spos; 24 | let str = 25 | match really_input_string ch (epos - spos) with 26 | | exception End_of_file -> "???" 27 | | str -> str 28 | in 29 | close_in ch; 30 | shorten (String.map (function '\x00' .. '\x1f' | '\x80' .. '\xff' -> ' ' | c -> c) str) 31 | 32 | let digit_of_char c = 33 | Char.(code c - code '0') 34 | 35 | (* Expand out references of the form $i to the piece of the input that 36 | is referred to by that element of the current parse stack. *) 37 | let expand_message env message = 38 | let buf = Buffer.create (String.length message) in 39 | let add_extract sidx eidx = 40 | if sidx < eidx then 41 | Buffer.add_string buf "\"???\"" 42 | else match MI.get sidx env, MI.get eidx env with 43 | | None, _ | _, None -> 44 | Buffer.add_string buf "\"???\"" 45 | | Some (MI.Element (_, _, spos, _)), 46 | Some (MI.Element (_, _, _, epos)) -> 47 | let text = extract spos epos in 48 | Printf.bprintf buf "%S" text 49 | in 50 | let rec loop i = 51 | if i < String.length message 52 | then match message.[i] with 53 | | '$' -> read_stack_idx (i+1) 54 | | '\n' when i+1 = String.length message -> 55 | (* trim the newline off the end *) 56 | () 57 | | c -> Buffer.add_char buf c; loop (i+1) 58 | and read_stack_idx i = 59 | if i = String.length message then 60 | Buffer.add_char buf '$' 61 | else match message.[i] with 62 | | '0' .. '9' as c -> 63 | read_stack_idx_int (digit_of_char c) (i+1) 64 | | c -> 65 | Buffer.add_char buf '$'; 66 | Buffer.add_char buf c; 67 | loop (i+1) 68 | and read_stack_idx_int r i = 69 | if i = String.length message then 70 | add_extract r r 71 | else match message.[i] with 72 | | '0' .. '9' as c -> 73 | read_stack_idx_int (digit_of_char c + 10*r) (i+1) 74 | | '-' -> 75 | read_snd_stack_idx r (i+1) 76 | | c -> 77 | add_extract r r; 78 | Buffer.add_char buf c; 79 | loop (i+1) 80 | and read_snd_stack_idx r i = 81 | if i = String.length message then 82 | Printf.bprintf buf "$%d-" r 83 | else match message.[i] with 84 | | '0' .. '9' as c -> 85 | read_snd_stack_idx_int r (digit_of_char c) (i+1) 86 | | c -> 87 | Printf.bprintf buf "$%d-" r; 88 | Buffer.add_char buf c; 89 | loop (i+1) 90 | and read_snd_stack_idx_int r s i = 91 | if i = String.length message then 92 | add_extract r s 93 | else match message.[i] with 94 | | '0' .. '9' as c -> 95 | read_snd_stack_idx_int r (digit_of_char c + 10*s) (i+1) 96 | | c -> 97 | add_extract r s; 98 | Buffer.add_char buf c; 99 | loop (i+1) 100 | in 101 | loop 0; 102 | Buffer.contents buf 103 | 104 | let parse lexbuf = 105 | let rec loop cp = match cp with 106 | | MI.Accepted a -> 107 | Ok a 108 | | MI.InputNeeded env -> 109 | let token = Lexer.token lexbuf in 110 | let spos = Lexing.lexeme_start_p lexbuf in 111 | let epos = Lexing.lexeme_end_p lexbuf in 112 | loop (MI.offer cp (token, spos, epos)) 113 | | MI.Shifting _ | MI.AboutToReduce _ -> 114 | loop (MI.resume cp) 115 | | MI.HandlingError env -> 116 | let pos = Location.of_lexbuf lexbuf in 117 | let lexeme = Lexing.lexeme lexbuf in 118 | let state = MI.current_state_number env in 119 | let message = 120 | try Parser_messages.message state 121 | with Not_found -> "unknown parse error" 122 | in 123 | let message = expand_message env message in 124 | Error (pos, message, lexeme) 125 | | MI.Rejected -> 126 | assert false 127 | in 128 | let init_pos = lexbuf.Lexing.lex_curr_p in 129 | loop (Parser.Incremental.program init_pos) 130 | -------------------------------------------------------------------------------- /modulog/std.ml: -------------------------------------------------------------------------------- 1 | let read_structure_from_file filename = 2 | let ch = open_in filename in 3 | try 4 | let lexbuf = Lexing.from_channel (open_in filename) in 5 | lexbuf.Lexing.lex_curr_p <- 6 | { Lexing.pos_fname = filename 7 | ; pos_lnum = 1 8 | ; pos_cnum = 0 9 | ; pos_bol = 0 10 | }; 11 | let result = Parser_driver.parse lexbuf in 12 | close_in ch; 13 | result 14 | with e -> 15 | close_in ch; raise e 16 | 17 | -------------------------------------------------------------------------------- /modulog/syntax.ml: -------------------------------------------------------------------------------- 1 | module Core = Core_syntax.Make (Modules.Syntax.String_names) 2 | module Mod = Modules.Syntax.Mod_Syntax_Raw (Core) 3 | -------------------------------------------------------------------------------- /modulog/syntax.mli: -------------------------------------------------------------------------------- 1 | module Core : module type of Core_syntax.Make (Modules.Syntax.String_names) 2 | 3 | module Mod : Modules.Syntax.MOD_SYNTAX_RAW 4 | with type Core.Location.t = Core.Location.t 5 | and type Core.Names.ident = Core.Names.ident 6 | and type Core.Names.longident = Core.Names.longident 7 | and type Core.term = Core.term 8 | and type Core.val_type = Core.val_type 9 | and type Core.def_type = Core.def_type 10 | and type Core.kind = Core.kind 11 | -------------------------------------------------------------------------------- /modulog/to_rules.ml: -------------------------------------------------------------------------------- 1 | module Ruleset = Datalog.Ruleset 2 | 3 | module List = struct 4 | include List 5 | 6 | let fold_righti f l a = 7 | snd (List.fold_right (fun x (i, a) -> (i+1, f i x a)) l (0,a)) 8 | end 9 | 10 | module Eval = struct 11 | module Core = Checked_syntax.Core 12 | 13 | type 'a eval = 14 | Ruleset.builder -> 'a * Ruleset.builder 15 | 16 | let return x rules = 17 | (x, rules) 18 | 19 | let (>>=) c f rules = 20 | let a, rules = c rules in 21 | f a rules 22 | 23 | let run c = 24 | let (), rules = c Ruleset.Builder.empty in 25 | Ruleset.Builder.finish rules 26 | 27 | type eval_type = 28 | | Itype_int 29 | | Itype_tuple of eval_type list 30 | | Itype_enum of string list 31 | 32 | let arity_of_eval_type typ = 33 | let rec count = function 34 | | Itype_int | Itype_enum _ -> fun i -> i+1 35 | | Itype_tuple typs -> List.fold_right count typs 36 | in 37 | count typ 0 38 | 39 | let arity_of_decl_type typs = 40 | List.fold_left (fun a typ -> arity_of_eval_type typ + a) 0 typs 41 | 42 | type eval_value = 43 | | Val_predicate of Ruleset.predicate_name * eval_type list 44 | | Val_const of Core.expr 45 | 46 | module Eval (Env : Modules.Evaluator.EVAL_ENV 47 | with type eval_value = eval_value 48 | and type eval_type = eval_type) = 49 | struct 50 | 51 | let rec eval_type env () = function 52 | | {Core.domtype_data=Type_int} -> 53 | Itype_int 54 | | {domtype_data=Type_typename lid} -> 55 | (match Env.find lid env with 56 | | Some (`Type ty) -> ty 57 | | _ -> failwith "internal: expecting a type") 58 | | {domtype_data=Type_tuple tys} -> 59 | Itype_tuple (List.map (eval_type env ()) tys) 60 | | {domtype_data=Type_enum syms} -> 61 | Itype_enum syms 62 | 63 | let rec eta_expand_var vnm suffix ty flexprs = 64 | match ty with 65 | | Itype_int | Itype_enum _ -> 66 | let vnm = vnm ^ (String.concat "/" (List.rev_map string_of_int suffix)) 67 | in 68 | Ruleset.Var vnm :: flexprs 69 | | Itype_tuple tys -> 70 | List.fold_righti 71 | (fun i ty l -> eta_expand_var vnm (i::suffix) ty l) 72 | tys 73 | flexprs 74 | 75 | let rec eta_expand_underscore ty flexprs = 76 | match ty with 77 | | Itype_int | Itype_enum _ -> 78 | Ruleset.Underscore :: flexprs 79 | | Itype_tuple tys -> 80 | List.fold_right eta_expand_underscore tys flexprs 81 | 82 | let num_of_symbol sym syms = 83 | let rec find i = function 84 | | [] -> failwith "internal error: dodgy enum symbol" 85 | | s :: _ when String.equal s sym -> Int32.of_int i 86 | | _ :: syms -> find (i+1) syms 87 | in 88 | find 0 syms 89 | 90 | let rec flatten_expr env expr ty flexprs = 91 | match expr, ty with 92 | | {Core.expr_data = Expr_var vnm}, ty -> 93 | eta_expand_var vnm [] ty flexprs 94 | | {expr_data = Expr_literal i}, Itype_int -> 95 | Ruleset.Lit i :: flexprs 96 | | {expr_data = Expr_underscore}, ty -> 97 | eta_expand_underscore ty flexprs 98 | | {expr_data = Expr_tuple exprs}, Itype_tuple tys -> 99 | flatten_exprs env exprs tys flexprs 100 | | {expr_data = Expr_enum sym}, Itype_enum syms -> 101 | Ruleset.Lit (num_of_symbol sym syms) :: flexprs 102 | | {expr_data = Expr_lid lid}, ty -> 103 | (match Env.find lid env with 104 | | Some (`Value (Val_const expr)) -> 105 | flatten_expr env expr ty flexprs 106 | | Some _ | None -> 107 | failwith "internal error: failure looking up constant") 108 | | _ -> 109 | failwith "internal error: type mismatch in flatten_expr" 110 | 111 | and flatten_exprs env exprs tys = 112 | List.fold_right2 (flatten_expr env) exprs tys 113 | 114 | let flatten_args env exprs tys = 115 | flatten_exprs env exprs tys [] 116 | 117 | let eval_atom env = function 118 | | Core.{atom_data=Atom_predicate { pred; args }} -> 119 | (match Env.find pred env with 120 | | Some (`Value (Val_predicate (pred, typ))) -> 121 | let args = flatten_args env args typ in 122 | Ruleset.Atom {pred; args} 123 | | _ -> 124 | failwith "internal error: type error in eval_atom") 125 | 126 | let eval_rule env Core.{rule_pred; rule_args; rule_rhs} = 127 | match Env.find (Modules.Path.Pident rule_pred) env with 128 | | Some (`Value (Val_predicate (pred, typ))) -> 129 | let args = flatten_args env rule_args typ in 130 | let rhs = List.map (eval_atom env) rule_rhs in 131 | Ruleset.{ pred; args; rhs } 132 | | _ -> 133 | failwith "internal error: type error in eval_rule" 134 | 135 | let builder_map f l s = 136 | let rec loop acc s = function 137 | | [] -> List.rev acc, s 138 | | x::l -> let y, s = f x s in loop (y::acc) s l 139 | in 140 | loop [] s l 141 | 142 | let builder_iter f l s = 143 | let rec loop s = function 144 | | [] -> (), s 145 | | x::l -> let (), s = f x s in loop s l 146 | in 147 | loop s l 148 | 149 | let builder f rules = 150 | match f rules with 151 | | Ok rules -> (), rules 152 | | Error _ -> failwith "internal error: builder error" 153 | 154 | let make_ident path ident = 155 | (* FIXME: better way of communicating structured names *) 156 | String.concat "_" (List.rev (Modules.Ident.name ident :: path)) 157 | 158 | let declare_pred env path decl_name int decl_type = 159 | let ident = make_ident path decl_name in 160 | let decl_type = List.map (eval_type env ()) decl_type.Core.predty_data in 161 | let arity = arity_of_decl_type decl_type in 162 | let name = Ruleset.{ident;arity} in 163 | builder (Ruleset.Builder.add_predicate name int) >>= fun () -> 164 | return (decl_name, Val_predicate (name, decl_type)) 165 | 166 | let eval_predicate env path defs = 167 | let info = Ruleset.{ kind = `Intensional; output = [] } in 168 | builder_map 169 | Core.(fun decl -> 170 | declare_pred env path decl.decl_name info decl.decl_type) 171 | defs 172 | >>= fun bindings -> 173 | let env = Env.add_values bindings env in 174 | builder_iter 175 | (fun Core.{decl_rules} -> 176 | builder_iter 177 | (fun rule -> builder (Ruleset.Builder.add_rule (eval_rule env rule))) 178 | decl_rules) 179 | defs 180 | >>= fun () -> 181 | return bindings 182 | 183 | let eval_external env path Core.{ external_name; external_type } = 184 | let info = 185 | let filename = Modules.Ident.name external_name ^ ".csv" in 186 | Ruleset.{ kind = `Extensional filename 187 | ; output = [] 188 | } 189 | in 190 | declare_pred env path external_name info external_type 191 | >>= fun binding -> 192 | return [binding] 193 | 194 | let eval_term env path term = 195 | match term with 196 | | Core.PredicateDefs defs -> 197 | eval_predicate env path defs 198 | | Core.External ext -> 199 | eval_external env path ext 200 | | Core.ConstantDef {const_name;const_expr} -> 201 | return [ (const_name, Val_const const_expr) ] 202 | | Core.Output { output_rel; output_filename } -> 203 | (match Env.find output_rel env with 204 | | Some (`Value (Val_predicate (name, _))) -> 205 | fun b -> 206 | [], Ruleset.Builder.add_output name output_filename b 207 | | _ -> 208 | failwith "internal error: attempting output a non relation") 209 | 210 | let eval_decl env path ident val_type = 211 | match val_type with 212 | | Core.Predicate predty -> 213 | let info = Ruleset.{ kind = `Intensional; output = [] } in 214 | declare_pred env path ident info predty >>= fun (_, typ) -> 215 | return typ 216 | | Core.Value _ -> 217 | failwith "internal error: unsafe recursive constant defn" 218 | end 219 | 220 | end 221 | 222 | module ModEval = 223 | Modules.Evaluator.Make (Checked_syntax.Mod) (Eval) 224 | 225 | let from_structure structure = 226 | Eval.run (ModEval.eval_structure structure) 227 | -------------------------------------------------------------------------------- /modulog/to_rules.mli: -------------------------------------------------------------------------------- 1 | val from_structure : Checked_syntax.Mod.structure -> Datalog.Ruleset.ruleset 2 | -------------------------------------------------------------------------------- /newtype.mlog: -------------------------------------------------------------------------------- 1 | (* Demonstration that we can use functors to turn predicates on types 2 | into proper types. Combined with inlining, this would mean that we 3 | don't need a special facility for this. It would be nice to have a 4 | shorter syntax for functor application. 5 | 6 | This would work well with dependent types too: if the 'acceptable' 7 | predicate is binary, then the resulting abstract type could depend 8 | on the argument type. *) 9 | 10 | module type NEW_TYPE_SPEC = sig 11 | type t 12 | 13 | pred acceptable : t 14 | end 15 | 16 | module type NEW_TYPE = sig 17 | type concrete 18 | type t 19 | 20 | (* Under the assumption that there is at most one 't' for every 'concrete'. Could this be stated? *) 21 | pred repr : t * concrete 22 | end 23 | 24 | module New_type (T : NEW_TYPE_SPEC) = 25 | (struct 26 | type concrete = T.t 27 | type t = T.t 28 | 29 | define repr : t * concrete 30 | repr(?x, ?x) :- T.acceptable(?x) 31 | end : NEW_TYPE with type concrete = T.t) 32 | 33 | -------------------------------------------------------------------------------- /notes.md: -------------------------------------------------------------------------------- 1 | # Notes 2 | 3 | - On fast large-scale program analysis in Datalog 4 | http://dl.acm.org/citation.cfm?id=2892226 5 | 6 | - Soufflé: On Synthesis of Program Analyzers 7 | http://link.springer.com/chapter/10.1007/978-3-319-41540-6_23 8 | https://github.com/oracle/souffle 9 | 10 | - https://blog.acolyer.org/2018/03/27/anna-a-kvs-for-any-scale/ 11 | 12 | - http://categoricaldata.net/aql.html 13 | 14 | - "Modules for Prolog Revisited" -- not sure how related this is. 15 | 16 | - "A Theory of Modules for Logic Programming" -- similar 17 | 18 | - https://semmle.com/publications 19 | 20 | ## Joins 21 | 22 | - https://github.com/frankmcsherry/blog/blob/master/posts/2018-05-19.md 23 | Stores relations as sorted lists, and uses some clever tricks to do 24 | joins. Especially when there is one big source relation followed by 25 | several filters. We could re-order the filters based on selectivity? 26 | 27 | ## Code generation 28 | 29 | - A C++ library for generating machine code: 30 | 31 | https://github.com/asmjit/asmjit 32 | 33 | This was mentioned in a sequence of blog posts on making a JIT for 34 | Brainfuck: 35 | 36 | http://eli.thegreenplace.net/2017/adventures-in-jit-compilation-part-1-an-interpreter/ 37 | http://eli.thegreenplace.net/2017/adventures-in-jit-compilation-part-2-an-x64-jit/ 38 | 39 | 40 | ## Using relational data stores 41 | 42 | - "SQLGraph: An Efficient Relational-Based Property Graph Store" is a 43 | paper describing efficient ways of storing graph structured data in 44 | a relational database. 45 | 46 | https://static.googleusercontent.com/media/research.google.com/en//pubs/archive/43287.pdf 47 | 48 | - Recursive with in SQL: 49 | 50 | https://lagunita.stanford.edu/c4x/DB/Recursion/asset/OtherRecursion.pdf 51 | 52 | ## B-Trees, and related 53 | 54 | - https://github.com/tomjridge/tjr_btree 55 | A B-Tree implementation in OCaml, extracted from Isabelle/HOL. By Tom Ridge. 56 | 57 | - https://github.com/spacejam/rsdb/blob/master/README.md 58 | A Rust implementation of something called "BW-Trees", which apparently work better on SSDs 59 | 60 | - https://github.com/datacrypt-project/hitchhiker-tree 61 | 62 | # Compilation 63 | 64 | 1. Alter `Relation_machine.of_rules` to avoid unnecessary copying by 65 | unrolling the fixpoint loops by one. 66 | 67 | 2. Do a naive translation that ignores indexes. 68 | 69 | 3. Then include the indexes 70 | 71 | 72 | # Other ideas 73 | 74 | - Conversion of regular expressions into rules describing an automaton? 75 | - 76 | - Streaming predicates 77 | - Conversion of LTL formulae into Buchi automata? 78 | - Greatest fixpoints; Inf-datalog; CTL. 79 | - Proof producing execution 80 | - Semiring weighted relations? 81 | - Negation, and other aggregation operators 82 | - Proper integration of external data sources as extensional dbs 83 | - And connect these into the interpreter(s) and compiler 84 | - Modules: Signature update; `open`; `include`; `module type of`; 85 | separate compilation. 86 | 87 | # Datalog optimisations 88 | 89 | ## (Non-size-increasing) Inlining 90 | 91 | If there is a rule of the form: 92 | 93 | a(?X1,...,?Xn) :- b(?Xi1, ..., ?Xim) 94 | 95 | and this is the only rule defining `a`, then replace all occurences of 96 | `a` with the appropriate instantiation of `b`. 97 | 98 | More generally, might do partial evaluation of the datalog? to 99 | eliminate fully ground rules. This would require duplication of 100 | existing rules. 101 | 102 | ## (potentially) join re-ordering? 103 | 104 | ## Magic sets? 105 | 106 | - Given a top-down pattern 107 | - Essentially, push through the requirements to guide the bottom-up 108 | solver. 109 | 110 | # Module systems 111 | 112 | - A caml-list post by Andreas Rossberg on how checking of module 113 | signature subsumption in OCaml is undecidable due to abstract module 114 | signatures: 115 | 116 | http://caml.inria.fr/pub/old_caml_site/caml-list/1507.html 117 | 118 | - Rossberg's "1ML – Core and Modules United (F-ing First-class 119 | Modules)" describes a new ML-like language where the core language 120 | and the module language are unified. Based on the "F-ing modules" 121 | translation from modules for ML to System Fomega. 122 | 123 | - Harper and Stone's "A Type-Theoretic Interpretation of Standard 124 | ML". An approach to understanding SML's module system by seeing it 125 | as a kind of dependent type theory. 126 | 127 | - Dreyer's PhD thesis "Understanding and Evolving the ML Module 128 | System". Presents a survey of existing ways of describing the ML 129 | module system and attempts to unify them in a single common 130 | system. Uses this unification to extend ML modules to include 131 | recursive modules. Proposes a new form of ML based on this work. 132 | -------------------------------------------------------------------------------- /paths.mlog: -------------------------------------------------------------------------------- 1 | type vertex = int 2 | 3 | define 4 | edge : vertex * vertex 5 | edge(1, 2) 6 | edge(2, 3) 7 | edge(3, 4) 8 | 9 | define 10 | path : vertex * vertex 11 | path(?X,?Y) :- edge(?X,?Y) 12 | path(?X,?Z) :- path(?X,?Y), edge(?Y,?Z) 13 | -------------------------------------------------------------------------------- /paths2.mlog: -------------------------------------------------------------------------------- 1 | module type Edges = sig 2 | type vertex 3 | 4 | pred edge : vertex * vertex 5 | end 6 | 7 | module MyEdges = struct 8 | type vertex = int 9 | 10 | define edge : vertex * vertex 11 | edge(1, 2) 12 | edge(2, 3) 13 | edge(3, 4) 14 | edge(4, 1) 15 | end 16 | 17 | module Path (E : Edges) = struct 18 | 19 | type vertex = E.vertex 20 | 21 | define path : E.vertex * E.vertex 22 | path(?X,?Y) :- E.edge(?X,?Y) 23 | path(?X,?Z) :- path(?X,?Y), E.edge(?Y,?Z) 24 | 25 | end 26 | 27 | module P = Path (MyEdges) 28 | -------------------------------------------------------------------------------- /pointsto.mlog: -------------------------------------------------------------------------------- 1 | module type PROGRAM = sig 2 | type variable 3 | 4 | type object 5 | 6 | type fieldname 7 | 8 | alloc : variable * object 9 | 10 | assign : variable * variable 11 | 12 | fread : variable * variable * fieldname 13 | 14 | fwrite : variable * fieldname * variable 15 | end 16 | 17 | module PointsTo (P : PROGRAM) = struct 18 | 19 | define 20 | ptsto : P.variable * P.object 21 | ptsto(?v,?o) :- P.alloc(?v,?o) 22 | ptsto(?v,?o) :- P.assign(?v,?v2), ptsto(?v2,?o) 23 | ptsto(?v,?o) :- P.fread(?v,?v2,?f), ptsto(?v2,?o2), fptsto(?o2,?f,?o) 24 | 25 | and 26 | fptsto : P.object * P.fieldname * P.object 27 | fptsto(?o,?f,?o2) :- P.fwrite(?v,?f,?v2), ptsto(?v,?o), ptsto(?v2,?o2) 28 | 29 | end 30 | 31 | module TestProg = struct 32 | 33 | type variable = int 34 | 35 | type object = int 36 | 37 | type fieldname = int 38 | 39 | define 40 | alloc : int * int 41 | and assign : int * int 42 | and fread : int * int * int 43 | and fwrite : int * int * int 44 | 45 | end 46 | 47 | module P = PointsTo (TestProg) 48 | -------------------------------------------------------------------------------- /rec-unsafe.mlog: -------------------------------------------------------------------------------- 1 | define edge : int * int 2 | edge(1,2) 3 | edge(0,1) 4 | 5 | module type PATH = sig 6 | path : int * int 7 | constant foo : int 8 | end 9 | 10 | module rec P : PATH = struct 11 | define path : int * int 12 | path(?x,?y) :- edge(?x,?y) 13 | path(?x,?z) :- P.path(?x,?y), edge(?y,?z) 14 | 15 | constant foo : int = P.foo 16 | end 17 | 18 | 19 | define reachable : int 20 | reachable(?x) :- P.path(0,?x) 21 | -------------------------------------------------------------------------------- /rec.mlog: -------------------------------------------------------------------------------- 1 | define edge : int * int 2 | edge(1,2) 3 | edge(0,1) 4 | 5 | module type PATH = sig 6 | path : int * int 7 | end 8 | 9 | module rec P : PATH = struct 10 | define path : int * int 11 | path(?x,?y) :- edge(?x,?y) 12 | path(?x,?z) :- P.path(?x,?y), edge(?y,?z) 13 | end 14 | 15 | 16 | define reachable : int 17 | reachable(?x) :- P.path(0,?x) 18 | -------------------------------------------------------------------------------- /relation_machine/codegen.ml: -------------------------------------------------------------------------------- 1 | module Buf (IA : Idealised_algol.Syntax.S) = struct 2 | module type S = Codegen_double_buf.S with module Syn = IA 3 | 4 | type t = Buf : (module S with type handle = 'h) * 'h -> t 5 | 6 | let declare arity k = 7 | let module Config = struct let arity = arity end in 8 | let module B = Codegen_double_buf.Make (IA) (Config) () in 9 | B.declare (fun h -> k (Buf ((module B), h))) 10 | 11 | let insert (Buf (m, h)) vals = 12 | let module B = (val m) in 13 | B.insert h vals 14 | 15 | let iterate_all (Buf (m, h)) k = 16 | let module B = (val m) in 17 | B.iterate_all h k 18 | 19 | let swap (Buf (m, h)) = 20 | let module B = (val m) in 21 | B.swap h 22 | 23 | let is_empty (Buf (m, h)) = 24 | let module B = (val m) in 25 | B.is_empty h 26 | end 27 | 28 | module Gen (IA : Idealised_algol.Syntax.S) () = struct 29 | 30 | let map_seq f = 31 | List.fold_left (fun code x -> IA.(^^) code (f x)) IA.empty 32 | 33 | module Buf = Buf (IA) 34 | module CSV = Codegen_csv.Make (IA) 35 | 36 | (* FIXME: do the same thing for Tables as for Buffers *) 37 | module type INDEXED_TABLE = Codegen_indexed_table.S with module S = IA 38 | 39 | type value = 40 | | Buffer : Buf.t -> value 41 | | Table : (module INDEXED_TABLE with type handle = 'h) * 'h -> value 42 | 43 | module RelEnv = Map.Make (Syntax.RelVar) 44 | 45 | module AttrEnv = Map.Make (Syntax.Attr) 46 | 47 | let rec and_list = function 48 | | [] -> IA.Bool.true_ 49 | | [e] -> e 50 | | e::es -> IA.Bool.(&&) e (and_list es) 51 | 52 | let condition lenv exps = let open! IA.Int32 in function 53 | | (i, Syntax.Attr nm) -> exps.(i) == AttrEnv.find nm lenv 54 | | (i, Syntax.Lit j) -> exps.(i) == const j 55 | 56 | let exp_of_scalar lenv = function 57 | | Syntax.Attr nm -> AttrEnv.find nm lenv 58 | | Syntax.Lit j -> IA.Int32.const j 59 | 60 | let pattern_of_conditions arity lenv conditions = 61 | let pat = Array.make arity `Wild in 62 | List.iter 63 | (fun (i, scalar) -> pat.(i) <- `Fixed (exp_of_scalar lenv scalar)) 64 | conditions; 65 | pat 66 | 67 | let print_strln s = 68 | let open! IA.Stdio in 69 | printf stdout (lit s @@ lit "\n" @@ stop) 70 | 71 | let print_exps exps = 72 | let open! IA.Stdio in 73 | begin%monoid.IA 74 | for i = 0 to Array.length exps - 1 do 75 | if i > 0 then printf stdout (lit "," @@ stop); 76 | printf stdout (int32 @@ stop) exps.(i) 77 | done; 78 | printf stdout (lit "\n" @@ stop) 79 | end 80 | 81 | let projections_to_lenv projections attrs lenv = 82 | List.fold_right 83 | (fun (i, nm) -> AttrEnv.add nm attrs.(i)) 84 | projections 85 | lenv 86 | 87 | let if_conj conditions then_ = 88 | match conditions with 89 | | [] -> then_ 90 | | conditions -> IA.ifthen (and_list conditions) ~then_ 91 | 92 | let rec translate_expr expr env lenv k = match expr with 93 | | Syntax.Return { values } -> 94 | k (Array.map (exp_of_scalar lenv) values) 95 | 96 | | Syntax.Guard_NotIn { relation; values; cont } -> 97 | begin 98 | match RelEnv.find relation env with 99 | | Buffer _ -> 100 | (* FIXME: in some cases, it would make sense to check 101 | the write end of the buffer for duplicates before 102 | checking the relation itself. *) 103 | failwith "internal error: [codegen] buffer used as a guard" 104 | | Table (m, handle) -> 105 | let module IT = (val m) in 106 | let values = Array.map (exp_of_scalar lenv) values in 107 | IT.ifmember handle values 108 | ~then_:IA.empty 109 | ~else_:(translate_expr cont env lenv k) 110 | end 111 | 112 | | Syntax.Select { relation; conditions; projections; cont } -> 113 | begin match RelEnv.find relation env with 114 | | Buffer handle -> 115 | begin 116 | (* FIXME: emit a warning if conditions contains anything, 117 | or if projections is empty. *) 118 | Buf.iterate_all handle @@ fun attrs -> 119 | if_conj (List.map (condition lenv attrs) conditions) 120 | (let lenv = projections_to_lenv projections attrs lenv in 121 | translate_expr cont env lenv k) 122 | end 123 | | Table (m, handle) -> 124 | begin 125 | let module IT = (val m) in 126 | match conditions, projections with 127 | | conditions, [] -> 128 | let pat = pattern_of_conditions IT.arity lenv conditions in 129 | IT.ifmember_pat handle ~pat 130 | ~then_:(translate_expr cont env lenv k) 131 | ~else_:IA.empty 132 | | [], projections -> 133 | IT.iterate_all handle ~do_:begin fun attrs -> 134 | let lenv = projections_to_lenv projections attrs lenv in 135 | translate_expr cont env lenv k 136 | end 137 | | conditions, projections -> 138 | let pat = pattern_of_conditions IT.arity lenv conditions in 139 | IT.iterate handle ~pat ~do_:begin fun attrs -> 140 | let lenv = projections_to_lenv projections attrs lenv in 141 | translate_expr cont env lenv k 142 | end 143 | end 144 | end 145 | 146 | let rec translate_comm env = function 147 | | Syntax.ReadRelation (nm, filename) -> 148 | (match RelEnv.find nm env with 149 | | Buffer _ -> failwith "internal error: [codegen] loading into buffer" 150 | | Table (m, h) -> 151 | let module IT = (val m) in 152 | IA.Stdio.with_file_input filename begin fun ch -> 153 | IA.while_ IA.Bool.true_ ~do_:begin 154 | CSV.read_tuple ch ~width:nm.arity 155 | ~eof:IA.break 156 | ~parsed:(IT.insert h) 157 | end 158 | end) 159 | 160 | | Syntax.WriteRelation (nm, filename) -> 161 | (match RelEnv.find nm env with 162 | | Buffer _ -> failwith "internal error: [codegen] writing from buffer" 163 | | Table (m, h) -> 164 | let module IT = (val m) in 165 | IA.Stdio.with_file_output filename begin fun ch -> 166 | IT.iterate_all h ~do_:begin fun exps -> 167 | CSV.write_tuple ch exps 168 | end 169 | end) 170 | 171 | | Syntax.WhileNotEmpty (vars, body) -> 172 | let check_empty nm = 173 | match RelEnv.find nm env with 174 | | Buffer handle -> 175 | Buf.is_empty handle 176 | | Table _ -> 177 | failwith "internal error: [codegen] emptiness test on a table" 178 | in 179 | IA.while_ (IA.Bool.not (and_list (List.map check_empty vars))) 180 | ~do_:(translate_comms env body) 181 | 182 | | Insert (relvar, expr) -> 183 | (translate_expr expr env AttrEnv.empty @@ fun vals -> 184 | match RelEnv.find relvar env with 185 | | Buffer handle -> 186 | Buf.insert handle vals 187 | | Table (m, handle) -> 188 | (* FIXME: the membership check is not always required if 189 | doing a merge from a buffer. *) 190 | let module IT = (val m) in 191 | IT.ifmember handle vals 192 | ~then_:IA.empty 193 | ~else_:(IT.insert handle vals)) 194 | 195 | | DeclareBuffers (vars, body) -> 196 | List.fold_right 197 | (fun (Syntax.{ident=_;arity} as varnm) k env -> 198 | Buf.declare (* ~name:ident ~ *)arity 199 | (fun handle -> k (RelEnv.add varnm (Buffer handle) env))) 200 | vars 201 | (fun env -> translate_comms env body) 202 | env 203 | 204 | | Swap relvar -> 205 | (match RelEnv.find relvar env with 206 | | Buffer buf -> 207 | Buf.swap buf 208 | | Table _ -> 209 | failwith "internal error: [codegen] attempt to swap a table") 210 | 211 | and translate_comms env comms = 212 | map_seq (translate_comm env) comms 213 | 214 | let translate_predicate indexes relvar k env = 215 | let indexes = 216 | match List.assoc relvar indexes with 217 | | exception Not_found -> 218 | failwith "internal error: [codegen] relation missing an index" 219 | | indexes -> 220 | indexes 221 | in 222 | let module P = struct 223 | let arity = relvar.Syntax.arity and indexes = indexes 224 | end in 225 | let module IT = Codegen_indexed_table.Make (IA) (P) () in 226 | IT.declare ~name:relvar.Syntax.ident begin fun handle -> 227 | k (RelEnv.add relvar (Table ((module IT), handle)) env) 228 | end 229 | 230 | let translate_prog (Syntax.{ relvars; commands } as code) = 231 | let indexes = Indexes.indexes code in 232 | List.fold_right (translate_predicate indexes) relvars 233 | (fun env -> translate_comms env commands) 234 | RelEnv.empty 235 | end 236 | 237 | let generator (type comm) 238 | (module IA : Idealised_algol.Syntax.S with type comm = comm) 239 | program = 240 | let module T = Gen (IA) () in 241 | T.translate_prog program 242 | 243 | let translate program = 244 | let open! Idealised_algol in 245 | C.output { Syntax.generate = generator } program Format.std_formatter 246 | 247 | let compile outname program = 248 | let open! Idealised_algol in 249 | C.compile outname { Syntax.generate = generator } program 250 | -------------------------------------------------------------------------------- /relation_machine/codegen_csv.ml: -------------------------------------------------------------------------------- 1 | module Make (IA : Idealised_algol.Syntax.S) : sig 2 | val write_tuple : 3 | IA.Stdio.out_ch IA.exp -> 4 | int32 IA.exp array -> 5 | IA.comm 6 | 7 | val read_tuple : 8 | IA.Stdio.in_ch IA.exp -> 9 | width:int -> 10 | parsed:(int32 IA.exp array -> IA.comm) -> 11 | eof:IA.comm -> 12 | IA.comm 13 | end = struct 14 | 15 | type w = W : { format : 'a IA.Stdio.fmt; cont : 'a -> IA.comm } -> w 16 | 17 | let rec build_writer arr n = 18 | let open! IA.Stdio in 19 | if n = Array.length arr - 1 then 20 | W { format = int32 @@ lit "\n" @@ stop 21 | ; cont = (fun k -> k arr.(n)) 22 | } 23 | else 24 | let W {format; cont} = build_writer arr (n+1) in 25 | W { format = int32 @@ lit "," @@ format 26 | ; cont = (fun k -> cont (k arr.(n))) 27 | } 28 | 29 | let write_tuple out_ch arr = 30 | let open! IA.Stdio in 31 | let W { format; cont } = build_writer arr 0 in 32 | printf out_ch format |> cont 33 | 34 | type r = R : { format : 'a IA.Stdio.fmt; cont : int32 IA.exp list -> 'a } -> r 35 | 36 | let rec build_reader n i k = 37 | let open! IA.Stdio in 38 | if i = n - 1 then 39 | R { format = int32 @@ lit "\n" @@ stop 40 | ; cont = (fun exps exp -> k (Array.of_list (List.rev (exp::exps)))) 41 | } 42 | else 43 | let R {format; cont} = build_reader n (i+1) k in 44 | R { format = int32 @@ lit "," @@ format 45 | ; cont = (fun exps exp -> cont (exp::exps)) 46 | } 47 | 48 | let read_tuple in_ch ~width ~parsed ~eof = 49 | let open! IA.Stdio in 50 | let R {format; cont} = build_reader width 0 parsed in 51 | scanf in_ch format ~parsed:(cont []) ~eof 52 | 53 | end 54 | -------------------------------------------------------------------------------- /relation_machine/codegen_double_buf.ml: -------------------------------------------------------------------------------- 1 | module type CONFIG = sig 2 | val arity : int 3 | end 4 | 5 | module type S = sig 6 | module Syn : Idealised_algol.Syntax.S 7 | 8 | type handle 9 | 10 | val declare : (handle -> Syn.comm) -> Syn.comm 11 | 12 | val insert : handle -> int32 Syn.exp array -> Syn.comm 13 | 14 | val iterate_all : handle -> (int32 Syn.exp array -> Syn.comm) -> Syn.comm 15 | 16 | val swap : handle -> Syn.comm 17 | 18 | val is_empty : handle -> bool Syn.exp 19 | end 20 | 21 | module Make (Syn : Idealised_algol.Syntax.S) (C : CONFIG) () 22 | : S with module Syn = Syn 23 | = 24 | struct 25 | 26 | module Syn = Syn 27 | 28 | module Key = Codegen_inttuple.Make (Syn) (C) () 29 | module BT = 30 | Idealised_algol.Btree.Make (Syn) (struct let min_children = 16l end) 31 | (Key) 32 | () 33 | 34 | type handle = 35 | { write : BT.handle 36 | ; read : BT.handle 37 | } 38 | 39 | (* declare_buffer (path_buf/2) { 40 | path_buf/2 += path; 41 | 42 | swap path_buf; 43 | 44 | while_not_empty (path_buf) { 45 | path_buf <- 46 | [ (x,z) | (x,y) <- path_buf, (y,z) <- edge, (x,z) \nin path ] 47 | 48 | swap path_buf; 49 | 50 | path <- path_buf; 51 | } 52 | *) 53 | 54 | let declare k = 55 | BT.declare @@ fun read -> 56 | BT.declare @@ fun write -> 57 | k {read; write} 58 | 59 | let insert h vals = 60 | let key = Key.create vals in 61 | BT.ifmember key h.write 62 | Syn.empty 63 | (BT.insert key h.write) 64 | 65 | let iterate_all h k = 66 | BT.iterate_all h.read (fun key -> k (Array.init C.arity (Key.get key))) 67 | 68 | let swap h = 69 | BT.move ~src:h.write ~tgt:h.read 70 | 71 | let is_empty h = 72 | BT.is_empty h.read 73 | 74 | end 75 | -------------------------------------------------------------------------------- /relation_machine/codegen_indexed_table.ml: -------------------------------------------------------------------------------- 1 | module Array = struct 2 | include Array 3 | let fold_lefti f init arr = 4 | let rec loop ~idx ~accum = 5 | if idx = Array.length arr then 6 | accum 7 | else 8 | let accum = f accum idx arr.(idx) in 9 | loop ~idx:(idx+1) ~accum 10 | in 11 | loop ~idx:0 ~accum:init 12 | end 13 | 14 | module type S = sig 15 | module S : Idealised_algol.Syntax.S 16 | 17 | type handle 18 | 19 | val arity : int 20 | 21 | val declare : name:string -> (handle -> S.comm) -> S.comm 22 | 23 | val iterate : 24 | handle -> 25 | pat:[`Wild | `Fixed of int32 S.exp] array -> 26 | do_:(int32 S.exp array -> S.comm) -> 27 | S.comm 28 | 29 | val iterate_all : 30 | handle -> 31 | do_:(int32 S.exp array -> S.comm) -> 32 | S.comm 33 | 34 | val insert : handle -> int32 S.exp array -> S.comm 35 | 36 | val ifmember_pat : 37 | handle -> 38 | pat:[`Wild | `Fixed of int32 S.exp] array -> 39 | then_:S.comm -> 40 | else_:S.comm -> 41 | S.comm 42 | 43 | val ifmember : 44 | handle -> 45 | int32 S.exp array -> 46 | then_:S.comm -> 47 | else_:S.comm -> 48 | S.comm 49 | end 50 | 51 | module type CONFIG = sig 52 | val arity : int 53 | val indexes : int array array 54 | end 55 | 56 | module Make (S : Idealised_algol.Syntax.S) (A : CONFIG) () : S with module S = S = 57 | struct 58 | 59 | module S = S 60 | 61 | let _ = 62 | (* FIXME: raise invalid_arg? *) 63 | assert (A.arity > 0); 64 | assert (Array.length A.indexes > 0); 65 | assert (Array.for_all (fun a -> Array.length a = A.arity) A.indexes) 66 | 67 | let arity = A.arity 68 | 69 | module Key = Codegen_inttuple.Make (S) (A) () 70 | 71 | module BT = 72 | Idealised_algol.Btree.Make (S) 73 | (struct let min_children = 16l end) 74 | (Key) 75 | () 76 | 77 | type handle = BT.handle array 78 | 79 | let declare ~name:_ k = 80 | let rec loop i l = 81 | if i = Array.length A.indexes then 82 | k (Array.of_list (List.rev l)) 83 | else 84 | BT.declare (fun v -> loop (i+1) (v::l)) 85 | in 86 | loop 0 [] 87 | 88 | let conv_pattern pat = 89 | pat 90 | |> Array.fold_lefti (fun l i -> function `Fixed _ -> i::l | `Wild -> l) [] 91 | |> List.rev 92 | |> Array.of_list 93 | 94 | let is_prefix ar1 ar2 = 95 | if Array.length ar1 > Array.length ar2 then false 96 | else 97 | let rec loop i = 98 | if i = Array.length ar1 then true 99 | else if ar1.(i) <> ar2.(i) then false 100 | else loop (i+1) 101 | in 102 | loop 0 103 | 104 | let find_handle prefix handles = 105 | let rec loop i = 106 | if i = Array.length handles then 107 | failwith "Invalid search pattern" 108 | else if is_prefix prefix A.indexes.(i) then 109 | handles.(i), A.indexes.(i) 110 | else 111 | loop (i+1) 112 | in 113 | loop 0 114 | 115 | let invert perm = 116 | let inv = Array.make (Array.length perm) 0 in 117 | Array.iteri (fun i j -> inv.(j) <- i) perm; 118 | inv 119 | 120 | let get_fixed = function 121 | | `Fixed e -> e 122 | | `Wild -> assert false 123 | 124 | let for_pattern h pat k = 125 | let prefix_pat = conv_pattern pat in 126 | let handle, perm = find_handle prefix_pat h in 127 | let perm_inv = invert perm in 128 | let minimum = 129 | Key.create 130 | (Array.init A.arity 131 | (fun i -> 132 | if i < Array.length prefix_pat then 133 | get_fixed (pat.(prefix_pat.(i))) 134 | else 135 | S.Int32.const 0l)) 136 | in 137 | let maximum = 138 | Key.create 139 | (Array.init A.arity 140 | (fun i -> 141 | if i < Array.length prefix_pat then 142 | get_fixed (pat.(prefix_pat.(i))) 143 | else 144 | S.Int32.maximum)) 145 | in 146 | k handle minimum maximum perm_inv 147 | 148 | let iterate h ~pat ~do_:k = 149 | for_pattern h pat begin fun tree minimum maximum perm_inv -> 150 | BT.iterate_range 151 | minimum maximum tree 152 | begin fun key -> 153 | k (Array.init A.arity (fun i -> Key.get key perm_inv.(i))) 154 | end 155 | end 156 | 157 | let ifmember_pat h ~pat ~then_ ~else_ = 158 | for_pattern h pat begin fun tree minimum maximum _ -> 159 | BT.ifmember_range 160 | minimum maximum tree 161 | then_ 162 | else_ 163 | end 164 | 165 | let ifmember h key ~then_ ~else_ = 166 | let perm = A.indexes.(0) in 167 | let handle = h.(0) in 168 | let key = Key.create (Array.init A.arity (fun i -> key.(perm.(i)))) in 169 | BT.ifmember key handle then_ else_ 170 | 171 | let iterate_all h ~do_:k = 172 | let perm_inv = invert A.indexes.(0) in 173 | let handle = h.(0) in 174 | BT.iterate_all handle (fun key -> k (Array.init A.arity (fun i -> Key.get key perm_inv.(i)))) 175 | 176 | let insert h exps = 177 | h 178 | |> Array.mapi (fun i -> 179 | BT.insert (Key.create (Array.map (fun j -> exps.(j)) A.indexes.(i)))) 180 | |> let open! S in Array.fold_left (^^) empty 181 | 182 | end 183 | -------------------------------------------------------------------------------- /relation_machine/codegen_inttuple.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Idealised_algol.Btree.KEY 3 | 4 | val create : int32 Syn.exp array -> t Syn.exp 5 | 6 | val get : t Syn.exp -> int -> int32 Syn.exp 7 | end 8 | 9 | module Make (Syn : Idealised_algol.Syntax.S) (A : sig val arity : int end) () 10 | : S with module Syn = Syn = 11 | struct 12 | module Syn = Syn 13 | 14 | type key 15 | type t = key Syn.Struct.t 16 | let t : t Syn.typ = Syn.Struct.make "key" 17 | let val_fields = 18 | Array.init A.arity 19 | (fun i -> Syn.Struct.field t (Printf.sprintf "x%d" i) Syn.Int32.t) 20 | let () = Syn.Struct.seal t 21 | 22 | let create exps = 23 | Syn.Struct.const t (Array.map (fun e -> Syn.Struct.Exp e) exps) 24 | 25 | let get x i = 26 | let open! Syn.Struct in 27 | x#.val_fields.(i) 28 | 29 | let eq = 30 | Syn.declare_func 31 | ~name:"eq" 32 | ~typ:Syn.(("x", t) @-> ("y", t) @-> return Syn.Bool.t) 33 | ~body:begin fun x y -> 34 | let rec loop i acc = 35 | if i = A.arity then 36 | acc 37 | else 38 | loop (i+1) 39 | (let open! Syn.Bool in let open! Syn.Int32 in 40 | let open! Syn.Struct in 41 | acc && x#.val_fields.(i) == y#.val_fields.(i)) 42 | in 43 | loop 1 44 | (let open! Syn in let open! Syn.Bool in let open! Syn.Int32 in 45 | let open! Syn.Struct in 46 | x#.val_fields.(0) == y#.val_fields.(0)) 47 | end 48 | 49 | let le = 50 | Syn.declare_func 51 | ~name:"le" 52 | ~typ:Syn.(("x", t) @-> ("y", t) @-> return Syn.Bool.t) 53 | ~body:begin fun x y -> 54 | let rec loop i = 55 | if i = A.arity - 1 then 56 | let open! Syn in 57 | let open! Syn.Int32 in 58 | let open! Syn.Struct in 59 | x#.val_fields.(i) <= y#.val_fields.(i) 60 | else 61 | let e = loop (i+1) in 62 | let open! Syn in 63 | let open! Bool in 64 | let open! Int32 in 65 | let open! Syn.Struct in 66 | x#.val_fields.(i) < y#.val_fields.(i) 67 | || (x#.val_fields.(i) == y#.val_fields.(i) && e) 68 | in 69 | loop 0 70 | end 71 | 72 | let lt = 73 | Syn.declare_func 74 | ~name:"lt" 75 | ~typ:Syn.(("x", t) @-> ("y", t) @-> return Syn.Bool.t) 76 | ~body:begin fun x y -> 77 | let rec loop i = 78 | if i = A.arity - 1 then 79 | let open! Syn in 80 | let open! Syn.Int32 in 81 | let open! Syn.Struct in 82 | x#.val_fields.(i) < y#.val_fields.(i) 83 | else 84 | let e = loop (i+1) in 85 | let open! Syn in 86 | let open! Syn.Bool in 87 | let open! Syn.Int32 in 88 | let open! Syn.Struct in 89 | x#.val_fields.(i) < y#.val_fields.(i) 90 | || (x#.val_fields.(i) == y#.val_fields.(i) && e) 91 | in 92 | loop 0 93 | end 94 | end 95 | -------------------------------------------------------------------------------- /relation_machine/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name relation_machine) 3 | (preprocess (pps ppx_monoid)) 4 | (libraries ocamlgraph fmt datalog idealised_algol) 5 | (flags (:standard -w -49+44 -safe-string))) 6 | -------------------------------------------------------------------------------- /relation_machine/indexes.ml: -------------------------------------------------------------------------------- 1 | module PatternSet : sig 2 | module Pattern : sig 3 | type t 4 | 5 | val complete : int -> t 6 | val of_list : int list -> t 7 | val elements : t -> int list 8 | (* val pp : t Fmt.t *) 9 | end 10 | 11 | type t 12 | 13 | val empty : t 14 | 15 | val add : Pattern.t -> t -> t 16 | 17 | (* val pp : t Fmt.t *) 18 | 19 | include Minimalpathcover.G 20 | with type t := t 21 | and type V.t = Pattern.t 22 | 23 | end = struct 24 | (* This could be more efficiently implemented with using BDDs, but 25 | it is probably not worth it for the sizes of sets we will be 26 | dealing with. *) 27 | 28 | module Pattern = struct 29 | include Set.Make (struct type t = int let compare = compare end) 30 | 31 | let complete n = 32 | let rec loop pat i = if i = n then pat else loop (add i pat) (i+1) in 33 | loop empty 0 34 | (* 35 | let pp = 36 | Fmt.braces (Fmt.iter ~sep:(Fmt.always ",@ ") iter Fmt.int) 37 | *) 38 | end 39 | 40 | include Set.Make (Pattern) 41 | 42 | (* 43 | let pp = 44 | Fmt.braces (Fmt.iter ~sep:(Fmt.always ",@ ") iter Pattern.pp) 45 | *) 46 | 47 | module V = struct 48 | type t = Pattern.t 49 | let equal = Pattern.equal 50 | let hash s = Hashtbl.hash (Pattern.elements s) 51 | end 52 | 53 | let is_strict_subset s1 s2 = 54 | Pattern.subset s1 s2 && not (Pattern.equal s1 s2) 55 | 56 | let iter_vertex = 57 | iter 58 | 59 | let iter_succ f g s = 60 | iter (fun s' -> if is_strict_subset s' s then f s') g 61 | 62 | let iter_pred f g s = 63 | iter (fun s' -> if is_strict_subset s s' then f s') g 64 | end 65 | 66 | module MPC = Minimalpathcover.Make (PatternSet) 67 | 68 | module PredicatePats : sig 69 | type t 70 | 71 | val empty : t 72 | 73 | val add : Syntax.relvar -> PatternSet.Pattern.t -> t -> t 74 | 75 | val map_to_list : (Syntax.relvar -> PatternSet.t -> 'a) -> t -> 'a list 76 | 77 | (* val pp : Format.formatter -> t -> unit *) 78 | end = struct 79 | module VarMap = Map.Make (Syntax.RelVar) 80 | 81 | type t = PatternSet.t VarMap.t 82 | 83 | let empty = VarMap.empty 84 | 85 | let pats pred t = 86 | match VarMap.find pred t with 87 | | exception Not_found -> PatternSet.empty 88 | | set -> set 89 | 90 | let add pred pat t = 91 | let set = pats pred t in 92 | VarMap.add pred (PatternSet.add pat set) t 93 | 94 | let map_to_list f t = 95 | VarMap.fold (fun p pats -> List.cons (f p pats)) t [] 96 | 97 | (* 98 | let pp = 99 | Fmt.iter_bindings VarMap.iter 100 | (Fmt.pair ~sep:(Fmt.always " => ") 101 | Syntax.pp_relvar 102 | PatternSet.pp) 103 | *) 104 | end 105 | 106 | let rec search_patterns_of_expr pats = function 107 | | Syntax.Select { relation; conditions; projections=_; cont } -> 108 | let pat = PatternSet.Pattern.of_list (List.map fst conditions) in 109 | let pats = PredicatePats.add relation pat pats in 110 | search_patterns_of_expr pats cont 111 | | Return _ -> 112 | pats 113 | | Guard_NotIn { relation; values; cont } -> 114 | let pat = PatternSet.Pattern.complete (Array.length values) in 115 | let pats = PredicatePats.add relation pat pats in 116 | search_patterns_of_expr pats cont 117 | 118 | let rec search_patterns_of_command pats = function 119 | | Syntax.WhileNotEmpty (_, comms) | DeclareBuffers (_, comms) -> 120 | search_patterns_of_commands pats comms 121 | | Insert (relvar, expr) -> 122 | (* account for the search needed for the membership test *) 123 | let pat = PatternSet.Pattern.complete relvar.Syntax.arity in 124 | let pats = PredicatePats.add relvar pat pats in 125 | search_patterns_of_expr pats expr 126 | | Swap _ | ReadRelation _ | WriteRelation _ -> 127 | pats 128 | 129 | and search_patterns_of_commands pats commands = 130 | List.fold_left search_patterns_of_command pats commands 131 | 132 | let search_patterns Syntax.{commands; _} = 133 | search_patterns_of_commands PredicatePats.empty commands 134 | 135 | let ordering_of_pattern_path arity pats = 136 | let included = Array.make arity false in 137 | let ordering = Array.make arity (-1) in 138 | let pos = ref 0 in 139 | pats |> List.iter begin fun pat -> 140 | let elems = PatternSet.Pattern.elements pat in 141 | elems |> List.iter begin fun idx -> 142 | if not included.(idx) then 143 | (ordering.(!pos) <- idx; included.(idx) <- true; incr pos) 144 | end 145 | end; 146 | included |> Array.iteri begin fun i visited -> 147 | if not visited then (ordering.(!pos) <- i; incr pos) 148 | end; 149 | assert (!pos = arity); 150 | ordering 151 | 152 | let orderings_of_patterns pred pats = 153 | let arity = pred.Syntax.arity in 154 | let pattern_paths = 155 | MPC.minimal_path_cover pats 156 | |> List.map List.rev 157 | |> List.map (ordering_of_pattern_path arity) 158 | |> Array.of_list 159 | in 160 | (pred, pattern_paths) 161 | 162 | (* FIXME: generate a Map, instead of an association list *) 163 | let indexes program : (Syntax.relvar * int array array) list = 164 | PredicatePats.map_to_list 165 | orderings_of_patterns 166 | (search_patterns program) 167 | 168 | (* 169 | let pp_indexes = 170 | Fmt.(brackets 171 | (list ~sep:(always ";@ ") 172 | (brackets 173 | (list ~sep:(always ";@ ") 174 | PatternSet.Pattern.pp)))) 175 | 176 | let pp_all_indexes = 177 | Fmt.(braces 178 | (list ~sep:(always ";@ ") 179 | (pair ~sep:(always " =>@ ") 180 | Syntax.pp_relvar 181 | pp_indexes))) 182 | *) 183 | 184 | let pp_orderings = 185 | Fmt.(brackets 186 | (array ~sep:(always ";@ ") 187 | (brackets 188 | (array ~sep:(always ";@ ") int)))) 189 | 190 | let pp_all_orderings = 191 | Fmt.(braces 192 | (list ~sep:(always ";@ ") 193 | (pair ~sep:(always " =>@ ") 194 | Syntax.pp_relvar 195 | pp_orderings))) 196 | -------------------------------------------------------------------------------- /relation_machine/indexes.mli: -------------------------------------------------------------------------------- 1 | val indexes : Syntax.program -> (Syntax.relvar * int array array) list 2 | 3 | val pp_all_orderings : (Syntax.relvar * int array array) list Fmt.t 4 | -------------------------------------------------------------------------------- /relation_machine/interpreter.ml: -------------------------------------------------------------------------------- 1 | module MakeEnv (K : Map.OrderedType) (T : sig type t end) : sig 2 | type t 3 | type value = T.t 4 | exception No_binding of K.t 5 | val empty : t 6 | val find : K.t -> t -> value 7 | val add : K.t -> value -> t -> t 8 | val iter : (K.t -> value -> unit) -> t -> unit 9 | end = struct 10 | module M = Map.Make (K) 11 | type t = T.t M.t 12 | type value = T.t 13 | exception No_binding of K.t 14 | let empty = M.empty 15 | let find k env = 16 | try M.find k env with Not_found -> raise (No_binding k) 17 | let add k v env = M.add k v env 18 | let iter = M.iter 19 | end 20 | 21 | module Relation : sig 22 | type t 23 | val create : int -> t 24 | val add : t -> int32 array -> unit 25 | val mem : t -> int32 array -> bool 26 | val iter : (int32 array -> unit) -> t -> unit 27 | val is_empty : t -> bool 28 | (* val clear : t -> unit *) 29 | (* val copy : t -> t *) 30 | end = struct 31 | module H = Hashtbl.Make 32 | (struct 33 | type t = int32 array 34 | let equal = (=) 35 | let hash = Hashtbl.hash 36 | end) 37 | type t = unit H.t 38 | let create n = H.create n 39 | let add rel tuple = H.add rel tuple () 40 | let mem rel tuple = H.mem rel tuple 41 | let iter f rel = H.iter (fun tuple () -> f tuple) rel 42 | let is_empty r = H.length r = 0 43 | (* let clear = H.clear *) 44 | (* let copy = H.copy *) 45 | end 46 | 47 | let pp_rel = 48 | Fmt.(braces 49 | (iter ~sep:(always ",@ ") Relation.iter 50 | (brackets (array ~sep:(always ",") int32)))) 51 | 52 | module Env = struct 53 | include MakeEnv (struct type t = Syntax.relvar let compare = compare end) (Relation) 54 | 55 | let pp = 56 | Fmt.iter_bindings ~sep:(Fmt.always ",@ ") iter 57 | (Fmt.pair ~sep:(Fmt.always " = ") Syntax.pp_relvar pp_rel) 58 | end 59 | 60 | module AttrEnv = MakeEnv (String) (struct type t = int32 end) 61 | 62 | open Syntax 63 | 64 | let eval_scalar attr_env = function 65 | | Attr attr -> AttrEnv.find attr attr_env 66 | | Lit v -> v 67 | 68 | let check_condition attr_env values (i, scalar) = 69 | values.(i) = eval_scalar attr_env scalar 70 | 71 | let rec eval_expr rel_env attr_env f = function 72 | | Return { values } -> 73 | let values = Array.map (eval_scalar attr_env) values in 74 | f values 75 | | Guard_NotIn { relation; values; cont } -> 76 | let values = Array.map (eval_scalar attr_env) values in 77 | let guard_relation = Env.find relation rel_env in 78 | if not (Relation.mem guard_relation values) then 79 | eval_expr rel_env attr_env f cont 80 | | Select { relation; conditions; projections; cont } -> 81 | let relation = Env.find relation rel_env in 82 | relation |> Relation.iter begin fun values -> 83 | if List.for_all (check_condition attr_env values) conditions then begin 84 | let attr_env = 85 | List.fold_left 86 | (fun attr_env (i, attr) -> AttrEnv.add attr values.(i) attr_env) 87 | attr_env 88 | projections 89 | in 90 | eval_expr rel_env attr_env f cont 91 | end 92 | end 93 | 94 | let rec eval_comm rel_env = function 95 | | ReadRelation (_relvar, _filename) -> 96 | failwith "interpreter: FIXME: implement LoadRelation" 97 | 98 | | WriteRelation (_relvar, _filename) -> 99 | failwith "interpreter: FIXME: implement WriteRelation" 100 | 101 | | WhileNotEmpty (rels, body) -> 102 | let rels = List.map (fun rel -> Env.find rel rel_env) rels in 103 | let rec loop () = 104 | if not (List.for_all Relation.is_empty rels) then 105 | (eval_comms rel_env body; loop ()) 106 | in 107 | loop () 108 | 109 | | Insert (rel, expr) -> 110 | let rel = Env.find rel rel_env in 111 | eval_expr rel_env AttrEnv.empty (Relation.add rel) expr 112 | 113 | | Swap _rel -> 114 | failwith "FIXME: impement buffers in the interpreter" 115 | (* 116 | | Move { tgt; src } -> 117 | let src = Env.find src rel_env 118 | and tgt = Env.find tgt rel_env 119 | in 120 | Relation.clear tgt; 121 | Relation.iter (Relation.add tgt) src; 122 | Relation.clear src 123 | *) 124 | | DeclareBuffers (inits, comms) -> 125 | let initialise rel_env rel = 126 | Env.add rel (Relation.create 128) rel_env 127 | in 128 | let rel_env = List.fold_left initialise rel_env inits in 129 | eval_comms rel_env comms 130 | 131 | and eval_comms rel_env comms = 132 | List.iter (eval_comm rel_env) comms 133 | 134 | (* 135 | let read_line arity line = 136 | let attrs = Array.make arity 0l in 137 | let rec read field_idx acc i = 138 | if field_idx >= arity then 139 | failwith "Too many fields"; 140 | if i = String.length line then 141 | (attrs.(field_idx) <- acc; 142 | attrs) 143 | else match line.[i] with 144 | | ',' -> 145 | attrs.(field_idx) <- acc; 146 | read (field_idx+1) 0l (i+1) 147 | | '0' .. '9' as c -> 148 | let d = Int32.of_int (Char.code c - Char.code '0') in 149 | read field_idx Int32.(add (mul acc 10l) d) (i+1) 150 | | _ -> 151 | failwith "Unrecognised character" 152 | in 153 | read 0 0l 0 154 | 155 | let load_csv_file filename arity = 156 | let ch = open_in filename in 157 | let rel = Relation.create 128 in 158 | let rec loop () = 159 | match input_line ch with 160 | | exception End_of_file -> () 161 | | line -> 162 | let tuple = read_line arity line in 163 | Relation.add rel tuple; 164 | loop () 165 | in 166 | try loop (); close_in ch; rel 167 | with e -> close_in ch; raise e 168 | *) 169 | 170 | let eval {relvars; commands} = 171 | let rel_env = Env.empty in 172 | (* 173 | let rel_env = 174 | List.fold_left 175 | (fun rel_env nm -> 176 | let rel = load_csv_file (nm.ident ^ ".csv") nm.arity in 177 | Env.add nm rel rel_env) 178 | rel_env 179 | edb_relvars 180 | in 181 | *) 182 | let rel_env = 183 | List.fold_left 184 | (fun rel_env nm -> Env.add nm (Relation.create 128) rel_env) 185 | rel_env 186 | relvars 187 | in 188 | eval_comms rel_env commands; 189 | rel_env 190 | -------------------------------------------------------------------------------- /relation_machine/interpreter.mli: -------------------------------------------------------------------------------- 1 | module Env : sig 2 | type t 3 | 4 | val pp : Format.formatter -> t -> unit 5 | end 6 | 7 | val eval : Syntax.program -> Env.t 8 | -------------------------------------------------------------------------------- /relation_machine/minimalpathcover.ml: -------------------------------------------------------------------------------- 1 | (** Compute minimal path coverings of directed simple graphs. *) 2 | 3 | module type G = sig 4 | type t 5 | 6 | module V : Graph.Sig.HASHABLE 7 | 8 | val iter_vertex : (V.t -> unit) -> t -> unit 9 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 10 | val iter_pred : (V.t -> unit) -> t -> V.t -> unit 11 | end 12 | 13 | module Make (G : G) : sig 14 | val minimal_path_cover : G.t -> G.V.t list list 15 | end = struct 16 | 17 | module Bipartite = struct 18 | type t = G.t 19 | 20 | module V = struct 21 | type t = 22 | | Src 23 | | Snk 24 | | Left of G.V.t 25 | | Right of G.V.t 26 | let equal x y = match x, y with 27 | | Src, Src -> true 28 | | Snk, Snk -> true 29 | | Left s, Left t -> G.V.equal s t 30 | | Right s, Right t -> G.V.equal s t 31 | | _ -> false 32 | let hash = function 33 | | Src -> 0 34 | | Snk -> 1 35 | | Left s -> 2*G.V.hash s+2 36 | | Right s -> 2*G.V.hash s+3 37 | end 38 | 39 | module E = struct 40 | type t = V.t * V.t 41 | type label = unit 42 | let label _ = () 43 | let src = fst 44 | let dst = snd 45 | end 46 | 47 | let iter_succ_e f g = function 48 | | V.Src -> 49 | G.iter_vertex (fun a -> f (V.Src, V.Left a)) g 50 | | V.Snk -> 51 | () 52 | | V.Left a as v -> 53 | G.iter_succ (fun b -> f (v, V.Right b)) g a 54 | | V.Right _ as v -> 55 | f (v, V.Snk) 56 | 57 | let iter_pred_e f g = function 58 | | V.Src -> 59 | () 60 | | V.Snk -> 61 | G.iter_vertex (fun b -> f (V.Right b, V.Snk)) g 62 | | V.Left _ as v -> 63 | f (V.Src, v) 64 | | V.Right b as v -> 65 | G.iter_pred (fun a -> f (V.Left a, v)) g b 66 | 67 | end 68 | 69 | module Flow = struct 70 | type t = int 71 | type label = unit 72 | let max_capacity _ = 1 73 | let min_capacity _ = 0 74 | let flow () = 0 75 | let add = (+) 76 | let sub = (-) 77 | let zero = 0 78 | let compare = Pervasives.compare 79 | end 80 | 81 | module F = Graph.Flow.Ford_Fulkerson (Bipartite) (Flow) 82 | 83 | module PathStore : sig 84 | type t 85 | val empty : G.t -> t 86 | val add_edge : t -> G.V.t * G.V.t -> unit 87 | val paths : t -> G.V.t list list 88 | end = struct 89 | module Table = Hashtbl.Make (G.V) 90 | 91 | type t = (G.V.t list * G.V.t) Table.t 92 | 93 | let concat (p1, _) (p2, c) = 94 | (p1 @ p2, c) 95 | 96 | let empty g = 97 | let ends = Table.create 12 in 98 | g |> G.iter_vertex begin fun v -> 99 | Table.add ends v ([v], v) 100 | end; 101 | ends 102 | 103 | let head_of_path (_, v) = v 104 | let tail_of_path (vs, _) = List.hd vs 105 | 106 | let add_edge table (v1, v2) = 107 | let p1 = Table.find table v1 in 108 | let p2 = Table.find table v2 in 109 | Table.remove table v1; 110 | Table.remove table v2; 111 | let p = concat p1 p2 in 112 | Table.replace table (head_of_path p) p; 113 | Table.replace table (tail_of_path p) p 114 | 115 | let paths t = 116 | Table.fold 117 | (fun v (p,_) l -> if G.V.equal (List.hd p) v then p::l else l) 118 | t 119 | [] 120 | end 121 | 122 | let minimal_path_cover g = 123 | let flow_f, _ = F.maxflow g Bipartite.V.Src Bipartite.V.Snk in 124 | let paths = PathStore.empty g in 125 | (* would be nice if there were a way to iterate only over edges 126 | with non-zero flow. *) 127 | g |> G.iter_vertex begin fun v -> 128 | G.iter_succ 129 | (fun v' -> 130 | if flow_f (Bipartite.V.Left v, Bipartite.V.Right v') = 1 then 131 | PathStore.add_edge paths (v,v')) 132 | g v 133 | end; 134 | PathStore.paths paths 135 | 136 | end 137 | -------------------------------------------------------------------------------- /relation_machine/minimalpathcover.mli: -------------------------------------------------------------------------------- 1 | module type G = sig 2 | type t 3 | 4 | module V : Graph.Sig.HASHABLE 5 | 6 | val iter_vertex : (V.t -> unit) -> t -> unit 7 | val iter_succ : (V.t -> unit) -> t -> V.t -> unit 8 | val iter_pred : (V.t -> unit) -> t -> V.t -> unit 9 | end 10 | 11 | module Make (G : G) : sig 12 | val minimal_path_cover : G.t -> G.V.t list list 13 | end 14 | -------------------------------------------------------------------------------- /relation_machine/of_rules.ml: -------------------------------------------------------------------------------- 1 | module Ruleset = Datalog.Ruleset 2 | 3 | open Syntax 4 | 5 | module RelvarSet = struct 6 | include (Set.Make (RelVar) : Set.S with type elt = relvar) 7 | 8 | let map_to_list f set = 9 | fold (fun x -> List.cons (f x)) set [] 10 | 11 | let concat_map_to_list f set = 12 | List.concat (map_to_list f set) 13 | end 14 | 15 | module AttrSet = 16 | (Set.Make (Attr) : Set.S with type elt = attr) 17 | 18 | 19 | let scalar_of_expr = function 20 | | Ruleset.Var x -> Attr x 21 | | Ruleset.Lit i -> Lit i 22 | | Ruleset.Underscore -> failwith "internal error: underscore found in head" 23 | 24 | let relvar_of_predname Ruleset.{ ident; arity } = 25 | { ident; arity } 26 | 27 | let predname_of_relvar { ident; arity } = 28 | Ruleset.{ ident; arity } 29 | 30 | let expr_of_rule guard_relation head atoms = 31 | let rec transl_rhs env = function 32 | | [] -> 33 | (* FIXME: assert that all the variables are in scope. *) 34 | (* FIXME: move to arrays earlier *) 35 | let values = List.map scalar_of_expr head in 36 | let reqd = 37 | List.fold_left 38 | (fun set -> function Attr a -> AttrSet.add a set | Lit _ -> set) 39 | AttrSet.empty 40 | values 41 | in 42 | assert (AttrSet.subset reqd env); 43 | let values = Array.of_list values in 44 | let expr = Return { values } in 45 | let expr = match guard_relation with 46 | | Some relation -> Guard_NotIn { relation; values; cont = expr } 47 | | None -> expr 48 | in 49 | expr, reqd 50 | 51 | | Ruleset.Atom {pred=relation; args} :: atoms -> 52 | let _, projections, conditions = 53 | List.fold_left 54 | (fun (i, projections, conditions) expr -> match expr with 55 | | Ruleset.Var x when AttrSet.mem x env -> 56 | (i+1, projections, (i,Attr x)::conditions) 57 | | Ruleset.Var x -> 58 | (i+1, (i, x)::projections, conditions) 59 | | Ruleset.Lit v -> 60 | (* FIXME: assert that 'v' is in scope *) 61 | (i+1, projections, (i,Lit v)::conditions) 62 | | Ruleset.Underscore -> 63 | (i+1, projections, conditions)) 64 | (0, [], []) 65 | args 66 | in 67 | let env = List.fold_right (fun (_,x) -> AttrSet.add x) projections env in 68 | let cont, reqd = transl_rhs env atoms in 69 | (* remove any attrs not in reqd from projections. *) 70 | let projections = 71 | List.filter (fun (_,x) -> AttrSet.mem x reqd) projections 72 | in 73 | let reqd = 74 | List.fold_left 75 | (fun reqd (_,x) -> AttrSet.remove x reqd) 76 | reqd 77 | projections 78 | in 79 | let reqd = 80 | List.fold_left 81 | (fun reqd (_, s) -> match s with 82 | | Attr vnm -> AttrSet.add vnm reqd 83 | | Lit _ -> reqd) 84 | reqd 85 | conditions 86 | in 87 | let relation = relvar_of_predname relation in 88 | Select {relation; projections; conditions; cont}, reqd 89 | in 90 | let expr, reqd = transl_rhs AttrSet.empty atoms in 91 | assert (AttrSet.is_empty reqd); 92 | expr 93 | 94 | let relvar_of_rule { Ruleset.pred; _ } = 95 | relvar_of_predname pred 96 | 97 | let translate_rule (Ruleset.{args; rhs; _} as rule) = 98 | let expr = expr_of_rule None args rhs in 99 | let rel = relvar_of_rule rule in 100 | Insert (rel, expr) 101 | 102 | let predicates_of_rules = 103 | List.fold_left 104 | (fun set rule -> RelvarSet.add (relvar_of_rule rule) set) 105 | RelvarSet.empty 106 | 107 | let select_all src = 108 | let projections = Array.init src.arity (fun i -> (i, Printf.sprintf "X%d" i)) in 109 | let values = Array.map (fun (_, nm) -> Attr nm) projections in 110 | Select { relation = src 111 | ; conditions = [] 112 | ; projections = Array.to_list projections 113 | ; cont = Return { values } 114 | } 115 | 116 | let mk_merge src tgt = 117 | (* FIXME: these insertions don't need to check for duplicates. Could 118 | have a flag that says 'dispense with the membership test'. *) 119 | Insert (tgt, select_all src) 120 | 121 | let buf_ relvar = 122 | { relvar with ident = "buf:" ^ relvar.ident } 123 | 124 | let extract_predicate dpred rhs = 125 | let rec loop before = function 126 | | [] -> 127 | [] 128 | | (Ruleset.Atom { pred; args } as atom) :: after -> 129 | let rest = loop (atom :: before) after in 130 | if relvar_of_predname pred = dpred then 131 | let hatom = Ruleset.Atom { pred = predname_of_relvar (buf_ dpred) 132 | ; args } in 133 | (hatom :: List.rev_append before after) :: rest 134 | else 135 | rest 136 | in 137 | loop [] rhs 138 | 139 | let translate_recursive rules = 140 | let predicates = predicates_of_rules rules in 141 | let buf_predicates = RelvarSet.map_to_list buf_ predicates in 142 | let initialisations = 143 | RelvarSet.map_to_list (fun pred_nm -> mk_merge pred_nm (buf_ pred_nm)) 144 | predicates in 145 | let swaps = List.map (fun nm -> Swap nm) buf_predicates in 146 | let updates = 147 | List.concat @@ 148 | List.map 149 | begin fun Ruleset.{pred; args; rhs} -> 150 | let pred = relvar_of_predname pred in 151 | RelvarSet.concat_map_to_list 152 | (fun delta'd_predicate -> 153 | List.map 154 | (fun rhs -> Insert (buf_ pred, expr_of_rule (Some pred) args rhs)) 155 | (extract_predicate delta'd_predicate rhs)) 156 | predicates 157 | end 158 | rules 159 | and merges = 160 | RelvarSet.map_to_list 161 | (fun nm -> mk_merge (buf_ nm) nm) 162 | predicates 163 | in 164 | DeclareBuffers 165 | (buf_predicates, 166 | initialisations @ 167 | swaps @ 168 | [ WhileNotEmpty (buf_predicates, updates @ swaps @ merges) ]) 169 | 170 | let translate_component = function 171 | | `Direct rule -> 172 | translate_rule rule 173 | | `Recursive rules -> 174 | translate_recursive rules 175 | 176 | let translate_rules ruleset = 177 | List.map translate_component (Ruleset.components ruleset) 178 | 179 | 180 | let translate ruleset = 181 | (* FIXME: restrict the scope of each predicate to only the rule 182 | evaluations it is needed for. *) 183 | List.fold_right 184 | (fun (pred_name, info) {relvars; commands} -> 185 | let relvar = relvar_of_predname pred_name in 186 | let prefix = 187 | match info.Ruleset.kind with 188 | | `Intensional -> 189 | [] 190 | | `Extensional filename -> 191 | [ReadRelation (relvar, filename)] 192 | in 193 | let suffix = 194 | List.map 195 | (fun filename -> WriteRelation (relvar, filename)) 196 | info.Ruleset.output 197 | in 198 | { relvars = relvar :: relvars 199 | ; commands = prefix @ commands @ suffix 200 | }) 201 | (Ruleset.predicates ruleset) 202 | { relvars = [] 203 | ; commands = translate_rules ruleset } 204 | -------------------------------------------------------------------------------- /relation_machine/of_rules.mli: -------------------------------------------------------------------------------- 1 | val translate : Datalog.Ruleset.ruleset -> Syntax.program 2 | -------------------------------------------------------------------------------- /relation_machine/syntax.ml: -------------------------------------------------------------------------------- 1 | type relvar = 2 | { ident : string 3 | ; arity : int 4 | } 5 | 6 | module RelVar = struct 7 | type t = relvar 8 | let compare = Pervasives.compare 9 | end 10 | 11 | type attr = string 12 | 13 | module Attr = struct 14 | type t = attr 15 | let compare = Pervasives.compare 16 | end 17 | 18 | type scalar = 19 | | Attr of attr 20 | | Lit of int32 21 | 22 | type expr = 23 | | Return of 24 | { values : scalar array 25 | } 26 | | Guard_NotIn of 27 | { relation : relvar 28 | ; values : scalar array 29 | ; cont : expr 30 | } 31 | | Select of 32 | { relation : relvar 33 | ; conditions : (int * scalar) list 34 | ; projections : (int * attr) list 35 | ; cont : expr 36 | } 37 | 38 | type comm = 39 | | ReadRelation of relvar * string 40 | | WriteRelation of relvar * string 41 | | WhileNotEmpty of relvar list * comms 42 | | Insert of relvar * expr 43 | | Swap of relvar 44 | | DeclareBuffers of relvar list * comms 45 | 46 | and comms = comm list 47 | 48 | type program = 49 | { relvars : relvar list 50 | ; commands : comms 51 | } 52 | 53 | (**********************************************************************) 54 | let pp_scalar fmt = function 55 | | Attr attr -> Format.pp_print_string fmt attr 56 | | Lit i -> Format.fprintf fmt "%ld" i 57 | 58 | let merge_projections_conditions arity conditions projections = 59 | let conditions = List.sort (fun (i,_) (j,_) -> compare i j) conditions in 60 | let projections = List.sort (fun (i,_) (j,_) -> compare i j) projections in 61 | let rec loop i conds projs rev_merged = 62 | if i = arity then 63 | List.rev rev_merged 64 | else 65 | match conds, projs with 66 | | _, (j, x)::projs when i = j -> 67 | loop (i+1) conds projs (`Bind x::rev_merged) 68 | | (j, x)::conds, _ when i = j -> 69 | loop (i+1) conds projs (`Match x::rev_merged) 70 | | _ -> 71 | loop (i+1) conds projs (`Ignore::rev_merged) 72 | in 73 | loop 0 conditions projections [] 74 | 75 | let pp_matcher fmt = function 76 | | `Match x -> Format.fprintf fmt "=%a" pp_scalar x 77 | | `Bind x -> Format.fprintf fmt "?%s" x 78 | | `Ignore -> Format.fprintf fmt "?_" 79 | 80 | let pp_matching_spec = 81 | Fmt.(parens (list ~sep:(always ", ") pp_matcher)) 82 | 83 | let pp_relvar fmt { ident; arity } = 84 | Format.fprintf fmt "%s/%d" ident arity 85 | 86 | let rec pp_expr fmt = function 87 | | Return {values} -> 88 | Format.fprintf fmt "(@[%a@])" 89 | Fmt.(array ~sep:(always ",@ ") pp_scalar) values 90 | | Guard_NotIn { relation; values; cont } -> 91 | Format.fprintf fmt "where (@[%a@]) not in %a;@ %a" 92 | Fmt.(array ~sep:(always ",@ ") pp_scalar) values 93 | pp_relvar relation 94 | pp_expr cont 95 | | Select { relation; conditions; projections; cont } -> 96 | Format.fprintf fmt 97 | "@[select @[%a from %a@];@]@ %a" 98 | pp_matching_spec (merge_projections_conditions 99 | relation.arity 100 | conditions 101 | projections) 102 | pp_relvar relation 103 | pp_expr cont 104 | 105 | let rec pp_comm fmt = function 106 | | ReadRelation (relvar, filename) -> 107 | Format.fprintf fmt "load %S into %a;" 108 | filename 109 | pp_relvar relvar 110 | | WriteRelation (relvar, filename) -> 111 | Format.fprintf fmt "save %a to %S;" 112 | pp_relvar relvar 113 | filename 114 | | WhileNotEmpty (rels, body) -> 115 | Format.fprintf fmt "while_not_empty (@[%a@])@ {@[@,%a@]@,}" 116 | Fmt.(list ~sep:(always ",@ ") pp_relvar) rels 117 | pp_comms body 118 | | Insert (rel, expr) -> 119 | Format.fprintf fmt "@[%a +=@ { @[%a@] };@]" 120 | pp_relvar rel 121 | pp_expr expr 122 | | Swap relvar -> 123 | Format.fprintf fmt "swap %a;" 124 | pp_relvar relvar 125 | | DeclareBuffers (initialisers, body) -> 126 | Format.fprintf fmt "with_buffers (@[%a@])@ {@[@,%a@]@,}" 127 | Fmt.(list ~sep:(always ",@ ") pp_relvar) initialisers 128 | pp_comms body 129 | 130 | and pp_comms fmt = 131 | Fmt.(list ~sep:(always "@,@,") pp_comm) fmt 132 | 133 | let pp_program fmt {relvars; commands} = 134 | let pp_relvar_decl fmt nm = 135 | Format.fprintf fmt "var %a;@," pp_relvar nm 136 | in 137 | Format.fprintf fmt "@[%a@,%a@]" 138 | Fmt.(list ~sep:(always "") pp_relvar_decl) relvars 139 | pp_comms commands 140 | -------------------------------------------------------------------------------- /relation_machine/syntax.mli: -------------------------------------------------------------------------------- 1 | type relvar = 2 | { ident : string 3 | ; arity : int 4 | } 5 | 6 | module RelVar : sig 7 | type t = relvar 8 | val compare : t -> t -> int 9 | end 10 | 11 | type attr = string 12 | 13 | module Attr : sig 14 | type t = attr 15 | val compare : t -> t -> int 16 | end 17 | 18 | type scalar = 19 | | Attr of attr 20 | | Lit of int32 21 | 22 | type expr = 23 | | Return of 24 | { values : scalar array 25 | } 26 | | Guard_NotIn of 27 | { relation : relvar 28 | ; values : scalar array 29 | ; cont : expr 30 | } 31 | | Select of 32 | { relation : relvar 33 | ; conditions : (int * scalar) list 34 | ; projections : (int * attr) list 35 | ; cont : expr 36 | } 37 | 38 | type comm = 39 | | ReadRelation of relvar * string 40 | (** Read a csv file and insert all the tuples into the named 41 | relation variable. *) 42 | 43 | | WriteRelation of relvar * string 44 | (** Write all the tuples in the named relation to the file in CSV 45 | format, overwriting what was there before. *) 46 | 47 | | WhileNotEmpty of relvar list * comms 48 | (** Loop until all the relations in the named variables are 49 | empty. *) 50 | 51 | | Insert of relvar * expr 52 | (** Insert the results of the expression into the named 53 | variable. *) 54 | 55 | | Swap of relvar 56 | (** Swap the named read/write buffer. *) 57 | 58 | | DeclareBuffers of relvar list * comms 59 | 60 | and comms = 61 | comm list 62 | 63 | type program = 64 | { relvars : relvar list 65 | ; commands : comms 66 | } 67 | 68 | val pp_relvar : Format.formatter -> relvar -> unit 69 | 70 | val pp_program : Format.formatter -> program -> unit 71 | -------------------------------------------------------------------------------- /safety_test.mlog: -------------------------------------------------------------------------------- 1 | (* a non safe predicate definition *) 2 | 3 | define 4 | nonsafe : int 5 | nonsafe (_) -------------------------------------------------------------------------------- /simple.mlog: -------------------------------------------------------------------------------- 1 | define 2 | a : int 3 | a(?x) :- b(?x), c(?x) 4 | 5 | and b : int 6 | b(1) 7 | b(?x) :- c(?x), d(?x) 8 | 9 | and c : int 10 | c(2) 11 | c(?x) :- b(?x), d(?x) 12 | 13 | and d : int 14 | d(3) 15 | -------------------------------------------------------------------------------- /with_test1.mlog: -------------------------------------------------------------------------------- 1 | module type X = sig type t end with type t = int -------------------------------------------------------------------------------- /with_test2.mlog: -------------------------------------------------------------------------------- 1 | module type X = sig type t end 2 | 3 | module type Y = X with type t = int * int 4 | -------------------------------------------------------------------------------- /with_test3.mlog: -------------------------------------------------------------------------------- 1 | module type X = functor (P : sig end) -> sig end 2 | 3 | module type Y = X with type t = int 4 | -------------------------------------------------------------------------------- /with_test4.mlog: -------------------------------------------------------------------------------- 1 | module type X = sig type t end with type u = int 2 | -------------------------------------------------------------------------------- /with_test5.mlog: -------------------------------------------------------------------------------- 1 | module type X = sig type t = int end with type t = int * int --------------------------------------------------------------------------------