├── .editorconfig ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── c-support └── runtime │ ├── LDST.c │ ├── LDST.h │ ├── LDST_concurrent.c │ ├── LDST_debug.h │ ├── LDST_serial.c │ ├── thpool.c │ └── thpool.h ├── examples ├── add.ldgv ├── case-singleton.ldgv ├── casesub.ldgv ├── casetest.ldgv ├── cast-bot.ldgv ├── cast-collide.ldgv ├── cast-fail.ldgv ├── casts.ccldgv ├── depcast.ccldgv ├── depsum.ldgv ├── example-inputs.txt ├── gradualtest.ldgv ├── just-f2.ccldgv ├── just-f3.ccldgv ├── mymap.gldgv ├── natsum.ldgv ├── natsum2-new.ldgv ├── natsum2-rec.ldgv ├── natsum2.ldgv ├── node.ldgv ├── node.out ├── noderec.ldgv ├── person.gldgv ├── simple.ldgv ├── simple_recursion.ldgv ├── tclient.ldgv ├── tclient.out ├── tserver.ldgv ├── tserver.out └── type-equivalence.txt ├── exe ├── Main.hs └── Output.hs ├── ldgv.cabal ├── package.yaml ├── src ├── C │ ├── CPS.hs │ ├── Compile.hs │ ├── Generate.hs │ └── MonadStack.hs ├── Config.hs ├── Examples.hs ├── Interpreter.hs ├── Kinds.hs ├── Parsing.hs ├── Parsing │ ├── Grammar.y │ └── Tokens.x ├── PrettySyntax.hs ├── ProcessEnvironment.hs ├── Syntax.hs ├── TCSubtyping.hs ├── TCTyping.hs ├── TCXMonad.hs └── Typechecker.hs ├── stack.yaml ├── syntax.txt └── test ├── ArithmeticSpec.hs ├── CSpec.hs ├── CcldlcSpec.hs ├── FunctionApplicationSpec.hs ├── FunctionSignaturesSpec.hs ├── InterpreterSpec.hs ├── LdlcSpec.hs ├── Spec.hs ├── TypecheckerSpec.hs ├── Utils.hs ├── UtilsFuncCcldlc.hs └── inputs ├── case1.ldgv └── case2.ldgv /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | indent_style = space 5 | indent_size = 2 6 | end_of_line = lf 7 | charset = utf-8 8 | trim_trailing_whitespace = true 9 | insert_final_newline = false 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | *~ 24 | .DS_Store 25 | *.swp 26 | stack.yaml.lock 27 | result 28 | .DS_Store 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2019 - 2021, Chair of Programming Languages, Uni Freiburg 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | 32 | ----------------------------------------------------------------------------- 33 | This Project is partly based on Github Corners (https://tholman.com/github-corners/) 34 | 35 | The MIT License (MIT) 36 | 37 | Copyright (c) 2016 Tim Holman 38 | 39 | Permission is hereby granted, free of charge, to any person obtaining a copy of 40 | this software and associated documentation files (the "Software"), to deal in 41 | the Software without restriction, including without limitation the rights to 42 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 43 | of the Software, and to permit persons to whom the Software is furnished to do so, 44 | subject to the following conditions: 45 | 46 | The above copyright notice and this permission notice shall be included in all 47 | copies or substantial portions of the Software. 48 | 49 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 50 | INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A 51 | PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 52 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 53 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 54 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 55 | 56 | 57 | ----------------------------------------------------------------------------- 58 | The C-Backend uses C-Thread-Pool by Pithikos (https://github.com/Pithikos/C-Thread-Pool) 59 | 60 | The MIT License (MIT) 61 | 62 | Copyright (c) 2016 Johan Hanssen Seferidis 63 | 64 | Permission is hereby granted, free of charge, to any person obtaining a copy 65 | of this software and associated documentation files (the "Software"), to deal 66 | in the Software without restriction, including without limitation the rights 67 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 68 | copies of the Software, and to permit persons to whom the Software is 69 | furnished to do so, subject to the following conditions: 70 | 71 | The above copyright notice and this permission notice shall be included in all 72 | copies or substantial portions of the Software. 73 | 74 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 75 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 76 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 77 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 78 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 79 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 80 | SOFTWARE. 81 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ldgv - Label dependent session types 2 | 3 | This repository contains an implementation of a frontend (parser and 4 | type checker), an interpreter and a C backend for LDGV. 5 | 6 | LDGV stands for _Label Dependency_ an _Gay & Vasconcelos_, the authors of multiple papers about _Session Types_. It mainly implements [Label-Dependent Session Types](https://doi.org/10.1145/3371135). It additionally includes an implementation of the _Cast Calculus_ from [Label-Dependent Lambda Calculus and Gradual Typing](https://doi.org/10.1145/3485485). 7 | 8 | The syntax is described in `syntax.txt`. The directory `examples/` 9 | contains some examples, source files end in `.ldgv`. 10 | 11 | Compilation is done via [Stack](https://docs.haskellstack.org/), which you need to have installed. You may either compile and run LDGV by `stack run ldgv` (**recommended**). Or you install LDGV by `stack install`, essentially copying the executable `ldgv` to your `$PATH`. 12 | 13 | ## Interpreter 14 | 15 | Running the interpreter is possible via its command line interface 16 | 17 | ```stack run ldgv -- interpret``` 18 | 19 | resp. `ldgv interpret`. 20 | 21 | ## C backend 22 | 23 | The C backend is nearly feature complete, but missing a garbage collector and 24 | tests. 25 | 26 | It is available only via the [command line](#command-line). See there for 27 | building and running. 28 | 29 | ### Compiling the generated C code 30 | 31 | The generated C code is dependent on the files in `c-support/runtime/`: 32 | 33 | * `LDST.h` defines the data structures and interfaces to the scheduler and 34 | channel handler. 35 | * `LDST.c` contains implementations of helper functions for which there is no 36 | need to generate them every time. 37 | * `LDST_serial.c` contains a serial implementation of a scheduler and channel 38 | handler. Contexts in this implementation are not thread-safe. 39 | * `LDST_concurrent.c` contains a concurrent implementation using a threadpool. 40 | Its size can be determined at compile time by defining 41 | `LDST_THREADPOOL_SIZE`, the default is four. 42 | * `thpool.h`, `thpool.c` come from [Pithikos/C-Thread-Pool][] and are used in 43 | the concurrent scheduler and channel handler implementation. 44 | 45 | [Pithikos/C-Thread-Pool]: https://github.com/Pithikos/C-Thread-Pool 46 | 47 | The generated code requires C11 support and the concurrent runtime requires 48 | support for the C11 atomics library and pthreads. 49 | 50 | When compiling the generated code an optimization level of at least `-O2` 51 | should be considered, with this the common compilers (clang, gcc) will 52 | transform the abundant number of tail calls into jumps which will keep the 53 | stack size from exploding. 54 | 55 | The command line executable has support for invoking the C compiler on the 56 | generated source code by passing either `-O` or `-L` on the command line, see 57 | the output `compile --help` for more information. 58 | 59 | ### Integrating and using the generated C code 60 | 61 | Every top level definition in the source file will correspond to a symbol of 62 | type `LDST_fp0_t` (see `LDST.h`) with `ldst_` prepended. Additional 63 | transformations are applied to support primes in function names: a `q` is 64 | replaced by `qq` and a prime is replaced by `qQ`. 65 | 66 | The top-level functions should *not* be called directly but only through 67 | `LDST_fork` due to the interaction with the scheduler when using channel 68 | operations. There exist `LDST_run` and `LDST_main` to help with the execution 69 | of top level functions which don't exist as closures. See `LDST.h` for 70 | documentation of these. 71 | 72 | Using the option `-m IDENT / --main=IDENT` with the command line C backend emit 73 | a `int main(void)` function at the end of the resulting C code which executes 74 | `IDENT` and prints the result. See the output of `$LDGV compile --help` for 75 | more information. 76 | 77 | Multiple LDST files can be compiled separatly and then linked together. It is 78 | also possible to write functions in C and use them in LDST. The function has to 79 | properly curried, the top level symbol must have a type signature matching 80 | `LDST_fp0_t` and the name must match the name transformations pointed out 81 | above. (NB: this allows to subvert the type system, in all good and bad ways.) 82 | 83 | ## Testing 84 | 85 | You can run the full test suite by: 86 | 87 | ``` 88 | stack test 89 | ``` 90 | 91 | ## Web Page (Deprecated) 92 | 93 | There was a web version availabe, using [ghcjs](https://github.com/ghcjs/ghcjs) and the [reflex-platform](https://github.com/reflex-frp/reflex-platform). Because of some regression, presumably in some dependency of _reflex_, it is currently not available. Code and artifacts were factored out and moved to branch [browser-support](https://github.com/leyhline/ldgv/tree/browser-support). -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /c-support/runtime/LDST.c: -------------------------------------------------------------------------------- 1 | // 2 | // LDST.c 3 | // 4 | // Supporting functions. 5 | // 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include "LDST.h" 13 | #include "LDST_debug.h" 14 | 15 | struct SyncInfo { 16 | LDST_t *result; 17 | union { 18 | LDST_lam_t op; 19 | bool has_result; 20 | }; 21 | }; 22 | 23 | static LDST_res_t assign_k(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t val) { 24 | struct SyncInfo *info = vinfo; 25 | 26 | LOG("assigning to " PTR_FMT " (&result=" PTR_FMT ")", PTR_VAL(info), PTR_VAL(info->result)); 27 | *info->result = val; 28 | info->has_result = true; 29 | return LDST_invoke(k, ctxt, val); 30 | } 31 | 32 | static LDST_res_t assign(LDST_cont_t *then_k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t arg) { 33 | LDST_cont_t *k = malloc(sizeof(LDST_cont_t)); 34 | if (!k) 35 | return LDST_NO_MEM; 36 | 37 | struct SyncInfo *info = vinfo; 38 | LDST_lam_t op = info->op; 39 | info->has_result = false; 40 | k->k_lam.lam_fp = assign_k; 41 | k->k_lam.lam_closure = info; 42 | k->k_next = then_k; 43 | return op.lam_fp(k, ctxt, op.lam_closure, arg); 44 | } 45 | 46 | LDST_res_t LDST_sync(LDST_ctxt_t *ctxt, LDST_t *result, LDST_lam_t op, LDST_t arg) { 47 | LDST_res_t res; 48 | struct SyncInfo info = { result, { .op = op } }; 49 | LDST_lam_t assign_op = { assign, &info }; 50 | 51 | LOG("beginning sync " PTR_FMT " (&result=" PTR_FMT ")", PTR_VAL(&info), PTR_VAL(result)); 52 | res = LDST_fork(ctxt, assign_op, arg); 53 | if (res != LDST_OK) 54 | return res; 55 | 56 | res = LDST_context_wait(ctxt); 57 | if (res != LDST_OK) 58 | return res; 59 | 60 | return info.has_result ? LDST_OK : LDST_NO_RESULT; 61 | } 62 | 63 | struct RunInfo { 64 | int n; 65 | LDST_t *args; 66 | }; 67 | 68 | static LDST_res_t run_impl(LDST_cont_t *k_then, LDST_ctxt_t *ctxt, void *run_info, LDST_t value) { 69 | struct RunInfo *info = run_info; 70 | LDST_cont_t *k_now = k_then; 71 | 72 | if (info->n > 1) { 73 | // Create a new continuation to apply the remaining arguments is required. 74 | struct RunInfo *new_info = malloc(sizeof *new_info); 75 | if (!new_info) { 76 | return LDST_NO_MEM; 77 | } 78 | 79 | k_now = malloc(sizeof(LDST_cont_t)); 80 | if (!k_now) { 81 | free(new_info); 82 | return LDST_NO_MEM; 83 | } 84 | 85 | new_info->n = info->n - 1; 86 | new_info->args = info->args + 1; 87 | k_now->k_lam.lam_fp = run_impl; 88 | k_now->k_lam.lam_closure = new_info; 89 | k_now->k_next = k_then; 90 | } 91 | 92 | LDST_lam_t lam = value.val_lam; 93 | return lam.lam_fp(k_now, ctxt, lam.lam_closure, info->args[0]); 94 | } 95 | 96 | static LDST_res_t run_impl0(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *run_info, LDST_t value) { 97 | LDST_fp0_t fp = (LDST_fp0_t)value.val_lam.lam_fp; 98 | 99 | if (run_info) { 100 | LDST_cont_t *k_new = malloc(sizeof *k_new); 101 | k_new->k_next = k; 102 | k_new->k_lam.lam_fp = run_impl; 103 | k_new->k_lam.lam_closure = run_info; 104 | k = k_new; 105 | } 106 | 107 | return fp(k, ctxt); 108 | } 109 | 110 | LDST_res_t LDST_run(LDST_ctxt_t *ctxt, LDST_t *result, LDST_fp0_t f, int n, LDST_t *args) { 111 | struct RunInfo *info = 0; 112 | if (n > 0) { 113 | info = malloc(sizeof *info); 114 | 115 | if (!info) 116 | return LDST_NO_MEM; 117 | 118 | info->n = n; 119 | info->args = args; 120 | } 121 | 122 | LDST_lam_t lambda = { run_impl0, info }; 123 | LDST_t arg0 = { .val_lam = { (LDST_fp_t)f, 0 } }; 124 | return LDST_sync(ctxt, result, lambda, arg0); 125 | } 126 | 127 | LDST_t LDST_main(LDST_fp0_t f) { 128 | LDST_t result; 129 | LDST_ctxt_t *ctxt = LDST_context_create(); 130 | LDST_res_t err = ctxt ? LDST_run(ctxt, &result, f, 0, 0) : LDST_NO_MEM; 131 | 132 | switch (err) { 133 | case LDST_OK: 134 | return result; 135 | case LDST_NO_MEM: 136 | fputs("error: out of memory\n", stderr); 137 | break; 138 | case LDST_DEADLOCK: 139 | fputs("error: deadlocked\n", stderr); 140 | break; 141 | case LDST_UNMATCHED_LABEL: 142 | fputs("error: unmatched label\n", stderr); 143 | break; 144 | case LDST_NO_RESULT: 145 | fputs("error: result not available\n", stderr); 146 | break; 147 | default: 148 | fputs("error: unknown error\n", stderr); 149 | break; 150 | } 151 | exit(err); 152 | } 153 | 154 | static LDST_res_t nat_fold_k(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *void_closure, LDST_t v) { 155 | // closure[0] = f 156 | // closure[1] = n 157 | // closure[2] = i 158 | // closure[3] = a 159 | LDST_t *closure = void_closure; 160 | 161 | LDST_cont_t *new_k = malloc(sizeof(LDST_cont_t)); 162 | if (!new_k) 163 | return LDST_NO_MEM; 164 | 165 | new_k->k_lam.lam_fp = LDST_nat_fold; 166 | new_k->k_lam.lam_closure = closure; 167 | new_k->k_next = k; 168 | 169 | LDST_t a = closure[3]; 170 | LDST_lam_t f = v.val_lam; 171 | return f.lam_fp(new_k, ctxt, f.lam_closure, a); 172 | } 173 | 174 | /* 175 | * natrec n { z, n'. T. (a : T). e } ~ foldr (\n' a -> e) z n 176 | * 177 | * ==> Pseudo Haskell (f == \n' a. e) 178 | * 179 | * nat-fold f n z = go 0 z 180 | * where go i a = if n == i then a else go (i+1) (f i a) 181 | * 182 | * ==> Eta reduction, explicit currying, capture lists 183 | * 184 | * nat-fold f n = go [f n i=0] 185 | * go [f n i] a = if n == i then a else go [f n i=i-1] (f i a) 186 | * 187 | * This function (`ldst_nat_fold`) directly corresponds to `go` (first 188 | * argument already applied) and therefore has to be called with the correct 189 | * closure: A list of three values in the order of `f`, `n`, `i`. 190 | */ 191 | LDST_res_t LDST_nat_fold(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *void_closure, LDST_t a) { 192 | // closure[0] = f 193 | // closure[1] = n 194 | // closure[2] = i 195 | LDST_t *closure = void_closure; 196 | int n = closure[1].val_int; 197 | int i = closure[2].val_int; 198 | 199 | if (n == i) 200 | return LDST_invoke(k, ctxt, a); 201 | 202 | // The closure is reused both for the continuation and in there (see 203 | // `nat_fold_k`) it is also used as the closure to the recusive call to 204 | // `ldst_nat_fold` (this function). 205 | LDST_t *new_closure = malloc(4 * sizeof(LDST_t)); 206 | if (!new_closure) 207 | return LDST_NO_MEM; 208 | 209 | LDST_cont_t *new_k = malloc(sizeof(LDST_cont_t)); 210 | if (!new_k) { 211 | free(new_closure); 212 | return LDST_NO_MEM; 213 | } 214 | 215 | LDST_lam_t f = closure[0].val_lam; 216 | new_closure[0].val_lam = f; 217 | new_closure[1].val_int = n; 218 | new_closure[2].val_int = i + 1; 219 | new_closure[3] = a; 220 | 221 | new_k->k_lam.lam_fp = nat_fold_k; 222 | new_k->k_lam.lam_closure = new_closure; 223 | new_k->k_next = k; 224 | 225 | LDST_t idx = { .val_int = i }; 226 | return f.lam_fp(new_k, ctxt, f.lam_closure, idx); 227 | } 228 | 229 | // The recv operator returns a pair where the first element is the received 230 | // value and the second element is the "new" channel. 231 | LDST_res_t LDST_make_recv_result(LDST_chan_t *chan, LDST_t value, LDST_t *result) { 232 | LDST_t *received_pair = malloc(2 * sizeof(LDST_t)); 233 | if (!received_pair) 234 | return LDST_NO_MEM; 235 | 236 | received_pair[0] = value; 237 | received_pair[1].val_chan = chan; 238 | result->val_pair = received_pair; 239 | return LDST_OK; 240 | } 241 | 242 | struct CurryInfo { 243 | LDST_lam_t dest; 244 | int captured_count; 245 | int remaining_count; 246 | LDST_t captures[]; 247 | }; 248 | 249 | static LDST_res_t curry_impl(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *closure, LDST_t arg) { 250 | struct CurryInfo *info = closure; 251 | assert(info->remaining_count > 0 && "no arguments left to curry"); 252 | 253 | int old_capture_size = info->captured_count * sizeof(LDST_t); 254 | int new_capture_size = old_capture_size + sizeof(LDST_t); 255 | 256 | if (info->remaining_count == 1) { 257 | // `arg` is the last remaining argument, meaning we can now invoke the 258 | // function. 259 | LDST_t *captures = malloc(new_capture_size); 260 | if (!captures) 261 | return LDST_NO_MEM; 262 | 263 | memcpy(captures, info->captures, old_capture_size); 264 | captures[info->captured_count] = arg; 265 | 266 | arg.val_pair = captures; 267 | return info->dest.lam_fp(k, ctxt, info->dest.lam_closure, arg); 268 | } 269 | 270 | struct CurryInfo *new_info = malloc(sizeof *new_info + new_capture_size); 271 | if (!new_info) 272 | return LDST_NO_MEM; 273 | 274 | new_info->dest = info->dest; 275 | new_info->captured_count = info->captured_count + 1; 276 | new_info->remaining_count = info->remaining_count - 1; 277 | memcpy(new_info->captures, info->captures, old_capture_size); 278 | new_info->captures[info->captured_count] = arg; 279 | 280 | LDST_t result = { .val_lam = { curry_impl, new_info } }; 281 | return LDST_invoke(k, ctxt, result); 282 | } 283 | 284 | LDST_res_t LDST_curry(LDST_t *value, LDST_lam_t uncurried, int n) { 285 | if (n < 1) { 286 | // The function has to take at least one argument. 287 | return LDST_ERR_UNKNOWN; 288 | } 289 | 290 | struct CurryInfo *info = malloc(sizeof *info); 291 | if (!info) { 292 | return LDST_NO_MEM; 293 | } 294 | 295 | info->dest = uncurried; 296 | info->captured_count = 0; 297 | info->remaining_count = n; 298 | 299 | value->val_lam.lam_fp = curry_impl; 300 | value->val_lam.lam_closure = info; 301 | return LDST_OK; 302 | } 303 | -------------------------------------------------------------------------------- /c-support/runtime/LDST.h: -------------------------------------------------------------------------------- 1 | // 2 | // LDST.h 3 | // 4 | // Public interface to the LDST backends. 5 | 6 | #ifndef LDST_H__ 7 | #define LDST_H__ 8 | 9 | #include 10 | #include 11 | 12 | #ifdef __cplusplus 13 | extern "C" { 14 | #endif 15 | 16 | /***************************************************************************** 17 | * Type Definitions * 18 | *****************************************************************************/ 19 | 20 | typedef union LDST_val LDST_t; 21 | typedef struct LDST_lam LDST_lam_t; 22 | typedef struct LDST_cont LDST_cont_t; 23 | typedef struct LDST_chan LDST_chan_t; 24 | typedef struct LDST_ctxt LDST_ctxt_t; 25 | 26 | typedef enum LDST_res { 27 | LDST_OK, 28 | LDST_NO_MEM, // Allocation failure 29 | LDST_DEADLOCK, // Deadlock detected 30 | LDST_UNMATCHED_LABEL, // Match on an unhandled label 31 | LDST_NO_RESULT, // The continuation was never invoked for `LDST_sync` 32 | LDST_ERR_UNKNOWN, // Some other error occured 33 | } LDST_res_t; 34 | 35 | typedef LDST_res_t (*LDST_fp0_t)(LDST_cont_t *k, LDST_ctxt_t *ctxt); 36 | typedef LDST_res_t (*LDST_fp_t)(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *closure, LDST_t arg); 37 | 38 | struct LDST_lam { 39 | LDST_fp_t lam_fp; 40 | void *lam_closure; 41 | }; 42 | 43 | struct LDST_cont { 44 | LDST_lam_t k_lam; 45 | LDST_cont_t *k_next; 46 | }; 47 | 48 | union LDST_val { 49 | int val_int; 50 | double val_double; 51 | LDST_lam_t val_lam; 52 | LDST_t *val_pair; 53 | LDST_chan_t *val_chan; 54 | const char *val_label; 55 | }; 56 | 57 | 58 | /***************************************************************************** 59 | * Context Handling * 60 | *****************************************************************************/ 61 | 62 | // Creates a new context which can be used to run LDST functions. 63 | // 64 | // If this function returns `NULL` context creation should be considered 65 | // failed. 66 | LDST_ctxt_t *LDST_context_create(void); 67 | 68 | // Wait until all operations associated with this context have terminated. 69 | LDST_res_t LDST_context_wait(LDST_ctxt_t *context); 70 | 71 | // Destroys the given context. 72 | // 73 | // After a context has been destroyed it may not be used as an argument to any 74 | // of the `LDST_...` functions or any generated `ldst_...` function, including 75 | // `LDST_context_destroy`. It is safe to pass `NULL` to this function. 76 | // 77 | // This also invalidates all values and channels created with this context or 78 | // returned from running functions using this context. 79 | void LDST_context_destroy(LDST_ctxt_t *context); 80 | 81 | 82 | /***************************************************************************** 83 | * Backend Interface * 84 | *****************************************************************************/ 85 | 86 | // Creates a new channel. 87 | LDST_res_t LDST_chan_new(LDST_ctxt_t *ctxt, LDST_chan_t **chan); 88 | 89 | // Sends a value down a channel. 90 | // 91 | // The `channel` should be a channel obtained through a call to 92 | // `ldst_chan_new`. It is of type `void*` to fit the `LDST_fp_t` prototype. 93 | // 94 | // The continuation `k` will be invoked with a value of `val_chan` passing the 95 | // `channel` argument given to this function. 96 | LDST_res_t LDST_chan_send(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *channel, LDST_t value); 97 | 98 | // Receives a value from a channel. 99 | // 100 | // The continuation `k` will be invoked with a pair of the passed channel and the 101 | // recieved value. 102 | LDST_res_t LDST_chan_recv(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *channel); 103 | 104 | // Forks execution of the given lambda. 105 | LDST_res_t LDST_fork(LDST_ctxt_t *ctxt, LDST_lam_t op, LDST_t value); 106 | 107 | 108 | /***************************************************************************** 109 | * Supporting Functions * 110 | *****************************************************************************/ 111 | 112 | // Runs the given top level function `f` by applying the `n` arguments in 113 | // `args` and storing the result in `result`. 114 | // 115 | // `result` should point to a valid memory location. 116 | // 117 | // If `n` is zero, `args` may be the null pointer. If the result is a lambda 118 | // function, channel or pair containing either of these, `args` has to be valid 119 | // for as long as `result` is valid. Otherwise `args` must only be valid for 120 | // the duration of the call to `ldst_run`. 121 | LDST_res_t LDST_run(LDST_ctxt_t *ctxt, LDST_t *result, LDST_fp0_t f, int n, LDST_t *args); 122 | 123 | // Curries the given function and stores the result in `value`. 124 | // 125 | // `n` is the number of arguments to curry for and must be at least one. 126 | // 127 | // When the `n`th argument is applied to the curried result `uncurried.lam_fp` 128 | // will finally be called with a closure of `uncurried.lam_closure` and an 129 | // argument where `.val_pair` is a pointer to an (despite its name) `n` element 130 | // array containing the passed arguments in order. 131 | LDST_res_t LDST_curry(LDST_t *value, LDST_lam_t uncurried, int n); 132 | 133 | // A synchronous version of `LDST_fork`. 134 | // 135 | // When this function exits an the return value is `LDST_OK` then `*ctxt` will 136 | // contain the result of applying `op` to `arg`. 137 | LDST_res_t LDST_sync(LDST_ctxt_t *ctxt, LDST_t *result, LDST_lam_t op, LDST_t arg); 138 | 139 | // Runs the given top level function, no arguments are applied and the result 140 | // is returned. 141 | // 142 | // If an error occurs this function will call exit(3) with the error code 143 | // after printing an error description. 144 | // 145 | // This function creates a new context and uses it to run the function. The 146 | // context won't be destroyed but since it is inaccessible to the caller the 147 | // returned value should not be used further other than inspecting it. 148 | LDST_t LDST_main(LDST_fp0_t f); 149 | 150 | // Implementation detail of `natrec`. 151 | LDST_res_t LDST_nat_fold(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *closure, LDST_t value); 152 | 153 | // Implementation detail of channel operations. 154 | LDST_res_t LDST_make_recv_result(LDST_chan_t *chan, LDST_t value, LDST_t *result); 155 | 156 | // Invokes the given continuation and frees its memory. 157 | static inline LDST_res_t LDST_invoke(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_t value) { 158 | if (!k) 159 | return LDST_OK; 160 | 161 | LDST_lam_t lam = k->k_lam; 162 | LDST_cont_t *next = k->k_next; 163 | free(k); 164 | return lam.lam_fp(next, ctxt, lam.lam_closure, value); 165 | } 166 | 167 | #ifdef __cplusplus 168 | } 169 | #endif 170 | 171 | #endif // LDST_H__ 172 | -------------------------------------------------------------------------------- /c-support/runtime/LDST_concurrent.c: -------------------------------------------------------------------------------- 1 | // 2 | // LDST_concurrent.c 3 | // 4 | // Concurrent LDST backend. 5 | // 6 | 7 | #include 8 | #include 9 | #include 10 | #include "LDST.h" 11 | #include "LDST_debug.h" 12 | #include "thpool.h" 13 | 14 | #ifndef LDST_THREADPOOL_SIZE 15 | #define LDST_THREADPOOL_SIZE 4 16 | #endif 17 | 18 | struct LDST_chan { 19 | pthread_mutex_t chan_mut; 20 | LDST_t chan_value; 21 | LDST_cont_t *chan_cont; 22 | }; 23 | 24 | struct LDST_ctxt { 25 | threadpool pool; 26 | LDST_res_t error; 27 | atomic_int blocked_count; 28 | }; 29 | 30 | struct Operation { 31 | LDST_ctxt_t *ctxt; 32 | LDST_cont_t *cont; 33 | LDST_t val; 34 | }; 35 | 36 | LDST_ctxt_t *LDST_context_create(void) { 37 | LDST_ctxt_t *ctxt = malloc(sizeof *ctxt); 38 | if (!ctxt) { 39 | return 0; 40 | } 41 | 42 | ctxt->pool = thpool_init(LDST_THREADPOOL_SIZE); 43 | if (!ctxt->pool) { 44 | free(ctxt); 45 | return 0; 46 | } 47 | 48 | ctxt->error = LDST_OK; 49 | atomic_init(&ctxt->blocked_count, 0); 50 | return ctxt; 51 | } 52 | 53 | LDST_res_t LDST_context_wait(LDST_ctxt_t *ctxt) { 54 | LOG("waiting on " PTR_FMT, PTR_VAL(ctxt)); 55 | thpool_wait(ctxt->pool); 56 | LOG("finished " PTR_FMT, PTR_VAL(ctxt)); 57 | LDST_res_t res = ctxt->error; 58 | return res == LDST_OK && atomic_load_explicit(&ctxt->blocked_count, memory_order_relaxed) > 0 59 | ? LDST_DEADLOCK 60 | : res; 61 | } 62 | 63 | void LDST_context_destroy(LDST_ctxt_t *ctxt) { 64 | thpool_destroy(ctxt->pool); 65 | free(ctxt); 66 | } 67 | 68 | LDST_res_t LDST_chan_new(LDST_ctxt_t *ctxt, LDST_chan_t **chan) { 69 | LDST_chan_t *new_chan = malloc(sizeof *new_chan); 70 | LOG("created channel " PTR_FMT, PTR_VAL(new_chan)); 71 | if (!new_chan) 72 | return LDST_NO_MEM; 73 | 74 | if (pthread_mutex_init(&new_chan->chan_mut, 0) != 0) { 75 | free(new_chan); 76 | return LDST_ERR_UNKNOWN; 77 | } 78 | 79 | new_chan->chan_cont = 0; 80 | *chan = new_chan; 81 | return LDST_OK; 82 | } 83 | 84 | static void run_work(void *vop) { 85 | // Unpack the information about what to actually run. 86 | struct Operation *op = vop; 87 | LDST_ctxt_t *ctxt = op->ctxt; 88 | LDST_cont_t *k = op->cont; 89 | LDST_t val = op->val; 90 | free(op); 91 | 92 | if (ctxt->error != LDST_OK) { 93 | // Don't do anything if there is already an error. 94 | return; 95 | } 96 | 97 | LOG("starting work " PTR_FMT " (k=" PTR_FMT ", ctxt=" PTR_FMT ")", PTR_VAL(op), PTR_VAL(k), PTR_VAL(ctxt)); 98 | LDST_res_t res = LDST_invoke(k, ctxt, val); 99 | LOG("work done " PTR_FMT " (res=%d)", PTR_VAL(vop), res); 100 | 101 | // We don't keep track of all errors but only care about remembering any one 102 | // if there is one. 103 | if (res != LDST_OK) 104 | ctxt->error = res; 105 | } 106 | 107 | static LDST_res_t enqueue(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_t arg) { 108 | struct Operation *op = malloc(sizeof *op); 109 | if (!op) 110 | return LDST_NO_MEM; 111 | 112 | op->cont = k; 113 | op->val = arg; 114 | op->ctxt = ctxt; 115 | 116 | LOG("enqueuing work " PTR_FMT " (k=" PTR_FMT ", ctxt=" PTR_FMT ")", PTR_VAL(op), PTR_VAL(k), PTR_VAL(ctxt)); 117 | bool ok = thpool_add_work(ctxt->pool, run_work, op) == 0; 118 | return ok ? LDST_OK : LDST_ERR_UNKNOWN; 119 | } 120 | 121 | /// Returns the continuation in `chan` and sets it to `NULL` or returns `NULL` 122 | /// and stores `k` if there is none. 123 | /// 124 | /// REQUIRES: chan->chan_mut is locked. 125 | static LDST_cont_t *should_suspend(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) { 126 | LDST_cont_t *stored = chan->chan_cont; 127 | if (stored) { 128 | chan->chan_cont = 0; 129 | atomic_fetch_sub_explicit(&ctxt->blocked_count, 1, memory_order_relaxed); 130 | } else { 131 | chan->chan_cont = k; 132 | atomic_fetch_add_explicit(&ctxt->blocked_count, 1, memory_order_relaxed); 133 | } 134 | return stored; 135 | } 136 | 137 | static LDST_res_t suspend_if_needed( 138 | LDST_cont_t *k, 139 | LDST_ctxt_t *ctxt, 140 | LDST_chan_t *chan, 141 | LDST_cont_t **stored_k, 142 | LDST_t *value) 143 | { 144 | pthread_mutex_t *mutex = &chan->chan_mut; 145 | if (pthread_mutex_lock(mutex) != 0) { 146 | return LDST_ERR_UNKNOWN; 147 | } 148 | 149 | *stored_k = should_suspend(k, ctxt, chan); 150 | if (*stored_k == 0 && value != 0) { 151 | chan->chan_value = *value; 152 | } 153 | 154 | if (pthread_mutex_unlock(mutex) != 0) { 155 | return LDST_ERR_UNKNOWN; 156 | } 157 | 158 | return LDST_OK; 159 | } 160 | 161 | LDST_res_t LDST_chan_send(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *channel, LDST_t value) { 162 | LDST_res_t res; 163 | LDST_cont_t *recv_k; 164 | LDST_chan_t *chan = channel; 165 | 166 | res = suspend_if_needed(k, ctxt, chan, &recv_k, &value); 167 | if (res != LDST_OK) { 168 | return res; 169 | } 170 | 171 | LOG("send on " PTR_FMT "%s", PTR_VAL(chan), recv_k ? "" : " [blocked]"); 172 | if (!recv_k) { 173 | // We suspend the current thread because the receiving side has not arrived yet. 174 | return LDST_OK; 175 | } 176 | 177 | // Enqueue the receiving side. 178 | res = LDST_make_recv_result(chan, value, &value); 179 | if (res != LDST_OK) { 180 | return res; 181 | } 182 | 183 | res = enqueue(recv_k, ctxt, value); 184 | if (res != LDST_OK) { 185 | free(value.val_pair); 186 | return res; 187 | } 188 | 189 | // Continue the current thread. 190 | value.val_chan = chan; 191 | return LDST_invoke(k, ctxt, value); 192 | } 193 | 194 | LDST_res_t LDST_chan_recv(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) { 195 | LDST_res_t res; 196 | LDST_cont_t *send_k; 197 | 198 | res = suspend_if_needed(k, ctxt, chan, &send_k, 0); 199 | if (res != LDST_OK) { 200 | return res; 201 | } 202 | 203 | LOG("recv on " PTR_FMT "%s", PTR_VAL(chan), send_k ? "" : " [blocked]"); 204 | if (!send_k) { 205 | // We suspend the current thread because the sending side has not arrived yet. 206 | return LDST_OK; 207 | } 208 | 209 | // Create the result value for the calling thread. This either must happen 210 | // before the `enqueue` to benefit from the implicit channel lock or when 211 | // the channel mutex is still held. 212 | LDST_t value; 213 | res = LDST_make_recv_result(chan, chan->chan_value, &value); 214 | if (res != LDST_OK) { 215 | return res; 216 | } 217 | 218 | // Enqueue the sending side. 219 | LDST_t chan_value = { .val_chan = chan }; 220 | res = enqueue(send_k, ctxt, chan_value); 221 | if (res != LDST_OK) { 222 | free(value.val_pair); 223 | return res; 224 | } 225 | 226 | // Continue the current thread. 227 | return LDST_invoke(k, ctxt, value); 228 | } 229 | 230 | LDST_res_t LDST_fork(LDST_ctxt_t *ctxt, LDST_lam_t op, LDST_t value) { 231 | LOG("forking execution"); 232 | LDST_cont_t *k = malloc(sizeof(LDST_cont_t)); 233 | if (!k) { 234 | return LDST_NO_MEM; 235 | } 236 | 237 | k->k_lam = op; 238 | k->k_next = 0; 239 | 240 | LDST_res_t res = enqueue(k, ctxt, value); 241 | if (res != LDST_OK) { 242 | free(k); 243 | } 244 | 245 | return res; 246 | } 247 | 248 | /* 249 | struct SyncInfo { 250 | LDST_lam_t op; 251 | LDST_t *result; 252 | bool has_result; 253 | }; 254 | 255 | static LDST_res_t assign_k(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t val) { 256 | struct SyncInfo *info = vinfo; 257 | *info->result = val; 258 | LOG("result assigned, posting"); 259 | //uv_sem_post(&info->sem); 260 | return LDST_invoke(k, ctxt, val); 261 | } 262 | 263 | static LDST_res_t assign(LDST_cont_t *then_k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t arg) { 264 | struct SyncInfo *info = vinfo; 265 | LDST_cont_t *k = malloc(sizeof(LDST_cont_t)); 266 | if (!k) 267 | return LDST_NO_MEM; 268 | 269 | k->k_lam.lam_fp = assign_k; 270 | k->k_lam.lam_closure = vinfo; 271 | k->k_next = then_k; 272 | return info->op.lam_fp(k, ctxt, info->op.lam_closure, arg); 273 | } 274 | 275 | LDST_res_t LDST_sync(LDST_ctxt_t *ctxt, LDST_t *result, LDST_lam_t op, LDST_t value) { 276 | struct SyncInfo info = { .op = op, .result = result }; 277 | if (pthread_mutex_init(&info.result_mutex, 0) != 0) 278 | return LDST_ERR_UNKNOWN; 279 | 280 | if (pthread_cond_init(&info.result_cond, 0) != 0) { 281 | pthread_mutex_destroy(&info.result_mutex); 282 | return LDST_ERR_UNKNOWN; 283 | } 284 | 285 | LOG("initial fork"); 286 | LDST_lam_t storing_op = { assign, &info }; 287 | LDST_res_t res = LDST_fork(ctxt, storing_op, value); 288 | 289 | LOG("waiting for completion, fork=%d", res); 290 | thpool_wait(ctxt->pool); 291 | 292 | 293 | LOG("result available"); 294 | // uv_sem_destroy(&info.sem); 295 | // uv_loop_close(&sync_loop); 296 | 297 | res = LDST_merge_res(atomic_load_explicit(&detached_res, memory_order_relaxed), res); 298 | return atomic_load_explicit(&BlockedCount, memory_order_relaxed) > 0 299 | ? LDST_merge_res(LDST_DEADLOCK, res) 300 | : res; 301 | } 302 | */ 303 | -------------------------------------------------------------------------------- /c-support/runtime/LDST_debug.h: -------------------------------------------------------------------------------- 1 | // 2 | // LDST_debug.h 3 | // 4 | // Debug macros. This provides formatted output to stderr, colorized on which 5 | // thread it is running and with support for colorized pointer/address output 6 | // to differentiate the pointer values better. 7 | // 8 | 9 | #ifndef LDST_DEBUG_H__ 10 | #define LDST_DEBUG_H__ 11 | 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | #ifdef LDST_DEBUG 18 | 19 | #define LDST_DBG_COLOR(n) (int)((n) * ((n) + 3) % (228L - 21L) + 21L) 20 | #define LDST_DBG_COLOR_FMT "\033[38;5;%dm" 21 | #define LDST_DBG_COLOR_RESET "\033[m" 22 | 23 | #define PTR_FMT LDST_DBG_COLOR_FMT "%p" LDST_DBG_COLOR_RESET 24 | #define PTR_VAL(p) LDST_DBG_COLOR((uintptr_t)(p)), p 25 | 26 | #ifdef __APPLE__ 27 | #define LDST_DBG_THREADID(var) pthread_threadid_np(0, &var) 28 | #else 29 | // `pthread` is a pointer, just use this value. 30 | #define LDST_DBG_THREADID(var) var = (uintptr_t)pthread_self(); 31 | #endif 32 | 33 | #define LOG(fmt, ...) do { \ 34 | uint64_t tid__ ## __LINE__; \ 35 | LDST_DBG_THREADID(tid__ ## __LINE__); \ 36 | printf( \ 37 | LDST_DBG_COLOR_FMT \ 38 | "[%" PRId64 "] %s:%d " fmt \ 39 | LDST_DBG_COLOR_RESET "\n", \ 40 | LDST_DBG_COLOR(tid__ ## __LINE__), \ 41 | tid__ ## __LINE__, __func__, __LINE__, \ 42 | ##__VA_ARGS__); \ 43 | } while (0) 44 | 45 | #else // LDST_DEBUG 46 | 47 | #define LOG(fmt, ...) 48 | 49 | #endif // LDST_DEBUG 50 | 51 | #endif // LDST_DEBUG_H__ 52 | -------------------------------------------------------------------------------- /c-support/runtime/LDST_serial.c: -------------------------------------------------------------------------------- 1 | // 2 | // LDST_serial.c 3 | // 4 | // Serial LDST backend. 5 | 6 | #include 7 | #include 8 | #include 9 | #include "LDST.h" 10 | #include "LDST_debug.h" 11 | 12 | typedef struct cont_stack { 13 | LDST_t q_val; 14 | LDST_cont_t *q_cont; 15 | struct cont_stack *q_next; 16 | } cont_stack_t; 17 | 18 | struct LDST_chan { 19 | LDST_t chan_value; 20 | LDST_cont_t *chan_cont; 21 | }; 22 | 23 | struct LDST_ctxt { 24 | bool executing; 25 | int blocked_count; 26 | cont_stack_t *runnables; 27 | }; 28 | 29 | LDST_ctxt_t *LDST_context_create(void) { 30 | LDST_ctxt_t *ctxt = malloc(sizeof *ctxt); 31 | if (ctxt == 0) 32 | return 0; 33 | 34 | ctxt->executing = false; 35 | ctxt->blocked_count = 0; 36 | ctxt->runnables = 0; 37 | return ctxt; 38 | } 39 | 40 | LDST_res_t LDST_context_wait(LDST_ctxt_t *ctxt) { 41 | return ctxt->blocked_count > 0 ? LDST_DEADLOCK : LDST_OK; 42 | } 43 | 44 | void LDST_context_destroy(LDST_ctxt_t *ctxt) { 45 | free(ctxt); 46 | } 47 | 48 | static LDST_res_t enqueue(LDST_ctxt_t *ctxt, LDST_cont_t *cont, LDST_t value, const char *reason) { 49 | LOG("enqueue " PTR_FMT " (%s)", PTR_VAL(cont), reason); 50 | 51 | cont_stack_t *runnable = malloc(sizeof(cont_stack_t)); 52 | if (!runnable) { 53 | return LDST_NO_MEM; 54 | } 55 | 56 | runnable->q_val = value; 57 | runnable->q_cont = cont; 58 | runnable->q_next = ctxt->runnables; 59 | ctxt->runnables = runnable; 60 | return LDST_OK; 61 | } 62 | 63 | static void reset_channel(LDST_chan_t *chan) { 64 | memset(chan, 0, sizeof(LDST_chan_t)); 65 | } 66 | 67 | LDST_res_t LDST_chan_new(LDST_ctxt_t *ctxt, LDST_chan_t **chan) { 68 | LDST_chan_t *new_chan = malloc(sizeof(LDST_chan_t)); 69 | LOG("created channel " PTR_FMT, PTR_VAL(new_chan)); 70 | if (!new_chan) 71 | return LDST_NO_MEM; 72 | 73 | reset_channel(new_chan); 74 | *chan = new_chan; 75 | return LDST_OK; 76 | } 77 | 78 | static bool should_suspend(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) { 79 | if (chan->chan_cont) { 80 | ctxt->blocked_count--; 81 | return false; 82 | } 83 | 84 | chan->chan_cont = k; 85 | ctxt->blocked_count++; 86 | return true; 87 | } 88 | 89 | LDST_res_t LDST_chan_send(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *channel, LDST_t value) { 90 | LOG("send on " PTR_FMT, PTR_VAL(channel)); 91 | 92 | LDST_chan_t *chan = channel; 93 | if (should_suspend(k, ctxt, chan)) { 94 | LOG("send blocked " PTR_FMT, PTR_VAL(k)); 95 | chan->chan_value = value; 96 | return LDST_OK; 97 | } 98 | 99 | // Enqueue the receiving side. 100 | LDST_res_t res; 101 | res = LDST_make_recv_result(chan, value, &value); 102 | if (res != LDST_OK) { 103 | return res; 104 | } 105 | res = enqueue(ctxt, chan->chan_cont, value, "value received"); 106 | if (res != LDST_OK) { 107 | free(value.val_pair); 108 | return res; 109 | } 110 | 111 | // Continue the current thread. 112 | reset_channel(chan); 113 | value.val_chan = chan; 114 | return LDST_invoke(k, ctxt, value); 115 | } 116 | 117 | LDST_res_t LDST_chan_recv(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) { 118 | LOG("recv on " PTR_FMT, PTR_VAL(chan)); 119 | 120 | if (should_suspend(k, ctxt, chan)) { 121 | LOG("recv blocked " PTR_FMT, PTR_VAL(k)); 122 | return LDST_OK; 123 | } 124 | 125 | // Enqueue the sending side. 126 | LDST_res_t res; 127 | LDST_t value = { .val_chan = chan }; 128 | res = enqueue(ctxt, chan->chan_cont, value, "value transferred"); 129 | if (res != LDST_OK) 130 | return res; 131 | 132 | // Create the result value for the calling thread. 133 | res = LDST_make_recv_result(chan, chan->chan_value, &value); 134 | if (res != LDST_OK) 135 | return res; 136 | 137 | // Continue the current thread. 138 | reset_channel(chan); 139 | return LDST_invoke(k, ctxt, value); 140 | } 141 | 142 | static LDST_res_t run_runnables(LDST_ctxt_t *ctxt) { 143 | if (ctxt->executing) { 144 | return LDST_OK; 145 | } 146 | 147 | LOG("start executing"); 148 | ctxt->executing = true; 149 | 150 | LDST_res_t res = LDST_OK; 151 | cont_stack_t *runnable; 152 | while (res == LDST_OK && (runnable = ctxt->runnables)) { 153 | LOG("BEGIN " PTR_FMT, PTR_VAL(runnable->q_cont)); 154 | ctxt->runnables = runnable->q_next; 155 | res = LDST_invoke(runnable->q_cont, ctxt, runnable->q_val); 156 | LOG(" END " PTR_FMT, PTR_VAL(runnable->q_cont)); 157 | free(runnable); 158 | } 159 | 160 | ctxt->executing = false; 161 | if (res != LDST_OK) 162 | return res; 163 | 164 | if (ctxt->blocked_count > 0) 165 | return LDST_DEADLOCK; 166 | 167 | return LDST_OK; 168 | } 169 | 170 | LDST_res_t LDST_fork(LDST_ctxt_t *ctxt, LDST_lam_t op, LDST_t value) { 171 | LDST_cont_t *k = malloc(sizeof(LDST_cont_t)); 172 | if (!k) { 173 | return LDST_NO_MEM; 174 | } 175 | 176 | k->k_lam = op; 177 | k->k_next = 0; 178 | LDST_res_t res = enqueue(ctxt, k, value, "fork"); 179 | if (res != LDST_OK) { 180 | free(k); 181 | return res; 182 | } 183 | 184 | return run_runnables(ctxt); 185 | } 186 | -------------------------------------------------------------------------------- /c-support/runtime/thpool.c: -------------------------------------------------------------------------------- 1 | /* ******************************** 2 | * Author: Johan Hanssen Seferidis 3 | * License: MIT 4 | * Description: Library providing a threading pool where you can add 5 | * work. For usage, check the thpool.h file or README.md 6 | * 7 | *//** @file thpool.h *//* 8 | * 9 | ********************************/ 10 | 11 | #define _POSIX_C_SOURCE 200809L 12 | 13 | #if defined(__APPLE__) && defined(__MACH__) 14 | #define _DARWIN_C_SOURCE 15 | #endif 16 | 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #if defined(__linux__) 25 | #include 26 | #endif 27 | 28 | #include "thpool.h" 29 | 30 | #ifdef THPOOL_DEBUG 31 | #define THPOOL_DEBUG 1 32 | #else 33 | #define THPOOL_DEBUG 0 34 | #endif 35 | 36 | #if !defined(DISABLE_PRINT) || defined(THPOOL_DEBUG) 37 | #define err(str) fprintf(stderr, str) 38 | #else 39 | #define err(str) 40 | #endif 41 | 42 | static volatile int threads_keepalive; 43 | static volatile int threads_on_hold; 44 | 45 | 46 | 47 | /* ========================== STRUCTURES ============================ */ 48 | 49 | 50 | /* Binary semaphore */ 51 | typedef struct bsem { 52 | pthread_mutex_t mutex; 53 | pthread_cond_t cond; 54 | int v; 55 | } bsem; 56 | 57 | 58 | /* Job */ 59 | typedef struct job{ 60 | struct job* prev; /* pointer to previous job */ 61 | void (*function)(void* arg); /* function pointer */ 62 | void* arg; /* function's argument */ 63 | } job; 64 | 65 | 66 | /* Job queue */ 67 | typedef struct jobqueue{ 68 | pthread_mutex_t rwmutex; /* used for queue r/w access */ 69 | job *front; /* pointer to front of queue */ 70 | job *rear; /* pointer to rear of queue */ 71 | bsem *has_jobs; /* flag as binary semaphore */ 72 | int len; /* number of jobs in queue */ 73 | } jobqueue; 74 | 75 | 76 | /* Thread */ 77 | typedef struct thread{ 78 | int id; /* friendly id */ 79 | pthread_t pthread; /* pointer to actual thread */ 80 | struct thpool_* thpool_p; /* access to thpool */ 81 | } thread; 82 | 83 | 84 | /* Threadpool */ 85 | typedef struct thpool_{ 86 | thread** threads; /* pointer to threads */ 87 | volatile int num_threads_alive; /* threads currently alive */ 88 | volatile int num_threads_working; /* threads currently working */ 89 | pthread_mutex_t thcount_lock; /* used for thread count etc */ 90 | pthread_cond_t threads_all_idle; /* signal to thpool_wait */ 91 | jobqueue jobqueue; /* job queue */ 92 | } thpool_; 93 | 94 | 95 | 96 | 97 | 98 | /* ========================== PROTOTYPES ============================ */ 99 | 100 | 101 | static int thread_init(thpool_* thpool_p, struct thread** thread_p, int id); 102 | static void* thread_do(struct thread* thread_p); 103 | static void thread_hold(int sig_id); 104 | static void thread_destroy(struct thread* thread_p); 105 | 106 | static int jobqueue_init(jobqueue* jobqueue_p); 107 | static void jobqueue_clear(jobqueue* jobqueue_p); 108 | static void jobqueue_push(jobqueue* jobqueue_p, struct job* newjob_p); 109 | static struct job* jobqueue_pull(jobqueue* jobqueue_p); 110 | static void jobqueue_destroy(jobqueue* jobqueue_p); 111 | 112 | static void bsem_init(struct bsem *bsem_p, int value); 113 | static void bsem_reset(struct bsem *bsem_p); 114 | static void bsem_post(struct bsem *bsem_p); 115 | static void bsem_post_all(struct bsem *bsem_p); 116 | static void bsem_wait(struct bsem *bsem_p); 117 | 118 | 119 | 120 | 121 | 122 | /* ========================== THREADPOOL ============================ */ 123 | 124 | 125 | /* Initialise thread pool */ 126 | struct thpool_* thpool_init(int num_threads){ 127 | 128 | threads_on_hold = 0; 129 | threads_keepalive = 1; 130 | 131 | if (num_threads < 0){ 132 | num_threads = 0; 133 | } 134 | 135 | /* Make new thread pool */ 136 | thpool_* thpool_p; 137 | thpool_p = (struct thpool_*)malloc(sizeof(struct thpool_)); 138 | if (thpool_p == NULL){ 139 | err("thpool_init(): Could not allocate memory for thread pool\n"); 140 | return NULL; 141 | } 142 | thpool_p->num_threads_alive = 0; 143 | thpool_p->num_threads_working = 0; 144 | 145 | /* Initialise the job queue */ 146 | if (jobqueue_init(&thpool_p->jobqueue) == -1){ 147 | err("thpool_init(): Could not allocate memory for job queue\n"); 148 | free(thpool_p); 149 | return NULL; 150 | } 151 | 152 | /* Make threads in pool */ 153 | thpool_p->threads = (struct thread**)malloc(num_threads * sizeof(struct thread *)); 154 | if (thpool_p->threads == NULL){ 155 | err("thpool_init(): Could not allocate memory for threads\n"); 156 | jobqueue_destroy(&thpool_p->jobqueue); 157 | free(thpool_p); 158 | return NULL; 159 | } 160 | 161 | pthread_mutex_init(&(thpool_p->thcount_lock), NULL); 162 | pthread_cond_init(&thpool_p->threads_all_idle, NULL); 163 | 164 | /* Thread init */ 165 | int n; 166 | for (n=0; nthreads[n], n); 168 | #if THPOOL_DEBUG 169 | printf("THPOOL_DEBUG: Created thread %d in pool \n", n); 170 | #endif 171 | } 172 | 173 | /* Wait for threads to initialize */ 174 | while (thpool_p->num_threads_alive != num_threads) {} 175 | 176 | return thpool_p; 177 | } 178 | 179 | 180 | /* Add work to the thread pool */ 181 | int thpool_add_work(thpool_* thpool_p, void (*function_p)(void*), void* arg_p){ 182 | job* newjob; 183 | 184 | newjob=(struct job*)malloc(sizeof(struct job)); 185 | if (newjob==NULL){ 186 | err("thpool_add_work(): Could not allocate memory for new job\n"); 187 | return -1; 188 | } 189 | 190 | /* add function and argument */ 191 | newjob->function=function_p; 192 | newjob->arg=arg_p; 193 | 194 | /* add job to queue */ 195 | jobqueue_push(&thpool_p->jobqueue, newjob); 196 | 197 | return 0; 198 | } 199 | 200 | 201 | /* Wait until all jobs have finished */ 202 | void thpool_wait(thpool_* thpool_p){ 203 | pthread_mutex_lock(&thpool_p->thcount_lock); 204 | while (thpool_p->jobqueue.len || thpool_p->num_threads_working) { 205 | pthread_cond_wait(&thpool_p->threads_all_idle, &thpool_p->thcount_lock); 206 | } 207 | pthread_mutex_unlock(&thpool_p->thcount_lock); 208 | } 209 | 210 | 211 | /* Destroy the threadpool */ 212 | void thpool_destroy(thpool_* thpool_p){ 213 | /* No need to destory if it's NULL */ 214 | if (thpool_p == NULL) return ; 215 | 216 | volatile int threads_total = thpool_p->num_threads_alive; 217 | 218 | /* End each thread 's infinite loop */ 219 | threads_keepalive = 0; 220 | 221 | /* Give one second to kill idle threads */ 222 | double TIMEOUT = 1.0; 223 | time_t start, end; 224 | double tpassed = 0.0; 225 | time (&start); 226 | while (tpassed < TIMEOUT && thpool_p->num_threads_alive){ 227 | bsem_post_all(thpool_p->jobqueue.has_jobs); 228 | time (&end); 229 | tpassed = difftime(end,start); 230 | } 231 | 232 | /* Poll remaining threads */ 233 | while (thpool_p->num_threads_alive){ 234 | bsem_post_all(thpool_p->jobqueue.has_jobs); 235 | sleep(1); 236 | } 237 | 238 | /* Job queue cleanup */ 239 | jobqueue_destroy(&thpool_p->jobqueue); 240 | /* Deallocs */ 241 | int n; 242 | for (n=0; n < threads_total; n++){ 243 | thread_destroy(thpool_p->threads[n]); 244 | } 245 | free(thpool_p->threads); 246 | free(thpool_p); 247 | } 248 | 249 | 250 | /* Pause all threads in threadpool */ 251 | void thpool_pause(thpool_* thpool_p) { 252 | int n; 253 | for (n=0; n < thpool_p->num_threads_alive; n++){ 254 | pthread_kill(thpool_p->threads[n]->pthread, SIGUSR1); 255 | } 256 | } 257 | 258 | 259 | /* Resume all threads in threadpool */ 260 | void thpool_resume(thpool_* thpool_p) { 261 | // resuming a single threadpool hasn't been 262 | // implemented yet, meanwhile this supresses 263 | // the warnings 264 | (void)thpool_p; 265 | 266 | threads_on_hold = 0; 267 | } 268 | 269 | 270 | int thpool_num_threads_working(thpool_* thpool_p){ 271 | return thpool_p->num_threads_working; 272 | } 273 | 274 | 275 | 276 | 277 | 278 | /* ============================ THREAD ============================== */ 279 | 280 | 281 | /* Initialize a thread in the thread pool 282 | * 283 | * @param thread address to the pointer of the thread to be created 284 | * @param id id to be given to the thread 285 | * @return 0 on success, -1 otherwise. 286 | */ 287 | static int thread_init (thpool_* thpool_p, struct thread** thread_p, int id){ 288 | 289 | *thread_p = (struct thread*)malloc(sizeof(struct thread)); 290 | if (*thread_p == NULL){ 291 | err("thread_init(): Could not allocate memory for thread\n"); 292 | return -1; 293 | } 294 | 295 | (*thread_p)->thpool_p = thpool_p; 296 | (*thread_p)->id = id; 297 | 298 | pthread_create(&(*thread_p)->pthread, NULL, (void * (*)(void *)) thread_do, (*thread_p)); 299 | pthread_detach((*thread_p)->pthread); 300 | return 0; 301 | } 302 | 303 | 304 | /* Sets the calling thread on hold */ 305 | static void thread_hold(int sig_id) { 306 | (void)sig_id; 307 | threads_on_hold = 1; 308 | while (threads_on_hold){ 309 | sleep(1); 310 | } 311 | } 312 | 313 | 314 | /* What each thread is doing 315 | * 316 | * In principle this is an endless loop. The only time this loop gets interuppted is once 317 | * thpool_destroy() is invoked or the program exits. 318 | * 319 | * @param thread thread that will run this function 320 | * @return nothing 321 | */ 322 | static void* thread_do(struct thread* thread_p){ 323 | 324 | /* Set thread name for profiling and debuging */ 325 | char thread_name[32] = {0}; 326 | snprintf(thread_name, 32, "thread-pool-%d", thread_p->id); 327 | 328 | #if defined(__linux__) 329 | /* Use prctl instead to prevent using _GNU_SOURCE flag and implicit declaration */ 330 | prctl(PR_SET_NAME, thread_name); 331 | #elif defined(__APPLE__) && defined(__MACH__) 332 | pthread_setname_np(thread_name); 333 | #else 334 | err("thread_do(): pthread_setname_np is not supported on this system"); 335 | #endif 336 | 337 | /* Assure all threads have been created before starting serving */ 338 | thpool_* thpool_p = thread_p->thpool_p; 339 | 340 | /* Register signal handler */ 341 | struct sigaction act; 342 | sigemptyset(&act.sa_mask); 343 | act.sa_flags = 0; 344 | act.sa_handler = thread_hold; 345 | if (sigaction(SIGUSR1, &act, NULL) == -1) { 346 | err("thread_do(): cannot handle SIGUSR1"); 347 | } 348 | 349 | /* Mark thread as alive (initialized) */ 350 | pthread_mutex_lock(&thpool_p->thcount_lock); 351 | thpool_p->num_threads_alive += 1; 352 | pthread_mutex_unlock(&thpool_p->thcount_lock); 353 | 354 | while(threads_keepalive){ 355 | 356 | bsem_wait(thpool_p->jobqueue.has_jobs); 357 | 358 | if (threads_keepalive){ 359 | 360 | pthread_mutex_lock(&thpool_p->thcount_lock); 361 | thpool_p->num_threads_working++; 362 | pthread_mutex_unlock(&thpool_p->thcount_lock); 363 | 364 | /* Read job from queue and execute it */ 365 | void (*func_buff)(void*); 366 | void* arg_buff; 367 | job* job_p = jobqueue_pull(&thpool_p->jobqueue); 368 | if (job_p) { 369 | func_buff = job_p->function; 370 | arg_buff = job_p->arg; 371 | func_buff(arg_buff); 372 | free(job_p); 373 | } 374 | 375 | pthread_mutex_lock(&thpool_p->thcount_lock); 376 | thpool_p->num_threads_working--; 377 | if (!thpool_p->num_threads_working) { 378 | pthread_cond_signal(&thpool_p->threads_all_idle); 379 | } 380 | pthread_mutex_unlock(&thpool_p->thcount_lock); 381 | 382 | } 383 | } 384 | pthread_mutex_lock(&thpool_p->thcount_lock); 385 | thpool_p->num_threads_alive --; 386 | pthread_mutex_unlock(&thpool_p->thcount_lock); 387 | 388 | return NULL; 389 | } 390 | 391 | 392 | /* Frees a thread */ 393 | static void thread_destroy (thread* thread_p){ 394 | free(thread_p); 395 | } 396 | 397 | 398 | 399 | 400 | 401 | /* ============================ JOB QUEUE =========================== */ 402 | 403 | 404 | /* Initialize queue */ 405 | static int jobqueue_init(jobqueue* jobqueue_p){ 406 | jobqueue_p->len = 0; 407 | jobqueue_p->front = NULL; 408 | jobqueue_p->rear = NULL; 409 | 410 | jobqueue_p->has_jobs = (struct bsem*)malloc(sizeof(struct bsem)); 411 | if (jobqueue_p->has_jobs == NULL){ 412 | return -1; 413 | } 414 | 415 | pthread_mutex_init(&(jobqueue_p->rwmutex), NULL); 416 | bsem_init(jobqueue_p->has_jobs, 0); 417 | 418 | return 0; 419 | } 420 | 421 | 422 | /* Clear the queue */ 423 | static void jobqueue_clear(jobqueue* jobqueue_p){ 424 | 425 | while(jobqueue_p->len){ 426 | free(jobqueue_pull(jobqueue_p)); 427 | } 428 | 429 | jobqueue_p->front = NULL; 430 | jobqueue_p->rear = NULL; 431 | bsem_reset(jobqueue_p->has_jobs); 432 | jobqueue_p->len = 0; 433 | 434 | } 435 | 436 | 437 | /* Add (allocated) job to queue 438 | */ 439 | static void jobqueue_push(jobqueue* jobqueue_p, struct job* newjob){ 440 | 441 | pthread_mutex_lock(&jobqueue_p->rwmutex); 442 | newjob->prev = NULL; 443 | 444 | switch(jobqueue_p->len){ 445 | 446 | case 0: /* if no jobs in queue */ 447 | jobqueue_p->front = newjob; 448 | jobqueue_p->rear = newjob; 449 | break; 450 | 451 | default: /* if jobs in queue */ 452 | jobqueue_p->rear->prev = newjob; 453 | jobqueue_p->rear = newjob; 454 | 455 | } 456 | jobqueue_p->len++; 457 | 458 | bsem_post(jobqueue_p->has_jobs); 459 | pthread_mutex_unlock(&jobqueue_p->rwmutex); 460 | } 461 | 462 | 463 | /* Get first job from queue(removes it from queue) 464 | * Notice: Caller MUST hold a mutex 465 | */ 466 | static struct job* jobqueue_pull(jobqueue* jobqueue_p){ 467 | 468 | pthread_mutex_lock(&jobqueue_p->rwmutex); 469 | job* job_p = jobqueue_p->front; 470 | 471 | switch(jobqueue_p->len){ 472 | 473 | case 0: /* if no jobs in queue */ 474 | break; 475 | 476 | case 1: /* if one job in queue */ 477 | jobqueue_p->front = NULL; 478 | jobqueue_p->rear = NULL; 479 | jobqueue_p->len = 0; 480 | break; 481 | 482 | default: /* if >1 jobs in queue */ 483 | jobqueue_p->front = job_p->prev; 484 | jobqueue_p->len--; 485 | /* more than one job in queue -> post it */ 486 | bsem_post(jobqueue_p->has_jobs); 487 | 488 | } 489 | 490 | pthread_mutex_unlock(&jobqueue_p->rwmutex); 491 | return job_p; 492 | } 493 | 494 | 495 | /* Free all queue resources back to the system */ 496 | static void jobqueue_destroy(jobqueue* jobqueue_p){ 497 | jobqueue_clear(jobqueue_p); 498 | free(jobqueue_p->has_jobs); 499 | } 500 | 501 | 502 | 503 | 504 | 505 | /* ======================== SYNCHRONISATION ========================= */ 506 | 507 | 508 | /* Init semaphore to 1 or 0 */ 509 | static void bsem_init(bsem *bsem_p, int value) { 510 | if (value < 0 || value > 1) { 511 | err("bsem_init(): Binary semaphore can take only values 1 or 0"); 512 | exit(1); 513 | } 514 | pthread_mutex_init(&(bsem_p->mutex), NULL); 515 | pthread_cond_init(&(bsem_p->cond), NULL); 516 | bsem_p->v = value; 517 | } 518 | 519 | 520 | /* Reset semaphore to 0 */ 521 | static void bsem_reset(bsem *bsem_p) { 522 | bsem_init(bsem_p, 0); 523 | } 524 | 525 | 526 | /* Post to at least one thread */ 527 | static void bsem_post(bsem *bsem_p) { 528 | pthread_mutex_lock(&bsem_p->mutex); 529 | bsem_p->v = 1; 530 | pthread_cond_signal(&bsem_p->cond); 531 | pthread_mutex_unlock(&bsem_p->mutex); 532 | } 533 | 534 | 535 | /* Post to all threads */ 536 | static void bsem_post_all(bsem *bsem_p) { 537 | pthread_mutex_lock(&bsem_p->mutex); 538 | bsem_p->v = 1; 539 | pthread_cond_broadcast(&bsem_p->cond); 540 | pthread_mutex_unlock(&bsem_p->mutex); 541 | } 542 | 543 | 544 | /* Wait on semaphore until semaphore has value 0 */ 545 | static void bsem_wait(bsem* bsem_p) { 546 | pthread_mutex_lock(&bsem_p->mutex); 547 | while (bsem_p->v != 1) { 548 | pthread_cond_wait(&bsem_p->cond, &bsem_p->mutex); 549 | } 550 | bsem_p->v = 0; 551 | pthread_mutex_unlock(&bsem_p->mutex); 552 | } 553 | -------------------------------------------------------------------------------- /c-support/runtime/thpool.h: -------------------------------------------------------------------------------- 1 | /********************************** 2 | * @author Johan Hanssen Seferidis 3 | * License: MIT 4 | * 5 | **********************************/ 6 | 7 | #ifndef _THPOOL_ 8 | #define _THPOOL_ 9 | 10 | #ifdef __cplusplus 11 | extern "C" { 12 | #endif 13 | 14 | /* =================================== API ======================================= */ 15 | 16 | 17 | typedef struct thpool_* threadpool; 18 | 19 | 20 | /** 21 | * @brief Initialize threadpool 22 | * 23 | * Initializes a threadpool. This function will not return until all 24 | * threads have initialized successfully. 25 | * 26 | * @example 27 | * 28 | * .. 29 | * threadpool thpool; //First we declare a threadpool 30 | * thpool = thpool_init(4); //then we initialize it to 4 threads 31 | * .. 32 | * 33 | * @param num_threads number of threads to be created in the threadpool 34 | * @return threadpool created threadpool on success, 35 | * NULL on error 36 | */ 37 | threadpool thpool_init(int num_threads); 38 | 39 | 40 | /** 41 | * @brief Add work to the job queue 42 | * 43 | * Takes an action and its argument and adds it to the threadpool's job queue. 44 | * If you want to add to work a function with more than one arguments then 45 | * a way to implement this is by passing a pointer to a structure. 46 | * 47 | * NOTICE: You have to cast both the function and argument to not get warnings. 48 | * 49 | * @example 50 | * 51 | * void print_num(int num){ 52 | * printf("%d\n", num); 53 | * } 54 | * 55 | * int main() { 56 | * .. 57 | * int a = 10; 58 | * thpool_add_work(thpool, (void*)print_num, (void*)a); 59 | * .. 60 | * } 61 | * 62 | * @param threadpool threadpool to which the work will be added 63 | * @param function_p pointer to function to add as work 64 | * @param arg_p pointer to an argument 65 | * @return 0 on success, -1 otherwise. 66 | */ 67 | int thpool_add_work(threadpool, void (*function_p)(void*), void* arg_p); 68 | 69 | 70 | /** 71 | * @brief Wait for all queued jobs to finish 72 | * 73 | * Will wait for all jobs - both queued and currently running to finish. 74 | * Once the queue is empty and all work has completed, the calling thread 75 | * (probably the main program) will continue. 76 | * 77 | * Smart polling is used in wait. The polling is initially 0 - meaning that 78 | * there is virtually no polling at all. If after 1 seconds the threads 79 | * haven't finished, the polling interval starts growing exponentially 80 | * until it reaches max_secs seconds. Then it jumps down to a maximum polling 81 | * interval assuming that heavy processing is being used in the threadpool. 82 | * 83 | * @example 84 | * 85 | * .. 86 | * threadpool thpool = thpool_init(4); 87 | * .. 88 | * // Add a bunch of work 89 | * .. 90 | * thpool_wait(thpool); 91 | * puts("All added work has finished"); 92 | * .. 93 | * 94 | * @param threadpool the threadpool to wait for 95 | * @return nothing 96 | */ 97 | void thpool_wait(threadpool); 98 | 99 | 100 | /** 101 | * @brief Pauses all threads immediately 102 | * 103 | * The threads will be paused no matter if they are idle or working. 104 | * The threads return to their previous states once thpool_resume 105 | * is called. 106 | * 107 | * While the thread is being paused, new work can be added. 108 | * 109 | * @example 110 | * 111 | * threadpool thpool = thpool_init(4); 112 | * thpool_pause(thpool); 113 | * .. 114 | * // Add a bunch of work 115 | * .. 116 | * thpool_resume(thpool); // Let the threads start their magic 117 | * 118 | * @param threadpool the threadpool where the threads should be paused 119 | * @return nothing 120 | */ 121 | void thpool_pause(threadpool); 122 | 123 | 124 | /** 125 | * @brief Unpauses all threads if they are paused 126 | * 127 | * @example 128 | * .. 129 | * thpool_pause(thpool); 130 | * sleep(10); // Delay execution 10 seconds 131 | * thpool_resume(thpool); 132 | * .. 133 | * 134 | * @param threadpool the threadpool where the threads should be unpaused 135 | * @return nothing 136 | */ 137 | void thpool_resume(threadpool); 138 | 139 | 140 | /** 141 | * @brief Destroy the threadpool 142 | * 143 | * This will wait for the currently active threads to finish and then 'kill' 144 | * the whole threadpool to free up memory. 145 | * 146 | * @example 147 | * int main() { 148 | * threadpool thpool1 = thpool_init(2); 149 | * threadpool thpool2 = thpool_init(2); 150 | * .. 151 | * thpool_destroy(thpool1); 152 | * .. 153 | * return 0; 154 | * } 155 | * 156 | * @param threadpool the threadpool to destroy 157 | * @return nothing 158 | */ 159 | void thpool_destroy(threadpool); 160 | 161 | 162 | /** 163 | * @brief Show currently working threads 164 | * 165 | * Working threads are the threads that are performing work (not idle). 166 | * 167 | * @example 168 | * int main() { 169 | * threadpool thpool1 = thpool_init(2); 170 | * threadpool thpool2 = thpool_init(2); 171 | * .. 172 | * printf("Working threads: %d\n", thpool_num_threads_working(thpool1)); 173 | * .. 174 | * return 0; 175 | * } 176 | * 177 | * @param threadpool the threadpool of interest 178 | * @return integer number of threads working 179 | */ 180 | int thpool_num_threads_working(threadpool); 181 | 182 | 183 | #ifdef __cplusplus 184 | } 185 | #endif 186 | 187 | #endif 188 | -------------------------------------------------------------------------------- /examples/add.ldgv: -------------------------------------------------------------------------------- 1 | -- Simple example of Label-Dependent Session Types 2 | -- Interprets addition of two numbers 3 | 4 | type SendInt : ! ~ssn = !Int. !Int. Unit 5 | 6 | val send2 (c: SendInt) = 7 | let x = ((send c) 1) in 8 | let y = ((send x) 42) in 9 | () 10 | 11 | val add2 (c1: dualof SendInt) = 12 | let = recv c1 in 13 | let = recv c2 in 14 | (m + n) 15 | 16 | val main : Int 17 | val main = 18 | let = (new SendInt) in 19 | let a1 = fork (send2 a) in 20 | add2 b 21 | -------------------------------------------------------------------------------- /examples/case-singleton.ldgv: -------------------------------------------------------------------------------- 1 | val f (x: {'a, 'b}) = < y = x, case y of {'a: 2, 'b: "abc"}> 2 | val g = f 'b 3 | -------------------------------------------------------------------------------- /examples/casesub.ldgv: -------------------------------------------------------------------------------- 1 | -- Subtyping example for Label-Dependent Lambda Calculus 2 | -- Typechecks subtyping relations between case and function types 3 | 4 | type BOOL : ~un = {'True,'False} 5 | 6 | type T1 : ~un = (b : BOOL) -> 7 | case b of 8 | { 'True : {'False} 9 | , 'False : {'True} 10 | } 11 | 12 | type T2 : ~un = (b : BOOL) -> BOOL 13 | 14 | T1 <: T2 15 | 16 | -- error expected 17 | T2 <: T1 18 | -------------------------------------------------------------------------------- /examples/casetest.ldgv: -------------------------------------------------------------------------------- 1 | -- Simple function definition in Label-Dependent Lambda Calculus 2 | 3 | val negate (b : {'True,'False}) = 4 | case b of 5 | { 'True : 'False 6 | , 'False : 'True 7 | } 8 | -------------------------------------------------------------------------------- /examples/cast-bot.ldgv: -------------------------------------------------------------------------------- 1 | type Bool : ~un = {'T, 'F} 2 | val f1 = case ('T : Bool => _|_) of {'T : 22 , 'F : "a" } -------------------------------------------------------------------------------- /examples/cast-collide.ldgv: -------------------------------------------------------------------------------- 1 | type Bool : ~un = {'T, 'F} 2 | val f1 = case (( 'T : Bool => *) : * => Int ) { 'T : 5 , 'F : 'T } -------------------------------------------------------------------------------- /examples/cast-fail.ldgv: -------------------------------------------------------------------------------- 1 | type Bool : ~un = {'T, 'F} 2 | 3 | val not : (b: Bool) -> Bool 4 | val not (b: Bool) = (case b {'T: 'F, 'F: 'T}) 5 | 6 | -- val f1 = case ('T : Bool => Int) of {'T : 22 , 'F : "a" } -- fails 7 | 8 | val f2 = ('T : {'T, 'F, 'N} => Bool) 9 | 10 | val f3 = fn (x: *) 11 | fn (y: case (x: * => Bool) {'T: Int, 'F: { 'T , 'F } }) 12 | case (x: * => Bool) {'T: 17+y, 'F: not y} 13 | -------------------------------------------------------------------------------- /examples/casts.ccldgv: -------------------------------------------------------------------------------- 1 | -- Examples from section 2 of the paper "Label Dependent Lambda Calculus and Gradual Typing.pdf" (2021) 2 | -- Also used in unit tests in tests/UtilsFuncCcldlc.hs 3 | 4 | type Bool : ~un = {'T, 'F} 5 | 6 | val not : (b: Bool) -> Bool 7 | val not (b: Bool) = (case b {'T: 'F, 'F: 'T}) 8 | 9 | -- This is a LDLC function: 10 | val f : (x: Bool) -> (y: case x {'T: Int, 'F: Bool}) -> case x {'T: Int, 'F: Bool} 11 | val f = 𝜆(x: Bool) 𝜆(y: case x {'T: Int, 'F: Bool}) case x {'T: 17+y, 'F: not y} 12 | 13 | -- This is the first GLDLC function: 14 | -- f1 :: Π(x: Bool).Π(y: *).case x {'T: Int, 'F: Bool} 15 | -- f1 = 𝜆(x: Bool) 𝜆(y: *) case x {'T: 17+y, 'F: not y} 16 | 17 | -- And the corresponding CCLDLC function 18 | val f1' : (x: Bool) -> (y: *) -> case x {'T: Int, 'F: Bool} 19 | val f1' = 𝜆(x: Bool) 𝜆(y: *) case x {'T: 17 + (y: * => Int), 'F: not (y: * => Bool)} 20 | 21 | -- This is the second GLDLC function: 22 | -- f2 :: Π(x: *).Π(y: case x {'T: Int, 'F: Bool}).case x {'T: Int, 'F: Bool} 23 | 24 | -- This is from the internal CCLDLC representation: 25 | val f2' : (x: *) -> (y: case (x: * => Bool) {'T: Int, 'F: Bool}) -> case (x: * => Bool) {'T: Int, 'F: Bool} 26 | val f2' = 𝜆(x: *) 𝜆(y: case (x: * => Bool) {'T: Int, 'F: Bool}) case (x: * => Bool) {'T: 17+y, 'F: not y} 27 | 28 | -- Conversion from * to case type 29 | type Direction : ~un = {'L, 'R} 30 | 31 | --val f3 : 32 | -- (x: Bool) 33 | -- -> (y: *) 34 | -- -> (z: case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 35 | -- -> case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool} 36 | val f3 = 37 | 𝜆(x: Bool) 38 | 𝜆(y: *) 39 | 𝜆(z: case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 40 | case (y: * => case x {'T: Direction, 'F: Bool}) {'T: y, 'F: not y, 'L: z, 'R: not z} 41 | 42 | -- LDLC: Conversion of function types 43 | val f4 : 44 | (x: Bool) 45 | -> (y: case x {'T: (u:Bool) -> (v:Bool) -> Bool, 'F: (u:Bool) -> Bool}) 46 | -> (z: Bool) 47 | -> Bool 48 | val f4 = 49 | 𝜆(x: Bool) 50 | 𝜆(y: case x {'T: (u:Bool) -> (v:Bool) -> Bool, 51 | 'F: (u:Bool) -> Bool}) 52 | 𝜆(z: Bool) case x {'T: y z z, 'F: y z} 53 | 54 | val and : (x: Bool) -> (y: Bool) -> Bool 55 | val and = 𝜆(x: Bool) 𝜆(y: Bool) case x {'T: y, 'F: 'F} 56 | 57 | -- CCLDLC: Conversion of function types 58 | val f4' : 59 | (x: Bool) 60 | -> (y: *) 61 | -> (z: Bool) 62 | -> Bool 63 | val f4' = 64 | 𝜆(x: Bool) 65 | 𝜆(y: *) 66 | 𝜆(z: Bool) 67 | case x 68 | { 'T: (y: * => (a:Bool) -> (b:Bool) -> Bool) z z 69 | , 'F: (y: * => (b:Bool) -> Bool) z } 70 | -------------------------------------------------------------------------------- /examples/depcast.ccldgv: -------------------------------------------------------------------------------- 1 | -- Examples of Cast Calculus Label-Dependent Lambda Calculus 2 | -- Comparison of functions without and with dynamic type casts 3 | -- Interprets function application of section 2.1 example 4 | -- (Label-Dependent Lambda Calculus and Gradual Typing, 2021) 5 | 6 | type Bool : ~un = {'T, 'F} 7 | 8 | val not : (b: Bool) -> Bool 9 | val not (b: Bool) = (case b {'T: 'F, 'F: 'T}) 10 | 11 | val f1 : (x : Int) -> Int 12 | val f1 = fn(x: Int) x 13 | 14 | val f1' : (x : *) -> Int 15 | val f1' = fn(x : *) (x : * => Int) 16 | 17 | val f : (x: Bool) -> (y: case x {'T: Int, 'F: Bool}) -> case x {'T: Int, 'F: Bool} 18 | val f = fn(x: Bool) fn(y: case x {'T: Int, 'F: Bool}) case x {'T: 17+y, 'F: not y} 19 | 20 | val f' : (x: Bool) -> (y: *) -> case x {'T: Int, 'F: Bool} 21 | val f' = fn(x: Bool) fn(y: *) case x {'T: 17 + (y : * => Int), 'F: not (y : * => Bool)} 22 | 23 | val main = f' 'F ('T : Bool => *) 24 | -------------------------------------------------------------------------------- /examples/depsum.ldgv: -------------------------------------------------------------------------------- 1 | -- Pair types in Label-Dependent Lambda Calculus 2 | -- Typechecks pairs and functions 3 | 4 | type Bool : ~un = {'True,'False} 5 | 6 | val f1 = 7 | < x = 'a, 42 > 8 | 9 | val f1a = 10 | < x = 'a, case x of {'a : 42, 'b : 'True} > 11 | 12 | val f1bz (z : {'a, 'b}) = 13 | < x = z, case z of {'a : 42, 'b : 'True} > 14 | 15 | val f1b (z : {'a, 'b}) = 16 | < x = z, case x of {'a : 42, 'b : 'True} > 17 | 18 | val f2 19 | (g : (x : {'a, 'b}) -> case x of {'a : Int, 'b : Bool}) 20 | (y : {'a, 'b}) 21 | = 22 | < z = case y of {'a : 'b, 'b : 'a}, g z > 23 | -------------------------------------------------------------------------------- /examples/example-inputs.txt: -------------------------------------------------------------------------------- 1 | (x:{'a,'b})-> Int <: (x:{'b})->Int 2 | 3 | (x:{'a,'b})-> case x of {'a : Int, 'b : Unit} <: (x:{'a,'b})->case x of {'a : Int, 'b:Unit} 4 | 5 | (x:{'a,'b})-> case x of {'a : Int, 'b : Unit} <: (x:{'a})->case x of {'a : Int, 'b:Unit} 6 | 7 | (x:{'a,'b})-> case x of {'a : Int, 'b : Unit} <: (x:{'a})->case x of {'a : Int} 8 | 9 | {'a} <: {'a,'b} 10 | 11 | [ x : {'a}] |- case x of {'a : Int, 'b : Unit} <: case x of {'a : Int} 12 | 13 | (x:{'a,'b}) -> Unit <: (x:{'a}) -> case x of { 'a : Unit , 'b : Int } 14 | 15 | 16 | (x:{'a}) -> case x of {'a : {'b} } <: (y:{'a}) -> {'b, 'c} 17 | 18 | (x:{'a}) -> ((y : case x of {'a : {'b} }) -> {'xxx}) <: (x:{'a}) -> ((y : {'b}) -> {'xxx}) 19 | 20 | (x:{'a}) -> ((y : {'b}) -> {'xxx}) <: (x:{'a}) -> ((y : case x of {'a : {'b} }) -> {'xxx}) 21 | 22 | (x:{'a}) -> ((y : {'b,'c}) -> ((z : {'zz}) -> {'xxx})) <: 23 | (x:{'a}) -> ((y : case x of {'a : {'c} }) -> ((z : case y of {'c : {'zz} }) -> {'xxx})) 24 | 25 | 26 | {'a} \/ {'b} 27 | 28 | (x:Int)->{'a} \/ (x:Int)->{'b} 29 | 30 | (x:{'a,'b})-> Int \/ (x:{'b,'c})-> Int 31 | 32 | (x:{'a,'b})-> Int \/ (x:{'b,'c})-> case x of {'b : Int , 'c : Unit } 33 | 34 | (x:{'a,'b}) -> Unit \/ (x:{'a}) -> case x of { 'a : Unit , 'b : Int } 35 | 36 | (x:{'a,'b}) -> case x of { 'a : Unit , 'b : Int } \/ (x:{'a}) -> Unit 37 | 38 | 39 | -------------------------------------------------------------------------------- /examples/gradualtest.ldgv: -------------------------------------------------------------------------------- 1 | type Bool : ~un = {'T, 'F} 2 | 3 | val not : (b: Bool) -> Bool 4 | val not (b: Bool) = (case b {'T: 'F, 'F: 'T}) 5 | 6 | val f (x : *) 7 | ( y : case ( x : * => Bool) of { 'T : Int , 'F : { 'T , 'F } } ) 8 | = (case (x : * => Bool) of { 'T : 42 + y , 'F : (case y of {'T : "a" , 'F : 4 }) }) 9 | 10 | -- fails unless gradual 11 | --val f' = f 'T 1 12 | 13 | val f'' = f ( 'F : Bool => *) ('T) 14 | 15 | val f''' = f ( 'T : { 'T } => *) 1 16 | 17 | val f1 = case (( 'T : Bool => *) : * => Bool) of {'T : 22 , 'F : "a" } 18 | 19 | --val f2 = case (( 'T : Int => *) : * => Bool) of {'T : 22 , 'F : "a" } fails 20 | 21 | --val f3 = case (( 'T : Bool => *) : * => Int) of {'T : 22 , 'F : "a" } fails 22 | 23 | --val f4 = case (( 'T : Bool => Int) : * => Bool) of {'T : 22 , 'F : "a" } fails 24 | 25 | val f5 = fn (x: *) 26 | fn (y: case (x: * => Bool) {'T: Int, 'F: { 'T , 'F } }) 27 | case (x: * => Bool) {'T: 17+y, 'F: not y} 28 | 29 | -- val f5' = f5 (1: Int => *) (2: Int => *) fails 30 | -------------------------------------------------------------------------------- /examples/just-f2.ccldgv: -------------------------------------------------------------------------------- 1 | 2 | -- Examples from section 2 of the paper "Label Dependent Lambda Calculus and Gradual Typing.pdf" (2021) 3 | -- Also used in unit tests in tests/UtilsFuncCcldlc.hs 4 | 5 | type Bool : ~un = {'T, 'F} 6 | 7 | val not : (b: Bool) -> Bool 8 | val not (b: Bool) = (case b {'T: 'F, 'F: 'T}) 9 | 10 | 11 | -- This is the second GLDLC function: 12 | -- f2 :: Π(x: *).Π(y: case x {'T: Int, 'F: Bool}).case x {'T: Int, 'F: Bool} 13 | 14 | -- This is from the internal CCLDLC representation: 15 | val f2' : (x: *) -> (y: case (x: * => Bool) {'T: Int, 'F: Bool}) -> case (x: * => Bool) {'T: Int, 'F: Bool} 16 | val f2' = 𝜆(x: *) 17 | 𝜆(y: case (x: * => Bool) {'T: Int, 'F: Bool}) 18 | case (x: * => Bool) {'T: 17+y, 'F: not y} 19 | 20 | -------------------------------------------------------------------------------- /examples/just-f3.ccldgv: -------------------------------------------------------------------------------- 1 | -- Examples from section 2 of the paper "Label Dependent Lambda Calculus and Gradual Typing.pdf" (2021) 2 | -- Also used in unit tests in tests/UtilsFuncCcldlc.hs 3 | 4 | type Bool : ~un = {'T, 'F} 5 | 6 | val not : Bool -> Bool 7 | -- val not (b: Bool) = (case b {'T: 'F, 'F: 'T}) 8 | 9 | 10 | -- Conversion from * to case type 11 | type Direction : ~un = {'L, 'R} 12 | 13 | -- -- Good! 14 | -- val f3'true = 15 | -- 𝜆(y: *) 16 | -- 𝜆(z: case (y: * => Direction) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 17 | -- case (y: * => Direction) 18 | -- {'T: (y : * => Bool), 'F: not (y : * => Bool), 'L: z, 'R: not z} 19 | 20 | -- Good! 21 | -- val f3'false = 22 | -- 𝜆(y: *) 23 | -- 𝜆(z: case (y: * => Bool) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 24 | -- case (y: * => Bool) 25 | -- {'T: (y : * => Direction), 'F: not (y : * => Bool), 'L: z, 'R: not z} 26 | 27 | 28 | 29 | --val f3 : 30 | -- (x: Bool) 31 | -- -> (y: *) 32 | -- -> (z: case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 33 | -- -> case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool} 34 | 35 | -- Good! 36 | -- val f3'castexpanded = 37 | -- 𝜆(x: Bool) 38 | -- 𝜆(y: *) 39 | -- 𝜆(z: case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 40 | -- case x {'T: 41 | -- case (y: * => Direction) 42 | -- {'T: (y : * => Bool), 'F: not (y : * => Bool), 'L: z, 'R: not z} , 43 | -- 'F: 44 | -- case (y: * => Bool) 45 | -- {'T: (y : * => Bool), 'F: not (y : * => Bool), 'L: z, 'R: not z} 46 | -- } 47 | 48 | -- original: still failing... 49 | 50 | val f3' = 51 | 𝜆(x: Bool) 52 | 𝜆(y: *) 53 | 𝜆(z: case (y: * => case x {'T: Direction, 'F: Bool}) {'T: Direction, 'F: Bool, 'L: Bool, 'R: Bool}) 54 | case (y: * => case x {'T: Direction, 'F: Bool}) 55 | {'T: (y : * => Bool), 'F: not (y : * => Bool), 'L: z, 'R: not z} 56 | -------------------------------------------------------------------------------- /examples/mymap.gldgv: -------------------------------------------------------------------------------- 1 | -- Example of Gradual Label-Dependent Lambda Calculus 2 | -- Example of typed map, see section 2.2 3 | -- (Label-Dependent Lambda Calculus and Gradual Typing, 2021) 4 | 5 | type Bool : ~un = {'True, 'False} 6 | 7 | type A : ~unit = Unit 8 | type B : ~unit = Unit 9 | type ListA : ~un = Int 10 | type ListB : ~un = Double 11 | type ArrayA : ~un = String 12 | type ArrayB : ~un = Unit 13 | 14 | val arraymap : (f : (x:A) -> B) -> ((xs:ArrayA) -> ArrayB) 15 | val listmap : (f : (x:A) -> B) -> (xs:ListA) -> ListB 16 | val arraytolist : (xs:ArrayB) -> ListB 17 | val arrayoflist : (xs:ListB) -> ArrayB 18 | 19 | val mymap = fn (b : Bool) fn (f : (z:A) -> B) fn (x : *) 20 | case b {'True: arraymap f x, 'False: listmap f x} 21 | 22 | val typedmap = fn (b : Bool) fn (f : (z:A) -> B) fn (x : case b {'True: ArrayA, 'False: ListA}) 23 | case b {'True: arraymap f x, 'False: listmap f x} 24 | 25 | val dynmap = fn (b : *) fn (f : (z:A) -> B) fn (x : case b {'True: ArrayA, 'False: ListA}) 26 | case b {'True: arraymap f x, 'False: listmap f x} 27 | 28 | val dyn2map = fn (b : *) fn (f : *) fn (x : case b {'True: ArrayA, 'False: ListA}) 29 | case b {'True: arraymap f x, 'False: listmap f x} 30 | 31 | val dyn3map = fn (b : *) fn (f : *) fn (x : *) 32 | case b {'True: arraymap f x, 'False: listmap f x} 33 | 34 | val mymap2 = fn (b : Bool) fn (f : (z:A) -> B) fn (x : *) 35 | case b {'True: arraytolist (arraymap f x), 'False: arrayoflist (listmap f x)} 36 | 37 | val typedmap2 = fn (b : Bool) fn (f : (z:A) -> B) fn (x : case b {'True: ArrayA, 'False: ListA}) 38 | case b {'True: arraytolist (arraymap f x), 'False: arrayoflist (listmap f x)} 39 | 40 | val checkedmap2 : 41 | (b : Bool) -> 42 | (f : (z:A) -> B) -> 43 | (x : case b {'True: ArrayA, 'False: ListA}) -> 44 | (case b {'True: ListA, 'False: ArrayA}) 45 | val checkedmap2 = 46 | fn (b : Bool) 47 | fn (f : (z:A) -> B) 48 | fn (x : case b {'True: ArrayA, 'False: ListA}) 49 | case b {'True: arraytolist (arraymap f x), 'False: arrayoflist (listmap f x)} 50 | -------------------------------------------------------------------------------- /examples/natsum.ldgv: -------------------------------------------------------------------------------- 1 | -- Example of Label-Dependent Session Types 2 | -- Typechecks recursion over natural numbers using natrec 3 | 4 | type End : ~unit = Unit 5 | 6 | type SUMC : ~ssn = 7 | ?(n : Nat) 8 | natrec n 9 | { !Int. End 10 | , A. ?Int. A 11 | } 12 | 13 | val sum (ch_in : SUMC) : End = 14 | let = recv ch_in in 15 | (natrec n 16 | { fn (m : Int) fn (c : !Int.End) 17 | send c m 18 | , n1 . A . (y : (m : Int) -> (a:A) -> End) . 19 | fn (m: Int) fn (c : ?Int. A) 20 | let = recv c in 21 | y (k + m) c 22 | }) 0 ch 23 | -------------------------------------------------------------------------------- /examples/natsum2-new.ldgv: -------------------------------------------------------------------------------- 1 | -- Example of Cast Calculus Label-Dependent Lambda Calculus 2 | -- Using new_natrec to calculate sum of n numbers 3 | 4 | type SUMF : ~un = 5 | (n : Nat) -> 6 | natrec n 7 | { 8 | Int 9 | , A. (x : Int) -> A 10 | } 11 | 12 | val sumf ( n : Nat) = 13 | (natrec n 14 | { 15 | fn (acc : Int) acc 16 | , n1 . A . (y : (acc : Int) -> A) . 17 | fn (acc : Int) fn (x : Int) 18 | y (acc + x) 19 | }) 0 20 | 21 | val newsumf ( n : Nat ) = 22 | -- (new_natrec f : n . A . T { Mzero, n1.Msucc }) n 0 23 | (new_natrec f : n1 . A . (acc : Int) -> A 24 | { 25 | fn (acc: Int) acc, -- zero: Int -> Int 26 | n1. fn (acc : Int) fn (x : Int) f n1 (acc + x) -- succ: Int -> Int -> A 27 | }) 28 | -- : (n: Nat) -> (acc: Int) -> natrec n { Int, A. (x: Int) -> A } 29 | n 30 | 0 31 | 32 | val r0 = sumf 0 33 | val r1 = sumf 1 42 34 | val r2 = sumf 2 17 4 35 | 36 | val newr0 = newsumf 0 37 | val newr1 = newsumf 1 42 38 | val newr2 = newsumf 2 17 4 39 | 40 | val main = newsumf 2 17 4 41 | 42 | -- example reductions (new) 43 | 44 | -- (new_natrec f : n . A . (y : (acc : Int) -> A) { 45 | -- n1. fn (acc : Int) fn (x : Int) f n1 (acc + x), 46 | -- fn (acc: Int) acc 47 | -- }) 0 48 | -- -> fn (acc: Int) acc 49 | 50 | -- (new_natrec f : n . A . (y : (acc : Int) -> A) { 51 | -- n1. fn (acc : Int) fn (x : Int) f n1 (acc + x), 52 | -- fn (acc: Int) acc 53 | -- }) (S n1) 54 | -- -> fn (acc : Int) fn (x : Int) (new_natrec f ...) n1 (acc + x) 55 | 56 | -- transformation old -> new: 57 | 58 | -- natrec V { Mzero, n1 . A . (y : T) . Msucc } 59 | -----> 60 | -- (new_natrec f : n . A . T { Mzero, n1 . Msucc[y := f n1] }) V 61 | 62 | -------------------------------------------------------------------------------- /examples/natsum2-rec.ldgv: -------------------------------------------------------------------------------- 1 | -- Example of untyped recursion over natural numbers using rec 2 | -- sumf_rec n m calculates the sum over n numbers with initial value m 3 | 4 | val sumf_rec = 5 | rec 6 | f 7 | (n1 . (fn (acc : Int) fn (x : Int) f n1 (acc + x))) 8 | (fn (acc : Int) acc) 9 | 10 | val main = sumf_rec 5 0 1 2 3 4 5 11 | -------------------------------------------------------------------------------- /examples/natsum2.ldgv: -------------------------------------------------------------------------------- 1 | -- Example of Label-Dependent Lambda Calculus 2 | -- (no Session Types) 3 | -- Typechecks and interprets natrec used for 4 | -- calculating the sum over n numbers 5 | 6 | type SUMF : ~un = 7 | (n : Nat) -> 8 | natrec n 9 | { 10 | Int 11 | , A. (x : Int) -> A 12 | } 13 | 14 | val sumf ( n : Nat) = 15 | (natrec n 16 | { 17 | fn (acc : Int) acc 18 | , n1 . A . (y : (acc : Int) -> A) . 19 | fn (acc : Int) fn (x : Int) 20 | y (acc + x) 21 | }) 0 22 | 23 | val r0 = sumf 0 24 | val r1 = sumf 1 42 25 | val r2 = sumf 2 17 4 26 | 27 | val main = sumf 5 1 2 3 4 5 28 | -------------------------------------------------------------------------------- /examples/node.ldgv: -------------------------------------------------------------------------------- 1 | -- Example of Label-Dependent Session Types 2 | -- From section 2.3 3 | 4 | type End : ~unit = Unit 5 | 6 | type NodeC :! ~ssn = 7 | !( tag : {'Empty, 'Node}) 8 | case tag of 9 | { 'Empty : !Unit. End 10 | , 'Node : !Int. End 11 | } 12 | 13 | type Node : ~un = 14 | -- Sigma 15 | [ tag : {'Empty, 'Node} 16 | , case tag of { 'Empty: Unit, 'Node: Int } ] 17 | 18 | val recvNode (c : dualof NodeC) : Node = 19 | let = recv c in 20 | let = recv c in 21 | < tag = tag , v > 22 | 23 | val sendNode (n : Node) (c : NodeC) = 24 | let < tag , v > = n in 25 | let c = send c tag in 26 | send c v 27 | 28 | -------------------------------------------------------------------------------- /examples/node.out: -------------------------------------------------------------------------------- 1 | Right (TFun MMany "c" (TName True "NodeC") (TPair MMany "tag" (TLab ["'Empty","'Node"]) (TCase (Var "tag") [("'Empty",TUnit),("'Node",TInt)])),[]) 2 | Right (TFun MMany "n" (TName False "Node") (TFun MMany "c" (TName False "NodeC") (TName False "Close")),[]) -------------------------------------------------------------------------------- /examples/noderec.ldgv: -------------------------------------------------------------------------------- 1 | -- Example of Label-Dependent Session Types 2 | -- From section 2.3 3 | 4 | type Close : ~unit = Unit 5 | 6 | type Node : ~un = 7 | [ tag : {'Empty, 'Node}, 8 | case tag of { 'Empty: Unit 9 | , 'Node : [ Int, Node ] } 10 | ] 11 | 12 | type NodeC :! ~ssn = 13 | !( tag : {'Empty, 'Node}) 14 | case tag of 15 | { 'Empty : !Unit . Close 16 | , 'Node : !Int . NodeC } 17 | 18 | val recvList (c : dualof NodeC) : Node = 19 | let = recv c in 20 | let = recv c in 21 | case tag of 22 | { 'Empty : 23 | , 'Node : > 24 | } 25 | 26 | val recvListb (c : dualof NodeC) : Node = 27 | let = recv c in 28 | let = recv c in 29 | 33 | } 34 | > 35 | -------------------------------------------------------------------------------- /examples/person.gldgv: -------------------------------------------------------------------------------- 1 | -- Example of Gradual Label-Dependent Lambda Calculus 2 | 3 | type BOOL : ~un = {'True, 'False} 4 | 5 | type PERSON : ~un = (x : {'Name, 'Age, 'Flag}) -> case x of {'Name: Int, 'Age: Nat, 'Flag: BOOL} 6 | 7 | type PERSONX : ~un = (x : *) -> case x of {'Name: Int, 'Age: Nat, 'Flag: BOOL} 8 | 9 | val jim (x : {'Name,'Age, 'Flag}) = 10 | case x of 11 | { 'Name: 65536 12 | , 'Age: 27 13 | , 'Flag: 'False 14 | } 15 | 16 | val ageof (p : PERSON) = p 'Age 17 | 18 | val ageofX (p : PERSONX) = p 'Age 19 | 20 | val main = ageofX jim 21 | 22 | val fooOfX (p : PERSONX) = p 'Foo 23 | 24 | val intOfNat (n : Nat) = -42 25 | 26 | val intOfBool (b : BOOL) = case b {'True: -1, 'False: 0} 27 | 28 | val intOfField (f : *) (p : PERSONX) : Int = 29 | case f of { 'Name: p f, 'Age: intOfNat (p f), 'Flag: intOfBool (p f) } 30 | 31 | val intOfName (p : PERSONX) = intOfField 'Name p 32 | 33 | val intOfAge (p : PERSONX) = intOfField 'Age p 34 | 35 | val intOfFlag (p : PERSONX) = intOfField 'Flag p 36 | 37 | val intOfFoo (p : PERSONX) = intOfField 'Foo p 38 | -------------------------------------------------------------------------------- /examples/simple.ldgv: -------------------------------------------------------------------------------- 1 | type End : ~unit = Unit 2 | 3 | 4 | type EOS : ! ~un = {'EOS} 5 | type End : ! ~unit = Unit 6 | 7 | type TClient : ! ~ssn = 8 | !( l : {'neg, 'add}) 9 | case l of 10 | { 'neg : !Int. ?Int. ?EOS. End 11 | , 'add : !Int. !Int. ?Int. ?EOS. End 12 | } 13 | 14 | type LClient : ! ~ssn = 15 | !{'neg}. !Int. ?Int. ?EOS. End 16 | 17 | val lClient (d : TClient) (x : Int) : Int = 18 | let d1 = (send d) 'neg in 19 | let d2 = (send d1) x in 20 | let = recv d2 in 21 | let = recv d3 in 22 | r 23 | 24 | type TServer : ! ~ssn = 25 | ? ( x : { 'neg, 'add }) 26 | case x of 27 | { 'neg : ?Int. !Int. !EOS. End 28 | , 'add : ?Int. ?Int. !Int. !EOS. End 29 | } 30 | 31 | val lServer (c : TServer) : End = 32 | let < l , c1 > = recv c in 33 | let < x , c2 > = recv c1 in 34 | case l of 35 | { 'neg : 36 | let c3 = send c2 (-x) in 37 | send c3 'EOS 38 | , 'add : 39 | let < y , c3 > = recv c2 in 40 | let c4 = send c3 (x + y) in 41 | send c4 'EOS 42 | } 43 | 44 | val main : Int 45 | val main = 46 | let = (new TClient) in 47 | let y = fork (lServer b) in 48 | ((lClient a) 42) 49 | -------------------------------------------------------------------------------- /examples/simple_recursion.ldgv: -------------------------------------------------------------------------------- 1 | type End : ~unit = Unit 2 | 3 | type SUMC : ~ssn = 4 | ?(n : Nat) 5 | natrec n 6 | { !Int. End 7 | , A. ?Int. A 8 | } 9 | 10 | type SUM : ~ssn = 11 | !(n : Nat) 12 | natrec n 13 | { ?Int. End 14 | , A. !Int. A 15 | } 16 | 17 | -- sum up incoming numbers 18 | val sum (ch_in : SUMC) : End = 19 | let = recv ch_in in 20 | (natrec n 21 | { fn (m : Int) fn (c : !Int.End) 22 | send c m 23 | , n1 . A . (y : (m : Int) -> (a:A) -> End) . 24 | fn (m: Int) fn (c : ?Int. A) 25 | let = recv c in 26 | y (k + m) c 27 | } 28 | ) 0 ch 29 | 30 | -- sends the numbers n to 1 31 | val sendsum (ch_out : SUM) (n : Nat) : Int = 32 | let ch = send ch_out n in 33 | (natrec n 34 | { fn (c : ?Int.End) 35 | fst (recv c) 36 | , n1 . A . (y : (a:A) -> Int) . 37 | fn (c : !Int. A) 38 | y (send c (n1 + 1)) 39 | }) ch 40 | 41 | -- | the summation should be (n^2 + n) / 2 -> with 1000 it should return 500500 42 | val main : Int 43 | val main = 44 | let = new SUMC in 45 | let x = fork (sum a) in 46 | sendsum b 1000 47 | -------------------------------------------------------------------------------- /examples/tclient.ldgv: -------------------------------------------------------------------------------- 1 | type EOS : ! ~un = {'EOS} 2 | type End : ! ~unit = Unit 3 | 4 | type TClient : ! ~ssn = 5 | !( l : {'neg, 'add}) 6 | case l of 7 | { 'neg : !Int. ?Int. ?EOS. End 8 | , 'add : !Int. !Int. ?Int. ?EOS. End 9 | } 10 | 11 | type LClient : ! ~ssn = 12 | !{'neg}. !Int. ?Int. ?EOS. End 13 | 14 | TClient <: LClient 15 | 16 | val lClient (d : TClient) (x : Int) : Int = 17 | let d = send d 'neg in 18 | let d = send d x in 19 | let = recv d in 20 | let = recv d in 21 | r 22 | -------------------------------------------------------------------------------- /examples/tclient.out: -------------------------------------------------------------------------------- 1 | Right (TFun MMany "d" (TName False "TClient") (TFun MMany "x" TInt TInt),[]) 2 | -------------------------------------------------------------------------------- /examples/tserver.ldgv: -------------------------------------------------------------------------------- 1 | type EOS : ! ~un = {'EOS} 2 | type End : ! ~unit = Unit 3 | 4 | type TServer : ! ~ssn = 5 | ? ( x : { 'neg, 'add }) 6 | case x of 7 | { 'neg : ?Int. !Int. !EOS. End 8 | , 'add : ?Int. ?Int. !Int. !EOS. End 9 | } 10 | 11 | val lServer1 (c : TServer) : End = 12 | let < l , c > = recv c in 13 | let < x , c > = recv c in 14 | case l of 15 | { 'neg : 16 | let c = send c (-x) in 17 | send c 'EOS 18 | , 'add : 19 | let < y , c > = recv c in 20 | let c = send c (x + y) in 21 | send c 'EOS 22 | } 23 | -------------------------------------------------------------------------------- /examples/tserver.out: -------------------------------------------------------------------------------- 1 | Right (TFun MMany "c" (TName False "TServer") TUnit,[]) 2 | -------------------------------------------------------------------------------- /examples/type-equivalence.txt: -------------------------------------------------------------------------------- 1 | (x:{'a,'b})-> Int =: (x:{'b,'a})->Int 2 | 3 | (x:{'a,'b})-> case x of {'a : Int, 'b : Unit} =: (y:{'b,'a})->case y of { 'b:Unit, 'a : Int} 4 | 5 | (x:{'a,'b})-> case x of {'a : Int, 'b : Int} =: (y:{'b,'a})-> Int 6 | 7 | type TServerRec : ! ~ssn = 8 | ? ( x : { 'neg, 'add }) 9 | case x of 10 | { 'neg : ?Int. !Int. TServerRec 11 | , 'add : ?Int. ?Int. !Int. TServerRec 12 | } 13 | 14 | TServerRec =: TServerRec 15 | 16 | type TServerRecSkewed : ! ~ssn = 17 | ? ( x : { 'neg, 'add }) 18 | ?Int. 19 | case x of 20 | { 'neg : !Int. TServerRecSkewed 21 | , 'add : ?Int. !Int. TServerRecSkewed 22 | } 23 | 24 | TServerRec =: TServerRecSkewed 25 | 26 | type TServerStrange :! ~ssn = 27 | !Int. 28 | ? ( x : { 'neg, 'add }) 29 | ?Int. 30 | case x of 31 | { 'neg : TServerStrange 32 | , 'add : ?Int. TServerStrange 33 | } 34 | 35 | type TServerHead :! ~ssn = 36 | ? ( x : { 'neg, 'add }) 37 | case x of 38 | { 'neg : ?Int. TServerStrange 39 | , 'add : ?Int. ?Int. TServerStrange 40 | } 41 | 42 | TServerRec =: TServerHead 43 | -------------------------------------------------------------------------------- /exe/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TupleSections #-} 8 | module Main (main) where 9 | 10 | import Control.Applicative 11 | import Control.Monad 12 | import Control.Monad.Reader 13 | import Data.ByteString.Builder 14 | import Data.Foldable 15 | import Data.Maybe 16 | import Data.Monoid 17 | import System.Exit 18 | import System.FilePath 19 | import UnliftIO 20 | import qualified Options.Applicative as Opts 21 | 22 | import Kinds 23 | import Output 24 | import Parsing 25 | import qualified C.Compile as C 26 | import qualified C.Generate as C 27 | import qualified Interpreter as I 28 | import qualified ProcessEnvironment as P 29 | import qualified Syntax 30 | import qualified Typechecker as T 31 | 32 | data CompileMode 33 | = CompileC 34 | | CompileObject 35 | | CompileLink String 36 | deriving (Show, Eq) 37 | 38 | data CompileOpts = Compile 39 | { compileInputs :: ![FilePath] 40 | , compileOutput :: !(Maybe FilePath) 41 | , compileMainId :: !(Maybe Syntax.Ident) 42 | , compileMainSig :: !(Maybe Syntax.Type) 43 | , compileMode :: !CompileMode 44 | , compileEnv :: !C.Env 45 | , compileGradual :: !Bool 46 | } 47 | deriving stock (Show) 48 | 49 | data TypecheckOpts = Typecheck 50 | { typecheckInputs :: ![FilePath] 51 | , typecheckGradual :: !Bool 52 | } 53 | 54 | data InterpreterOpts = Interpreter 55 | { interpreterInputs :: ![FilePath] 56 | , interpreterGradual :: !Bool 57 | } 58 | 59 | actionParser :: Opts.Parser (Action ()) 60 | actionParser = commands 61 | where 62 | commands = Opts.hsubparser $ mconcat 63 | [ Opts.command "compile" 64 | $ Opts.info compileParser 65 | $ Opts.progDesc "Parse, typecheck and transpile an LDGV/LDST program to C." 66 | , Opts.command "interpret" 67 | $ Opts.info interpretParser 68 | $ Opts.progDesc "Parse, typecheck and interpret an LDGV/LDST program." 69 | , Opts.command "typecheck" 70 | $ Opts.info typecheckParser 71 | $ Opts.progDesc "Only typecheck an LDGV/LDST program." 72 | ] 73 | 74 | typecheckParser = do 75 | typecheckGradual <- gradualSwitch 76 | typecheckInputs <- inPathArgs 77 | pure $ typecheck Typecheck{..} 78 | 79 | interpretParser = do 80 | interpreterGradual <- gradualSwitch 81 | interpreterInputs <- inPathArgs 82 | pure $ interpret Interpreter{..} 83 | 84 | compileParser = do 85 | compileMainId <- optional $ Opts.strOption $ mconcat 86 | [ Opts.long "main" 87 | , Opts.short 'm' 88 | , Opts.metavar "DECL" 89 | , Opts.help "Generate a ‘main()’ function, it evaluates the given \ 90 | \declaration which must have a type signature and have no \ 91 | \parameters to do something useful." 92 | ] 93 | compileMainSig <- optional $ Opts.option (Opts.eitherReader parseType) $ mconcat 94 | [ Opts.long "main-sig" 95 | , Opts.short 's' 96 | , Opts.metavar "TYPE" 97 | , Opts.help "Provides a type signature for the --main declaration \ 98 | \without having to edit the source code." 99 | ] 100 | compileOutput <- optional $ Opts.strOption $ mconcat 101 | [ Opts.long "output" 102 | , Opts.short 'o' 103 | , Opts.metavar "FILE" 104 | , Opts.help "Write the result to FILE, this defaults to STDOUT in -C mode." 105 | ] 106 | compileMode <- pure CompileC <|> asum 107 | [ Opts.flag' CompileC $ mconcat 108 | [ Opts.short 'C' 109 | , Opts.help "Generate C code, this is the default if none of -O or -L is given." 110 | ] 111 | , Opts.flag' CompileObject $ mconcat 112 | [ Opts.short 'O' 113 | , Opts.help "Generate C code and compile to an object file." 114 | ] 115 | , fmap CompileLink $ Opts.strOption $ mconcat 116 | [ Opts.short 'L' 117 | , Opts.long "link" 118 | , Opts.metavar "BACKEND" 119 | , Opts.help "Generate C code and link to an executable with BACKEND." 120 | ] 121 | ] 122 | compileEnv <- do 123 | cc <- Opts.strOption $ mconcat 124 | [ Opts.long "cc" 125 | , Opts.value "cc" 126 | , Opts.showDefault 127 | , Opts.metavar "CC" 128 | , Opts.help "Use CC to compile and link programs in modes -O and -L." 129 | ] 130 | opts <- many $ Opts.strOption $ mconcat 131 | [ Opts.long "cc-option" 132 | , Opts.metavar "OPT" 133 | , Opts.help "Additional option passed to CC. \ 134 | \This option can be given multiple times." 135 | ] 136 | opts' <- many $ Opts.strOption $ mconcat 137 | [ Opts.long "cc-options" 138 | , Opts.metavar "OPTS" 139 | , Opts.help "Additional options passed to CC, split on whitespace. \ 140 | \This option can be given multiple times." 141 | ] 142 | pure C.Env{ envCC = cc, envFlags = opts ++ concatMap words opts', envVerbose = True } 143 | compileGradual <- gradualSwitch 144 | compileInputs <- inPathArgs 145 | pure $ compile Compile{..} 146 | 147 | inPathArgs :: Opts.Parser [FilePath] 148 | inPathArgs = many $ Opts.strArgument $ mconcat 149 | [ Opts.metavar "SRC-FILES" 150 | , Opts.help "Read the input from SRC-FILES, uses STDIN if no path is given." 151 | ] 152 | 153 | gradualSwitch :: Opts.Parser Bool 154 | gradualSwitch = Opts.switch $ mconcat 155 | [ Opts.long "gradual" 156 | , Opts.short 'g' 157 | , Opts.help "Use gradual typing" 158 | ] 159 | 160 | actionParserInfo :: Opts.ParserInfo (Action ()) 161 | actionParserInfo = Opts.info (actionParser <**> Opts.helper) $ mconcat 162 | [ Opts.progDesc "An implementation of Label Dependent Session Types (LDST)." 163 | , Opts.footer "Authors: \ 164 | \Thomas Leyh (CCLDLC implementation), \ 165 | \Nils Hagner (interpreter, web frontend), \ 166 | \Janek Spaderna (C backend, command line frontend), \ 167 | \Peter Thiemann (parser, typechecker)" 168 | ] 169 | 170 | main :: IO () 171 | main = do 172 | let prefs = Opts.prefs Opts.showHelpOnEmpty 173 | action <- Opts.customExecParser prefs actionParserInfo 174 | runTerminalSize action 175 | 176 | typecheck :: TypecheckOpts -> Action () 177 | typecheck Typecheck{ typecheckInputs = inputs, typecheckGradual = gradual } = do 178 | let tcOptions = T.Options {..} 179 | decls <- parseInput inputs 180 | liftIO case T.typecheck tcOptions decls of 181 | Right _ -> putStrLn "Good!" 182 | Left err -> putStrLn $ "Error: " ++ err 183 | 184 | interpret :: InterpreterOpts -> Action () 185 | interpret Interpreter{ interpreterInputs = inputs, interpreterGradual = gradual } = do 186 | let tcOptions = T.Options {..} 187 | res <- try $ do 188 | decls <- parseInput inputs 189 | case T.typecheck tcOptions decls of 190 | Right a -> pure a 191 | Left err -> fail $ "Error: " ++ err 192 | liftIO $ I.interpret decls 193 | liftIO $ putStrLn $ either 194 | (\v -> "Error: " ++ show v) 195 | (\v -> "Result: " ++ show v) 196 | (res :: Either SomeException P.Value) 197 | 198 | compile :: CompileOpts -> Action () 199 | compile co = do 200 | mbackend <- case compileMode co of 201 | CompileC -> do 202 | generate co \b -> withOutput (compileOutput co) (`hPutBuilder` b) 203 | liftIO exitSuccess 204 | CompileObject -> pure Nothing 205 | CompileLink backend -> pure (Just backend) 206 | 207 | outputFP <- maybe 208 | (msgFatal "--output must be given for modes -O and -L.") 209 | pure 210 | (compileOutput co) 211 | 212 | -- The generated C code is written to a temporary file and then compiled/linked. 213 | let temporaryCCodeName = takeFileName outputFP <.> ".c" 214 | withSystemTempFile temporaryCCodeName \codeFP codeHandle -> do 215 | generate co (hPutBuilder codeHandle) 216 | hClose codeHandle 217 | 218 | let invocation = maybe 219 | (C.compile outputFP codeFP) 220 | (C.link outputFP [codeFP]) 221 | mbackend 222 | runReaderT invocation (compileEnv co) 223 | 224 | generate :: CompileOpts -> (Builder -> IO ()) -> Action () 225 | generate Compile{..} writeOutput = do 226 | when (isNothing compileMainId && isJust compileMainSig) do 227 | msgWarning "--main-sig is not used because no --main is given." 228 | 229 | let addSig' (ident, typ) = (Syntax.DSig ident Many typ :) 230 | let addSig = maybe id addSig' ((,) <$> compileMainId <*> compileMainSig) 231 | decls <- addSig <$> parseInput compileInputs 232 | let tcOptions = T.Options{ gradual = compileGradual } 233 | either msgFatal (liftIO . writeOutput) (T.typecheck tcOptions decls >> C.generate compileMainId decls) 234 | 235 | parseInput :: [FilePath] -> Action [Syntax.Decl] 236 | parseInput fps = do 237 | -- Unwraps a parse result of type @Maybe [Decl]@. 238 | let unwrap = liftIO . maybe exitFailure pure 239 | 240 | -- Like 'unwrap' above but combines multiple parse results before unwrapping. 241 | -- 242 | -- Using the `Ap` wrapper the many parse results are turned into one failed 243 | -- result should at least one parse have failed. 244 | let unwrapMany = unwrap . getAp . foldMap Ap 245 | 246 | if null fps 247 | then parseFile Nothing >>= unwrap 248 | else mapM (parseFile . Just) fps >>= unwrapMany 249 | 250 | parseFile :: Maybe FilePath -> Action (Maybe [Syntax.Decl]) 251 | parseFile mpath = do 252 | (name, src) <- liftIO $ case mpath of 253 | Nothing -> ("",) <$> getContents 254 | Just fp -> (fp,) <$> readFile fp 255 | 256 | case parseDecls src of 257 | Left err -> Nothing <$ formatMsg MsgError (Just name) err 258 | Right decls -> pure (Just decls) 259 | 260 | 261 | withOutput :: MonadUnliftIO m => Maybe FilePath -> (Handle -> m r) -> m r 262 | withOutput = maybe ($ stdout) (\fp -> withBinaryFile fp WriteMode) 263 | -------------------------------------------------------------------------------- /exe/Output.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | module Output where 9 | 10 | import Control.Monad.Reader 11 | import Prettyprinter 12 | import Prettyprinter.Util (reflow) 13 | import System.Exit 14 | import System.IO 15 | import qualified Data.Text as Text 16 | import qualified Prettyprinter.Render.Terminal as Terminal 17 | import qualified System.Console.Terminal.Size as Terminal 18 | 19 | newtype TerminalSize = TerminalSize (Maybe Int) 20 | 21 | type Action = ReaderT TerminalSize IO 22 | 23 | runTerminalSize :: Action a -> IO a 24 | runTerminalSize action = do 25 | !mcols <- stderrColumns 26 | runReaderT action (TerminalSize mcols) 27 | 28 | -- | Tries to determine the size of the terminal attached to stderr using the 29 | -- terminal-size package. 30 | -- 31 | -- On windows only @"System.Console.Terminal.Size".'Terminal.size'@ is 32 | -- available, this isn't suitable for the non-windows case: if stdout is 33 | -- redirected but stderr goes to the terminal it will return @Nothing@ instead 34 | -- of the actual terminal dimensions. 35 | stderrColumns :: MonadIO m => m (Maybe Int) 36 | stderrColumns = liftIO $ fmap Terminal.width <$!> size 37 | where 38 | size = 39 | #if defined(mingw32_HOST_OS) 40 | Terminal.size 41 | #else 42 | Terminal.hSize stderr 43 | #endif 44 | 45 | 46 | data MsgLevel 47 | = MsgError 48 | | MsgWarning 49 | 50 | msgWarning :: (MonadReader TerminalSize m, MonadIO m) => String -> m () 51 | msgWarning = formatMsg MsgWarning Nothing 52 | 53 | msgFatal :: (MonadReader TerminalSize m, MonadIO m) => String -> m a 54 | msgFatal msg = formatMsg MsgError Nothing msg >> liftIO exitFailure 55 | 56 | formatMsg :: (MonadIO m, MonadReader TerminalSize m) => MsgLevel -> Maybe FilePath -> String -> m () 57 | formatMsg level mfile msg = do 58 | let levelDoc = 59 | let (levelString, color) = case level of 60 | MsgError -> ("error", Terminal.Red) 61 | MsgWarning -> ("warning", Terminal.Yellow) 62 | in annotate (Terminal.color color) $ levelString <> ": " 63 | 64 | let fileDoc = flip foldMap mfile \file -> 65 | pretty file <> ": " 66 | 67 | let doc = mconcat 68 | [ annotate Terminal.bold $ fileDoc <> levelDoc 69 | , nest 4 $ reflow $ Text.pack msg 70 | ] 71 | 72 | TerminalSize mcols <- ask 73 | let prettyWidth = maybe Unbounded (\cols -> AvailablePerLine (min cols 80) 0.9) mcols 74 | let prettyOpts = defaultLayoutOptions { layoutPageWidth = prettyWidth } 75 | liftIO $ Terminal.renderIO stderr $ layoutPretty prettyOpts doc 76 | liftIO $ hPutChar stderr '\n' 77 | -------------------------------------------------------------------------------- /ldgv.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.18 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: ldgv 8 | version: 0.0.1 9 | synopsis: Frontend, interpreter and C backend for LDGV/LDST 10 | homepage: https://github.com/proglang/ldgv#readme 11 | bug-reports: https://github.com/proglang/ldgv/issues 12 | author: Thomas Leyh (CCLDLC implementation), 13 | Nils Hagner (web frontend, interpreter), 14 | Janek Spaderna (command line fronted, C backend), 15 | Peter Thiemann (parser, typechecker) 16 | maintainer: thiemann@informatik.uni-freiburg.de 17 | copyright: 2019-2021 Chair of Programming Languages, Uni Freiburg 18 | license: BSD3 19 | license-file: LICENSE 20 | build-type: Simple 21 | extra-doc-files: 22 | examples/add.ldgv 23 | examples/case-singleton.ldgv 24 | examples/casesub.ldgv 25 | examples/casetest.ldgv 26 | examples/cast-bot.ldgv 27 | examples/cast-collide.ldgv 28 | examples/cast-fail.ldgv 29 | examples/depsum.ldgv 30 | examples/gradualtest.ldgv 31 | examples/natsum.ldgv 32 | examples/natsum2-new.ldgv 33 | examples/natsum2-rec.ldgv 34 | examples/natsum2.ldgv 35 | examples/node.ldgv 36 | examples/noderec.ldgv 37 | examples/simple.ldgv 38 | examples/simple_recursion.ldgv 39 | examples/tclient.ldgv 40 | examples/tserver.ldgv 41 | examples/casts.ccldgv 42 | examples/depcast.ccldgv 43 | examples/just-f2.ccldgv 44 | examples/just-f3.ccldgv 45 | examples/mymap.gldgv 46 | examples/person.gldgv 47 | examples/example-inputs.txt 48 | examples/type-equivalence.txt 49 | examples/node.out 50 | examples/tclient.out 51 | examples/tserver.out 52 | data-files: 53 | c-support/runtime/LDST.h 54 | c-support/runtime/LDST_debug.h 55 | c-support/runtime/thpool.h 56 | c-support/runtime/LDST.c 57 | c-support/runtime/LDST_concurrent.c 58 | c-support/runtime/LDST_serial.c 59 | c-support/runtime/thpool.c 60 | 61 | source-repository head 62 | type: git 63 | location: https://github.com/proglang/ldgv 64 | 65 | library 66 | exposed-modules: 67 | C.Compile 68 | C.Generate 69 | Config 70 | Examples 71 | Interpreter 72 | Kinds 73 | Parsing 74 | Parsing.Grammar 75 | Parsing.Tokens 76 | ProcessEnvironment 77 | Syntax 78 | Typechecker 79 | other-modules: 80 | PrettySyntax 81 | TCSubtyping 82 | TCTyping 83 | TCXMonad 84 | C.CPS 85 | C.MonadStack 86 | Paths_ldgv 87 | hs-source-dirs: 88 | src 89 | ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing -Wno-unused-do-bind -Wno-unused-matches 90 | build-tools: 91 | alex 92 | , happy 93 | build-depends: 94 | array 95 | , base >=4.12 && <5 96 | , bytestring 97 | , containers 98 | , file-embed 99 | , filepath 100 | , lens 101 | , mtl 102 | , prettyprinter 103 | , text 104 | , transformers 105 | , typed-process 106 | , validation-selective 107 | default-language: Haskell2010 108 | 109 | executable ldgv 110 | main-is: Main.hs 111 | other-modules: 112 | Output 113 | hs-source-dirs: 114 | exe 115 | ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing -Wno-unused-do-bind -Wno-unused-matches -threaded -rtsopts -with-rtsopts=-N 116 | build-depends: 117 | base >=4.12 && <5 118 | , bytestring 119 | , filepath 120 | , ldgv 121 | , mtl 122 | , optparse-applicative 123 | , prettyprinter 124 | , prettyprinter-ansi-terminal 125 | , terminal-size 126 | , text 127 | , unliftio 128 | default-language: Haskell2010 129 | 130 | test-suite ldgv-test 131 | type: exitcode-stdio-1.0 132 | main-is: Spec.hs 133 | other-modules: 134 | ArithmeticSpec 135 | CcldlcSpec 136 | CSpec 137 | FunctionApplicationSpec 138 | FunctionSignaturesSpec 139 | InterpreterSpec 140 | LdlcSpec 141 | TypecheckerSpec 142 | Utils 143 | UtilsFuncCcldlc 144 | hs-source-dirs: 145 | test 146 | ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing -Wno-unused-do-bind -Wno-unused-matches -threaded -rtsopts -with-rtsopts=-N 147 | build-tool-depends: 148 | hspec-discover:hspec-discover 149 | build-depends: 150 | QuickCheck 151 | , array 152 | , base >=4.12 && <5 153 | , bytestring 154 | , containers 155 | , filepath 156 | , hspec 157 | , ldgv 158 | , mtl 159 | , text 160 | , typed-process 161 | , unliftio 162 | default-language: Haskell2010 163 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: ldgv 2 | version: 0.0.1 3 | github: "proglang/ldgv" 4 | synopsis: Frontend, interpreter and C backend for LDGV/LDST 5 | license: BSD3 6 | license-file: LICENSE 7 | author: 8 | - Thomas Leyh (CCLDLC implementation) 9 | - Nils Hagner (web frontend, interpreter) 10 | - Janek Spaderna (command line fronted, C backend) 11 | - Peter Thiemann (parser, typechecker) 12 | maintainer: "thiemann@informatik.uni-freiburg.de" 13 | copyright: "2019-2021 Chair of Programming Languages, Uni Freiburg" 14 | 15 | ghc-options: 16 | - -Wall 17 | - -Wcompat 18 | - -Wredundant-constraints 19 | - -Wno-name-shadowing 20 | - -Wno-unused-do-bind 21 | - -Wno-unused-matches 22 | 23 | extra-doc-files: 24 | - examples/*.ldgv 25 | - examples/*.ccldgv 26 | - examples/*.gldgv 27 | - examples/*.txt 28 | - examples/*.out 29 | 30 | data-files: 31 | - c-support/runtime/*.h 32 | - c-support/runtime/*.c 33 | 34 | dependencies: 35 | - base >=4.12 && <5 36 | - bytestring 37 | - filepath 38 | - mtl 39 | - text 40 | 41 | library: 42 | source-dirs: src 43 | other-modules: 44 | - PrettySyntax 45 | - TCSubtyping 46 | - TCTyping 47 | - TCXMonad 48 | - C.CPS 49 | - C.MonadStack 50 | - Paths_ldgv 51 | build-tools: 52 | - alex 53 | - happy 54 | dependencies: 55 | - array 56 | - containers 57 | - file-embed 58 | - lens 59 | - prettyprinter 60 | - transformers 61 | - typed-process 62 | - validation-selective 63 | 64 | tests: 65 | ldgv-test: 66 | main: Spec.hs 67 | source-dirs: test 68 | other-modules: 69 | - ArithmeticSpec 70 | - CcldlcSpec 71 | - CSpec 72 | - FunctionApplicationSpec 73 | - FunctionSignaturesSpec 74 | - InterpreterSpec 75 | - LdlcSpec 76 | - TypecheckerSpec 77 | - Utils 78 | - UtilsFuncCcldlc 79 | ghc-options: 80 | - -threaded 81 | - -rtsopts 82 | - -with-rtsopts=-N 83 | build-tools: hspec-discover 84 | dependencies: 85 | - ldgv 86 | - QuickCheck 87 | - array 88 | - containers 89 | - hspec 90 | - typed-process 91 | - unliftio 92 | 93 | executables: 94 | ldgv: 95 | main: Main.hs 96 | other-modules: Output 97 | source-dirs: exe 98 | dependencies: 99 | - ldgv 100 | - optparse-applicative 101 | - prettyprinter 102 | - prettyprinter-ansi-terminal 103 | - terminal-size 104 | - unliftio 105 | ghc-options: 106 | - -threaded 107 | - -rtsopts 108 | - -with-rtsopts=-N 109 | -------------------------------------------------------------------------------- /src/C/CPS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# OPTIONS_GHC -Wall #-} 7 | module C.CPS 8 | ( toCPS 9 | 10 | -- * CPS Types 11 | , Val(..) 12 | , Exp(..) 13 | , Continuation 14 | 15 | -- * Re-exports from "Syntax" 16 | , Ident 17 | , TIdent 18 | , Literal(..) 19 | , MathOp(..) 20 | , Type(..) 21 | , Freevars(..) 22 | ) where 23 | 24 | import Control.Monad.Cont 25 | import Control.Monad.Reader 26 | import Data.Foldable 27 | import Data.Functor 28 | import Data.Set (Set) 29 | import Kinds (Multiplicity) 30 | import Syntax hiding (Exp(..)) 31 | import qualified Data.Set as Set 32 | import qualified Syntax as S 33 | 34 | data Val 35 | = Lit Literal 36 | | Var Ident 37 | | Lam Multiplicity Ident Type {-ContIdent-} Exp 38 | | Rec Ident Ident Type Type Exp 39 | | Math (MathOp Val) 40 | | Succ Val 41 | | Pair Val Val 42 | | New Type 43 | | Send Val 44 | | Fork Exp 45 | deriving (Show, Eq) 46 | 47 | data Exp 48 | = Return {-ContIdent-} Val 49 | | Let Ident Val Exp 50 | | LetPair Ident Ident Val Exp 51 | | LetCont {-ContIdent-} Continuation Exp 52 | | Call Val Val (Maybe Continuation) 53 | -- ^ Represents a tail call if no continuation is given. 54 | | TLCall Ident (Maybe Continuation) 55 | -- ^ A call to a top level function. 56 | | Case Val [(String, Exp)] 57 | | NatRec Val Val Ident TIdent Ident Type Exp 58 | | Recv Val (Maybe Continuation) 59 | -- ^ Represents a "tail recv" if no continuation is given 60 | deriving (Show, Eq) 61 | 62 | type Continuation = (Ident, Exp) 63 | 64 | instance Freevars Val where 65 | fv = \case 66 | Lit _ -> Set.empty 67 | Var v -> Set.singleton v 68 | Lam _ x t e -> fv t <> Set.delete x (fv e) 69 | Rec f x t1 t2 e -> fv t1 <> fv t2 <> Set.delete f (Set.delete x (fv e)) 70 | Math m -> fv m 71 | Succ e -> fv e 72 | Pair e1 e2 -> fv e1 <> fv e2 73 | New ty -> fv ty 74 | Send e -> fv e 75 | Fork e -> fv e 76 | 77 | instance Freevars Exp where 78 | fv = \case 79 | Return v -> fv v 80 | Let x v e -> fv v <> Set.delete x (fv e) 81 | LetPair x y v e -> fv v <> Set.delete x (Set.delete y (fv e)) 82 | LetCont k e -> contFV k <> fv e 83 | Call a b mk -> fv a <> fv b <> foldMap contFV mk 84 | TLCall x mk -> 85 | -- FIXME: Should x really be considered a free variable, or implicitly 86 | -- bound by the top level definitions? 87 | Set.insert x (foldMap contFV mk) 88 | Case v cs -> foldl' (<>) (fv v) $ map (fv . snd) cs 89 | NatRec v z x _t y tyy s -> mconcat 90 | [ fv v 91 | , fv z 92 | , Set.delete x (Set.delete y (fv s)) 93 | , fv tyy 94 | ] 95 | Recv v mk -> fv v <> foldMap contFV mk 96 | where 97 | contFV (x, k) = Set.delete x (fv k) 98 | 99 | -- | Keeps track of the used variables in an expression. @varsUsed@ should 100 | -- always be a superset of @varsBound@. The former includes all initially free 101 | -- variables while the latter is used to keep track of all bound variables. 102 | -- 103 | -- @varsUsed@ is the set of identifiers we shouldn't use when creating fresh 104 | -- variables, @varsBound@ is used to distinguish used variables between local 105 | -- value accesses and top level calls. 106 | data Vars = Vars 107 | { varsUsed :: !(Set Ident) 108 | , varsBound :: !(Set Ident) 109 | } 110 | deriving (Show) 111 | 112 | toCPS :: S.Exp -> Exp 113 | toCPS e = flip runReader vars $ fromExp' e 114 | where 115 | vars = Vars 116 | { varsUsed = fv e 117 | , varsBound = mempty 118 | } 119 | 120 | fromExp :: S.Exp -> (Val -> Reader Vars Exp) -> Reader Vars Exp 121 | fromExp e = runContT (fromExpC e) 122 | 123 | fromExpC :: S.Exp -> ContT Exp (Reader Vars) Val 124 | fromExpC = \case 125 | S.Lit l -> pure (Lit l) 126 | S.Var v -> do 127 | vBound <- isBound v 128 | if vBound 129 | then pure (Var v) 130 | else captured $ pure . TLCall v . Just 131 | S.Lam m x t e -> lift $ 132 | Lam m x t <$> bound x (fromExp' e) 133 | S.App e1 e2 -> do 134 | v1 <- fromExpC e1 135 | v2 <- fromExpC e2 136 | captured $ pure . Call v1 v2 . Just 137 | S.Let x e1 e2 -> do 138 | v1 <- fromExpC e1 139 | (x', e2') <- renaming x e2 140 | ContT $ fmap (Let x' v1) . bound x' . fromExp e2' 141 | S.Pair _ x e1 e2 -> do 142 | v1 <- fromExpC e1 143 | (x', e2') <- renaming x e2 144 | ContT \k -> Let x' v1 <$> bound x' do 145 | fromExp e2' $ k . Pair (Var x') 146 | S.LetPair x1 x2 e1 e2 -> do 147 | v1 <- fromExpC e1 148 | (x1', e2a) <- renaming x1 e2 149 | (x2', e2b) <- renaming x2 e2a 150 | ContT $ fmap (LetPair x1' x2' v1) . bound2 x1' x2' . fromExp e2b 151 | S.Fst e -> getPair fst e 152 | S.Snd e -> getPair snd e 153 | S.Case e cs -> captured \k -> 154 | LetCont k <$> fromExp e \v -> 155 | Case v <$> traverse (traverse fromExp') cs 156 | S.Math m -> Math <$> traverse fromExpC m 157 | S.Succ e -> Succ <$> fromExpC e 158 | S.NatRec e z n tyv x t s -> do 159 | c <- NatRec <$> fromExpC e <*> fromExpC z 160 | captured \k -> 161 | LetCont k . c n tyv x t <$> bound2 n x (fromExp' s) 162 | S.Fork e -> do 163 | vars <- ask 164 | pure $ Fork $ flip runReader vars $ fromExp e (pure . Return) 165 | S.New t -> pure $ New t 166 | S.Send e -> Send <$> fromExpC e 167 | S.Recv e -> do 168 | v <- fromExpC e 169 | captured $ pure . Recv v . Just 170 | 171 | getPair :: (forall a. (a, a) -> a) -> S.Exp -> ContT Exp (Reader Vars) Val 172 | getPair f e = do 173 | v <- fromExpC e 174 | ContT \k -> do 175 | xfst <- fresh "fst" 176 | xsnd <- fresh "snd" 177 | let x = Var $ f (xfst, xsnd) 178 | LetPair xfst xsnd v <$> bound2 xfst xsnd (k x) 179 | 180 | fromExp' :: S.Exp -> Reader Vars Exp 181 | fromExp' = \case 182 | S.Var v -> do 183 | vBound <- isBound v 184 | if vBound 185 | then trivial (S.Var v) 186 | else pure $ TLCall v Nothing 187 | S.App e1 e2 -> flip runContT pure do 188 | Call <$> fromExpC e1 <*> fromExpC e2 <*> pure Nothing 189 | S.Let x e1 e2 -> fromExp e1 \v -> 190 | Let x v <$> bound x (fromExp' e2) 191 | S.Case e cs -> fromExp e \v -> 192 | Case v <$> traverse (traverse fromExp') cs 193 | S.NatRec e z n tyv x t s -> flip runContT pure do 194 | c <- NatRec <$> fromExpC e <*> fromExpC z 195 | lift $ c n tyv x t <$> bound2 n x (fromExp' s) 196 | S.LetPair x1 x2 e1 e2 -> fromExp e1 \v -> 197 | LetPair x1 x2 v <$> bound2 x1 x2 (fromExp' e2) 198 | S.Recv e -> fromExp e \v -> 199 | pure $ Recv v Nothing 200 | 201 | e@S.Lit{} -> trivial e 202 | e@S.Succ{} -> trivial e 203 | e@S.Math{} -> trivial e 204 | e@S.Fst{} -> trivial e 205 | e@S.Snd{} -> trivial e 206 | e@S.Lam{} -> trivial e 207 | e@S.Pair{} -> trivial e 208 | e@S.Fork{} -> trivial e 209 | e@S.New{} -> trivial e 210 | e@S.Send{} -> trivial e 211 | where 212 | trivial e = fromExp e (pure . Return) 213 | 214 | captured :: (Continuation -> Reader Vars Exp) -> ContT Exp (Reader Vars) Val 215 | captured f = do 216 | a <- fresh "a" 217 | ContT \k -> f . (a,) =<< bound a (k (Var a)) 218 | 219 | bound :: MonadReader Vars m => Ident -> m a -> m a 220 | bound x = local \(Vars v w) -> Vars (Set.insert x v) (Set.insert x w) 221 | 222 | bound2 :: MonadReader Vars m => Ident -> Ident -> m a -> m a 223 | bound2 x y = bound x . bound y 224 | 225 | isBound :: MonadReader Vars m => Ident -> m Bool 226 | isBound ident = do 227 | vars <- ask 228 | pure $ ident `Set.member` varsBound vars 229 | 230 | fresh :: MonadReader Vars m => Ident -> m Ident 231 | fresh ident = asks $ freshvar ident . varsUsed 232 | 233 | renaming :: MonadReader Vars m => Ident -> S.Exp -> m (Ident, S.Exp) 234 | renaming x e = fresh x <&> \x' -> 235 | (x', if x == x' then e else subst x (S.Var x') e) 236 | -------------------------------------------------------------------------------- /src/C/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# OPTIONS_GHC -Wall #-} 8 | 9 | module C.Compile 10 | ( Env(..) 11 | , defaultEnv 12 | , compile 13 | , link 14 | , cflags 15 | , listBackends 16 | ) where 17 | 18 | import Control.Monad.IO.Class 19 | import Control.Monad.Reader 20 | import Data.Traversable 21 | import Paths_ldgv 22 | import System.FilePath 23 | import System.IO 24 | import System.Process.Typed 25 | import qualified Control.Monad.Fail as Fail 26 | 27 | data Env = Env 28 | { envCC :: !String 29 | , envFlags :: ![String] 30 | , envVerbose :: !Bool 31 | } 32 | deriving stock (Show) 33 | 34 | defaultEnv :: Env 35 | defaultEnv = Env 36 | { envCC = "cc" 37 | , envFlags = [] 38 | , envVerbose = False 39 | } 40 | 41 | compile :: (MonadReader Env m, MonadIO m) => FilePath -> FilePath -> m () 42 | compile result src = do 43 | cc <- asks envCC 44 | defaultFlags <- liftIO cflags 45 | customFlags <- asks envFlags 46 | let args = "-o" : result : "-c" : src : defaultFlags ++ customFlags 47 | run cc args 48 | 49 | link :: (MonadReader Env m, MonadIO m, Fail.MonadFail m) => FilePath -> [FilePath] -> String -> m () 50 | link result srcs backend = do 51 | cc <- asks envCC 52 | defaultFlagsCC <- liftIO cflags 53 | defaultFlagsLD <- liftIO ldflags 54 | customFlags <- asks envFlags 55 | backendSrcs <- 56 | if | pathSeparator `elem` backend -> 57 | pure [backend] 58 | | Just additional <- lookup backend knownBackends -> liftIO $ 59 | traverse backendFile $ backendImplFileName backend : additional 60 | | otherwise -> Fail.fail $ 61 | "unknown backend ›" ++ backend ++ "‹, use ›./" ++ backend ++ "‹ to refer to a file" 62 | 63 | let args = "-o" : result : concat 64 | [ srcs 65 | , defaultFlagsCC 66 | , defaultFlagsLD 67 | , backendSrcs 68 | , customFlags 69 | ] 70 | run cc args 71 | 72 | run :: (MonadReader Env m, MonadIO m) => String -> [String] -> m () 73 | run exe args = do 74 | verbose <- asks envVerbose 75 | when verbose $ liftIO do 76 | hPutStrLn stderr $ unwords $ fmap show $ exe:args 77 | runProcess_ $ proc exe args 78 | 79 | basePath :: FilePath 80 | basePath = "c-support/runtime" 81 | 82 | cflags :: IO [String] 83 | cflags = do 84 | dataDir <- getDataDir 85 | pure ["-pthread", "-Wall", "-O2", "-fomit-frame-pointer", "-std=c11", "-I" ++ dataDir basePath ] 86 | 87 | ldflags :: IO [String] 88 | ldflags = do 89 | supportImpl <- backendFile "LDST.c" 90 | pure [supportImpl] 91 | 92 | listBackends :: IO [(String, FilePath)] 93 | listBackends = do 94 | for knownBackends \(b, _) -> (b,) <$> backendFile (backendImplFileName b) 95 | 96 | knownBackends :: [(String, [FilePath])] 97 | knownBackends = 98 | [ ("serial", []) 99 | , ("concurrent", ["thpool.c"]) 100 | ] 101 | 102 | backendImplFileName :: String -> FilePath 103 | backendImplFileName b = "LDST_" ++ b <.> "c" 104 | 105 | backendFile :: String -> IO FilePath 106 | backendFile filename = getDataFileName $ basePath filename 107 | -------------------------------------------------------------------------------- /src/C/MonadStack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | -- | A monad transformer adding a stack, allowing for 'pushStack' and 11 | -- 'popStack' operations. 12 | -- 13 | -- For now this module provides only the instances used in other parts of the 14 | -- code. 15 | module C.MonadStack (StackT, evalStack, evalStackT, hoistStack, generalizeStack, MonadStack(..)) where 16 | 17 | import Control.Monad.Error.Class 18 | import Control.Monad.State.Strict 19 | import Control.Monad.Writer.Class 20 | import Control.Monad.RWS.Strict 21 | import Control.Monad.Writer.Strict 22 | import Data.Functor.Identity 23 | 24 | newtype StackT s m a = StackT { unStackT :: StateT [s] m a } 25 | deriving newtype (Functor, Applicative, Monad, MonadError e, MonadWriter w, MonadTrans) 26 | 27 | evalStackT :: Monad m => [s] -> StackT s m a -> m a 28 | evalStackT ss = flip evalStateT ss . unStackT 29 | 30 | evalStack :: [s] -> StackT s Identity a -> a 31 | evalStack ss = runIdentity . evalStackT ss 32 | 33 | class Monad m => MonadStack s m | m -> s where 34 | pushStack :: s -> m () 35 | popStack :: m (Maybe s) 36 | 37 | instance Monad m => MonadStack s (StackT s m) where 38 | pushStack s = StackT $ modify (s :) 39 | popStack = StackT do 40 | ss <- get 41 | case ss of 42 | [] -> pure Nothing 43 | s:ss' -> Just s <$ put ss' 44 | 45 | instance (MonadStack s m, Monoid w) => MonadStack s (RWST r w s' m) where 46 | pushStack = lift . pushStack 47 | popStack = lift popStack 48 | 49 | instance (MonadStack s m, Monoid w) => MonadStack s (WriterT w m) where 50 | pushStack = lift . pushStack 51 | popStack = lift popStack 52 | 53 | hoistStack :: (forall x. m x -> n x) -> StackT s m a -> StackT s n a 54 | hoistStack f = StackT . mapStateT f . unStackT 55 | 56 | generalizeStack :: Applicative m => StackT s Identity a -> StackT s m a 57 | generalizeStack = hoistStack (pure . runIdentity) 58 | -------------------------------------------------------------------------------- /src/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Config where 3 | 4 | import qualified Debug.Trace as D 5 | import PrettySyntax (Pretty, pshow) 6 | import Control.Monad.IO.Class 7 | 8 | selected :: String -> Bool 9 | selected ident = ident `elem` ["valueEquiv", "subtype"] 10 | 11 | data DebugLevel = DebugNone | DebugAll 12 | deriving (Eq, Ord, Show) 13 | 14 | debugLevel :: DebugLevel 15 | --debugLevel = DebugAll 16 | debugLevel = DebugNone 17 | 18 | trace :: String -> a -> a 19 | trace s a | debugLevel > DebugNone = D.trace s a 20 | | otherwise = a 21 | 22 | traceOnly :: String -> String -> a -> a 23 | traceOnly ident s a 24 | | selected ident = D.trace (ident ++ ": " ++ s) a 25 | | otherwise = a 26 | 27 | traceOnlyM :: Applicative f => String -> String -> f () 28 | traceOnlyM ident s 29 | | selected ident = D.traceM (ident ++ ": " ++ s) 30 | | otherwise = pure () 31 | 32 | traceM :: Applicative f => String -> f () 33 | traceM s | debugLevel > DebugNone = D.traceM s 34 | | otherwise = pure () 35 | 36 | traceShowM :: (Show a, Applicative f) => a -> f () 37 | traceShowM = traceM . show 38 | 39 | traceIO :: MonadIO m => String -> m () 40 | traceIO s | debugLevel > DebugNone = liftIO $ D.traceIO s 41 | | otherwise = pure () 42 | 43 | traceSuccess :: (Pretty a, Applicative f) => a -> f () 44 | traceSuccess a 45 | | debugLevel > DebugNone = traceM $ "Success: " ++ pshow a 46 | | otherwise = traceM "Success" 47 | -------------------------------------------------------------------------------- /src/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Examples where 3 | 4 | import Data.Map (Map, fromList) 5 | import Data.Text (unpack) 6 | import Data.Text.Encoding (decodeUtf8) 7 | import Data.List (isSuffixOf) 8 | import Data.FileEmbed 9 | import Data.ByteString (ByteString) 10 | 11 | _examples :: [(String, ByteString)] 12 | _examples = filter (\(name, _) -> ".ldgv" `isSuffixOf` name) $(embedDir "examples") 13 | 14 | examples :: Map String String 15 | examples = fromList $ map (\(name, content) -> (name, unpack $ decodeUtf8 content)) _examples 16 | 17 | filenames :: [String] 18 | filenames = map fst _examples 19 | -------------------------------------------------------------------------------- /src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Interpreter 5 | ( interpret 6 | , interpretDecl 7 | , evalType 8 | , InterpreterException(..) 9 | ) where 10 | 11 | import qualified Config as C 12 | import Syntax 13 | import PrettySyntax 14 | import qualified Control.Concurrent.Chan as Chan 15 | import Control.Concurrent (forkIO) 16 | import Data.Foldable (find) 17 | import Data.Maybe (fromJust) 18 | import ProcessEnvironment 19 | import qualified Control.Monad as M 20 | import Control.Monad.Reader as R 21 | import Control.Applicative ((<|>)) 22 | import Control.Exception 23 | import Kinds (Multiplicity(..)) 24 | 25 | data InterpreterException 26 | = MathException String 27 | | LookupException String 28 | | CastException Exp 29 | | ApplicationException Exp 30 | | RecursorException String 31 | | RecursorNotNatException 32 | | NotImplementedException Exp 33 | | TypeNotImplementedException Type 34 | deriving Eq 35 | 36 | instance Show InterpreterException where 37 | show = \case 38 | (MathException s) -> "MathException: " ++ s 39 | (LookupException s) -> "LookupException: Lookup of '" ++ s ++ "' did not yield a value" 40 | (CastException exp) -> "CastException: (" ++ pshow exp ++ ") failed" 41 | (ApplicationException exp) -> "ApplicationException: expression '" ++ pshow exp ++ "' not allowed" 42 | (RecursorException s) -> "RecursorException: " ++ s 43 | RecursorNotNatException -> "Recursor only works on natural numbers" 44 | (NotImplementedException exp) -> "NotImplementedException: " ++ pshow exp 45 | (TypeNotImplementedException typ) -> "TypeNotImplementedException: " ++ pshow typ 46 | 47 | instance Exception InterpreterException 48 | 49 | blame :: Exp -> a 50 | blame exp = throw $ CastException exp 51 | 52 | -- | interpret the "main" value in an ldgv file given over stdin 53 | interpret :: [Decl] -> IO Value 54 | interpret decls = R.runReaderT (interpretDecl decls) [] 55 | 56 | interpretDecl :: [Decl] -> InterpretM Value 57 | interpretDecl (DFun "main" _ e _:_) = interpret' e 58 | interpretDecl (DFun name [] e _:decls) = interpret' e >>= \v -> local (extendEnv name v) (interpretDecl decls) 59 | interpretDecl (DFun name binds e _:decls) = 60 | let lambda = foldr (\(mul, id, ty) -> Lam mul id ty) e binds 61 | in interpret' lambda >>= \v -> local (extendEnv name v) (interpretDecl decls) 62 | interpretDecl (DType name _ _ t:decls) = local (extendEnv name $ VType t) (interpretDecl decls) 63 | interpretDecl (_:decls) = interpretDecl decls 64 | interpretDecl [] = throw $ LookupException "main" 65 | 66 | -- | interpret a single Expression 67 | interpret' :: Exp -> InterpretM Value 68 | interpret' e = ask >>= \penv -> 69 | M.ap 70 | (return $ \val -> C.trace ("Leaving interpretation of " ++ pshow e ++ " with value " ++ show val) val) $ 71 | (C.trace ("Invoking interpretation on " ++ pshow e) . eval) e 72 | 73 | eval :: Exp -> InterpretM Value 74 | eval = \case 75 | Succ e -> interpretMath $ Add (Lit (LInt 1)) e 76 | Rec f x e1 e0 -> ask >>= \env -> return $ VRec env f x e1 e0 77 | NatRec e1 e2 i1 t1 i2 t e3 -> do 78 | -- returns a function indexed over e1 (should be a variable pointing to a Nat) 79 | -- e1 should be the recursive variable which gets decreased each time the 80 | -- non-zero case is evaluated 81 | -- e2 is the zero case 82 | -- e3 is the nonzero case 83 | i <- interpret' e1 84 | case i of 85 | VInt 0 -> interpret' e2 86 | VInt 1 -> do 87 | zero <- interpret' e2 88 | R.local (extendEnv i1 (VInt 0) . extendEnv i2 zero) (interpret' e3) 89 | VInt n -> do 90 | -- interpret the n-1 case i2 and add it to the env 91 | -- together with n before interpreting the body e3 92 | let lowerEnv = extendEnv i1 (VInt $ n-1) 93 | lower <- R.local lowerEnv (interpret' $ NatRec (Var i1) e2 i1 t1 i2 t e3) 94 | R.local (extendEnv i2 lower . lowerEnv) (interpret' e3) 95 | _ -> throw $ RecursorException "Evaluation of 'natrec x...' must yield Nat value" 96 | NewNatRec f n tid ty ez x es -> ask >>= \env -> return $ VNewNatRec env f n tid ty ez x es 97 | Lam _ i _ e -> ask >>= \env -> return $ VFunc env i e 98 | cast@(Cast e t1 t2) -> do 99 | C.traceIO $ "Interpreting cast expression: " ++ pshow cast 100 | v <- interpret' e 101 | C.traceIO ("Evaluating expression " ++ pshow e ++ " to value " ++ show v) 102 | nft1 <- evalType t1 103 | C.traceIO $ "Evaluating type " ++ show t1 ++ " to normal form " ++ show nft1 104 | nft2 <- evalType t2 105 | C.traceIO $ "Evaluating type " ++ show t2 ++ " to normal form " ++ show nft2 106 | case v of 107 | VPair {} -> do 108 | C.traceIO $ "Interpreting pair cast expression: Value(" ++ show v ++ ") NFType(" ++ show nft1 ++ ") NFType(" ++ show nft2 ++ ")" 109 | v' <- lift $ reducePairCast v (toNFPair nft1) (toNFPair nft2) 110 | maybe (blame cast) return v' 111 | _ -> let v' = reduceCast v nft1 nft2 in maybe (blame cast) return v' 112 | Var s -> ask >>= \env -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) 113 | Let s e1 e2 -> interpret' e1 >>= \v -> R.local (extendEnv s v) (interpret' e2) 114 | Math m -> interpretMath m 115 | Lit l -> return (interpretLit l) 116 | e@(App e1 e2) -> do 117 | liftIO $ C.traceIO $ "Arguments for (" ++ pshow e1 ++ ") are (" ++ pshow e2 ++ ")" 118 | val <- interpret' e1 119 | arg <- interpret' e2 120 | interpretApp e val arg 121 | Pair mul s e1 e2 -> do 122 | v1 <- interpret' e1 123 | v2 <- R.local (extendEnv s v1) (interpret' e2) 124 | return $ VPair v1 v2 125 | LetPair s1 s2 e1 e2 -> interpret' e1 >>= \(VPair v1 v2) -> R.local (extendEnv s2 v2 . extendEnv s1 v1) (interpret' e2) 126 | fst@(Fst e) -> interpret' e >>= \(VPair s1 s2) -> return s1 127 | snd@(Snd e) -> interpret' e >>= \(VPair s1 s2) -> return s2 128 | Fork e -> do 129 | penv <- ask 130 | liftIO $ forkIO (do 131 | res <- R.runReaderT (interpret' e) penv 132 | C.traceIO "Ran a forked operation") 133 | return VUnit 134 | New t -> do 135 | r <- liftIO Chan.newChan 136 | w <- liftIO Chan.newChan 137 | return $ VPair (VChan r w) (VChan w r) 138 | Send e -> VSend <$> interpret' e 139 | Recv e -> do 140 | interpret' e >>= \v@(VChan c _) -> do 141 | val <- liftIO $ Chan.readChan c 142 | liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan " 143 | return $ VPair val v 144 | Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases 145 | e -> throw $ NotImplementedException e 146 | 147 | -- Exp is only used for blame 148 | interpretApp :: Exp -> Value -> Value -> InterpretM Value 149 | interpretApp _ (VFunc env s exp) w = R.local (const $ extendEnv s w env) (interpret' exp) 150 | interpretApp e (VFuncCast v (FuncType penv s t1 t2) (FuncType penv' s' t1' t2')) w' = do 151 | env0 <- ask 152 | let 153 | interpretAppCast :: IO Value 154 | interpretAppCast = do 155 | C.traceIO ("Attempting function cast in application (" ++ show v ++ ") with (" ++ show w' ++ ")") 156 | nft1 <- R.runReaderT (evalType t1) penv 157 | nft1' <- R.runReaderT (evalType t1') penv' 158 | w <- maybe (blame e) return (reduceCast w' nft1' nft1) 159 | nft2' <- R.runReaderT (evalType t2') (extendEnv s' w' penv') 160 | nft2 <- R.runReaderT (evalType t2) (extendEnv s w penv) 161 | u <- R.runReaderT (interpretApp e v w) env0 162 | u' <- maybe (blame e) return (reduceCast u nft2 nft2') 163 | C.traceIO ("Function cast in application results in: " ++ show u') 164 | return u' 165 | lift interpretAppCast 166 | interpretApp e rec@(VRec env f n1 e1 e0) (VInt n) 167 | | n < 0 = throw RecursorNotNatException 168 | | n == 0 = interpret' e0 169 | | n > 0 = do 170 | let env' = extendEnv n1 (VInt (n-1)) (extendEnv f rec env) 171 | R.local (const env') (interpret' e1) 172 | interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) 173 | | n < 0 = throw RecursorNotNatException 174 | | n == 0 = interpret' ez 175 | | n > 0 = do 176 | let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) 177 | R.local (const env') (interpret' es) 178 | interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c w) >> return v 179 | interpretApp e _ _ = throw $ ApplicationException e 180 | 181 | interpretLit :: Literal -> Value 182 | interpretLit = \case 183 | LInt i -> VInt i 184 | LNat n -> VInt n 185 | LLab l -> VLabel l 186 | LDouble d -> VDouble d 187 | LString s -> VString s 188 | LUnit -> VUnit 189 | 190 | interpretMathOp :: Exp -> Exp -> (Int -> Int -> Int) -> (Double -> Double -> Double) -> InterpretM Value 191 | interpretMathOp a b opInt opDouble = do 192 | v <- interpret' a 193 | w <- interpret' b 194 | return $ case (v, w) of 195 | (VInt x, VInt y) -> VInt (opInt x y) 196 | (VDouble x, VDouble y) -> VDouble (opDouble x y) 197 | (_, _) -> throw $ MathException (show v ++ " -> " ++ show w ++ " -> a: did not yield a value") 198 | 199 | interpretMath :: MathOp Exp -> InterpretM Value 200 | interpretMath = \case 201 | Add a b -> interpretMathOp a b (+) (+) 202 | Sub a b -> interpretMathOp a b (-) (-) 203 | Mul a b -> interpretMathOp a b (*) (*) 204 | Div a b -> interpretMathOp a b quot (/) 205 | Neg a -> interpret' a >>= (\v -> return $ case v of 206 | VInt x -> VInt (negate x) 207 | VDouble x -> VDouble (negate x) 208 | _ -> throw $ MathException ("negate " ++ show v ++ ": did not yield a value")) 209 | 210 | evalType :: Type -> InterpretM NFType 211 | evalType = \case 212 | TUnit -> return $ NFGType GUnit 213 | TInt -> return $ NFGType GInt 214 | TDouble -> return $ NFGType GDouble 215 | TString -> return $ NFGType GString 216 | TBot -> return NFBot 217 | TDyn -> return NFDyn 218 | TNat -> return $ NFGType GNat 219 | TNatLeq n -> return $ NFGType $ GNatLeq n 220 | TNatRec e t1 tid t2 -> do 221 | v <- interpret' e 222 | case v of 223 | VInt 0 -> evalType t1 224 | VInt n -> if n < 0 225 | then throw RecursorNotNatException 226 | else 227 | let lower = TNatRec (Lit $ LNat (n-1)) t1 tid t2 228 | in R.local (extendEnv tid (VType lower)) (evalType t2) 229 | _ -> throw $ RecursorException "Evaluation of 'natrec x...' must yield Nat value" 230 | TName _ s -> ask >>= \env -> maybe (throw $ LookupException s) (\(VType t) -> evalType t) (lookup s env) 231 | TLab ls -> return $ NFGType $ GLabel $ labelsFromList ls 232 | TFun m _ TDyn TDyn -> return $ NFGType $ GFunc m 233 | TFun m s t1 t2 -> ask >>= \env -> return $ NFFunc $ FuncType env s t1 t2 234 | TPair _ TDyn TDyn -> return $ NFGType $ GPair 235 | TPair s t1 t2 -> ask >>= \env -> return $ NFPair $ FuncType env s t1 t2 236 | TCase exp labels -> interpret' exp >>= \(VLabel l) -> 237 | let entry = find (\(l', _) -> l == l') labels 238 | in maybe (return NFBot) (evalType . snd) entry 239 | t -> throw $ TypeNotImplementedException t 240 | 241 | reduceCast :: Value -> NFType -> NFType -> Maybe Value 242 | reduceCast v t1 t2 = castIsValue v t1 t2 <|> reduceCast' v t1 t2 243 | 244 | -- Cast-Is-Value: return correct value if arguments already form a value 245 | castIsValue :: Value -> NFType -> NFType -> Maybe Value 246 | castIsValue v (NFGType gt) NFDyn = Just $ VDynCast v gt 247 | castIsValue v (NFFunc ft1) (NFFunc ft2) = Just $ VFuncCast v ft1 ft2 248 | castIsValue v (NFFunc ft1) (NFGType (GFunc _)) = Just $ VFuncCast v ft1 (FuncType [] "x" TDyn TDyn) 249 | castIsValue v (NFGType (GFunc _)) (NFFunc ft2) = Just $ VFuncCast v (FuncType [] "x" TDyn TDyn) ft2 250 | castIsValue v (NFGType (GFunc x)) (NFGType (GFunc y)) = Just $ VFuncCast v (FuncType [] "x" TDyn TDyn) (FuncType [] "y" TDyn TDyn) 251 | castIsValue _ _ _ = Nothing 252 | 253 | reduceCast' :: Value -> NFType -> NFType -> Maybe Value 254 | reduceCast' v t NFDyn = 255 | if t `isSubtypeOf` NFDyn 256 | then Just v --Cast-Dyn-Dyn 257 | else do 258 | gt <- matchType t 259 | v' <- reduceCast v t (NFGType gt) 260 | Just (VDynCast v' gt) -- Factor-Left 261 | reduceCast' _ _ NFBot = Nothing -- Cast-Bot 262 | reduceCast' (VDynCast v gt1) NFDyn (NFGType gt2) = if gt1 `isSubtypeOf` gt2 then Just v else Nothing -- Cast-Collapse/Cast-Collide 263 | reduceCast' v NFDyn t = do 264 | gt <- matchType t 265 | let nfgt = NFGType gt 266 | let typeq = t `equalsType` gt 267 | if not typeq then do 268 | v' <- reduceCast v NFDyn nfgt 269 | v'' <- reduceCast v' nfgt t 270 | Just v'' -- Factor-Right 271 | else 272 | Nothing 273 | reduceCast' v (NFGType gt1) (NFGType gt2) = if gt1 `isSubtypeOf` gt2 then Just v else Nothing 274 | reduceCast' _ _ _ = Nothing 275 | 276 | --- PT: this is weird 277 | toNFPair :: NFType -> NFType 278 | toNFPair (NFGType (GPair)) = NFPair (FuncType [] "x" TDyn TDyn) 279 | toNFPair t = t 280 | 281 | reducePairCast :: Value -> NFType -> NFType -> IO (Maybe Value) 282 | reducePairCast (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do 283 | mv' <- reduceComponent v (penv, t1) (penv', t1') 284 | case mv' of 285 | Nothing -> return Nothing 286 | Just v' -> do 287 | mw' <- reduceComponent w ((s, v) : penv, t2) ((s', v') : penv', t2') 288 | return $ liftM2 VPair mv' mw' 289 | where 290 | reduceComponent :: Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) 291 | reduceComponent v (penv, t) (penv', t') = do 292 | nft <- R.runReaderT (evalType t) penv 293 | nft' <- R.runReaderT (evalType t') penv' 294 | return $ reduceCast v nft nft' 295 | reducePairCast _ _ _ = return Nothing 296 | 297 | equalsType :: NFType -> GType -> Bool 298 | equalsType (NFFunc (FuncType _ _ TDyn TDyn)) (GFunc _) = True 299 | equalsType (NFPair (FuncType _ _ TDyn TDyn)) (GPair) = True 300 | equalsType (NFGType gt1) gt2 = gt1 == gt2 301 | equalsType _ _ = False 302 | 303 | matchType :: NFType -> Maybe GType 304 | matchType = \case 305 | NFFunc (FuncType _ _ _ _) -> Just $ GFunc MMany 306 | NFPair (FuncType _ _ _ _) -> Just $ GPair 307 | NFGType gt -> Just gt 308 | _ -> Nothing 309 | -------------------------------------------------------------------------------- /src/Kinds.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-incomplete-patterns #-} 2 | 3 | module Kinds where 4 | 5 | data Multiplicity = MMany | MOne 6 | deriving (Show, Eq, Ord) 7 | 8 | data Occurrence = Many | One | Zero 9 | deriving (Show,Eq) 10 | 11 | inject :: Multiplicity -> Occurrence 12 | inject MMany = Many 13 | inject MOne = One 14 | 15 | class Demote a where 16 | demote :: a -> Occurrence 17 | 18 | instance Demote Multiplicity where 19 | demote MMany = Many 20 | demote MOne = Zero 21 | 22 | instance Demote Occurrence where 23 | demote Many = Many 24 | demote One = Zero 25 | demote Zero = Zero 26 | 27 | 28 | data Kind = Kun | Klin | Kunit | Kssn | Kidx 29 | deriving (Show, Read, Eq) 30 | 31 | klub :: Kind -> Kind -> Kind 32 | klub Klin k = Klin 33 | klub k Klin = Klin 34 | klub Kunit Kidx = Kun 35 | klub Kidx Kunit = Kun 36 | klub k Kunit = k 37 | klub Kunit k = k 38 | klub Kun Kun = Kun 39 | klub Kun Kssn = Klin 40 | klub Kssn Kun = Klin 41 | klub Kun Kidx = Kun 42 | klub Kidx Kun = Kun 43 | klub Kssn Kssn = Kssn 44 | 45 | -- natural multiplicity 46 | mult :: Kind -> Multiplicity 47 | mult Kun = MMany 48 | mult Klin = MOne 49 | mult Kunit = MMany 50 | mult Kssn = MOne 51 | mult Kidx = MMany 52 | 53 | use :: Occurrence -> Maybe Occurrence 54 | use Zero = Nothing 55 | use One = Just Zero 56 | use Many = Just Many 57 | 58 | olub :: Occurrence -> Occurrence -> Occurrence 59 | olub One _ = One 60 | olub _ One = One 61 | olub Many Many = Many 62 | 63 | kindof :: Multiplicity -> Kind 64 | kindof MOne = Klin 65 | kindof MMany = Kun 66 | 67 | kolub :: (Kind, Multiplicity) -> (Kind, Multiplicity) -> (Kind, Multiplicity) 68 | kolub (k1,o1) (k2,o2) = (klub k1 k2, max o1 o2) 69 | -------------------------------------------------------------------------------- /src/Parsing.hs: -------------------------------------------------------------------------------- 1 | module Parsing where 2 | 3 | import Parsing.Grammar as G 4 | import Parsing.Tokens 5 | import Syntax 6 | 7 | parseDecls :: String -> Either String [Decl] 8 | parseDecls = flip runAlex G.parseDecls 9 | 10 | parseType :: String -> Either String Type 11 | parseType = flip runAlex G.parseType 12 | -------------------------------------------------------------------------------- /src/Parsing/Grammar.y: -------------------------------------------------------------------------------- 1 | { 2 | module Parsing.Grammar (parseDecls, parseType) where 3 | 4 | import Control.Monad 5 | import qualified Data.List as List 6 | 7 | import Kinds 8 | import Syntax 9 | import Parsing.Tokens (T(..)) 10 | import qualified Parsing.Tokens as T 11 | } 12 | 13 | %monad { T.Alex } 14 | %lexer { (\f -> T.alexMonadScan >>= f) } { T _ T.EOF } 15 | %error { parseError } 16 | %tokentype { T } 17 | 18 | %name parseDecls Cmds 19 | %name parseType Typ 20 | 21 | %token 22 | let { T _ T.Let } 23 | rec { T _ T.Rec } 24 | in { T _ T.In } 25 | int { T _ (T.Int $$) } 26 | double { T _ (T.Double $$) } 27 | string { T _ (T.Str $$) } 28 | var { T _ (T.Var $$) } 29 | case { T _ T.Case } 30 | fst { T _ T.Fst } 31 | snd { T _ T.Snd } 32 | of { T _ T.Of } 33 | val { T _ T.Val } 34 | type { T _ T.Type } 35 | fork { T _ T.Fork } 36 | new { T _ T.New } 37 | send { T _ T.Send } 38 | recv { T _ T.Recv } 39 | 40 | -- for Binary Session Types; obsolete for Label Dependent ones 41 | select { T _ T.Select } 42 | rcase { T _ T.Rcase } 43 | close { T _ T.Close } 44 | wait { T _ T.Wait } 45 | 46 | expect { T _ T.Expect } 47 | lab { T _ (T.Lab $$) } 48 | kind { T _ (T.Kind $$) } 49 | tid { T _ (T.TID $$) } 50 | Unit { T _ T.TUnit } 51 | Bot { T _ T.TBot } 52 | Int { T _ T.TInt } 53 | Nat { T _ T.TNat } 54 | String { T _ T.TString } 55 | Double { T _ T.TDouble } 56 | natrec { T _ T.NatRec } 57 | new_natrec { T _ T.NewNatRec } 58 | '()' { T _ T.Unit } 59 | '->' { T _ T.Arrow } 60 | '=>' { T _ T.DoubleArrow } 61 | '{{' { T _ T.OpenEqn } 62 | '}}' { T _ T.CloseEqn } 63 | assume { T _ T.Assume } 64 | '<:' { T _ T.Subtype } 65 | '=:' { T _ T.Equiv } 66 | ':' { T _ T.Colon } 67 | ',' { T _ T.Comma } 68 | '.' { T _ T.Dot } 69 | lam { T _ T.Lambda } 70 | dualof { T _ T.DualOf } 71 | '{' { T _ (T.Sym '{') } 72 | '}' { T _ (T.Sym '}') } 73 | '=' { T _ (T.Sym '=') } 74 | '+' { T _ (T.Sym '+') } 75 | '-' { T _ (T.Sym '-') } 76 | '*' { T _ (T.Sym '*') } 77 | '/' { T _ (T.Sym '/') } 78 | '(' { T _ (T.Sym '(') } 79 | ')' { T _ (T.Sym ')') } 80 | '<' { T _ (T.Sym '<') } 81 | '>' { T _ (T.Sym '>') } 82 | '[' { T _ (T.Sym '[') } 83 | ']' { T _ (T.Sym ']') } 84 | '!' { T _ (T.Sym '!') } 85 | '?' { T _ (T.Sym '?') } 86 | '"' { T _ (T.Sym '"') } 87 | 88 | %right LET 89 | %nonassoc int double '(' var lab case natrec '()' lam rec fst snd new fork 90 | %right in 91 | %nonassoc '>' '<' 92 | %left '+' '-' NEG POS 93 | %left '*' '/' 94 | %left send recv 95 | %nonassoc APP 96 | 97 | 98 | %% 99 | 100 | Cmds : {[]} 101 | | Cmd Cmds { $1 : $2 } 102 | 103 | Cmd : type tid ':' Mul kind '=' Typ { DType $2 $4 $5 $7 } 104 | | val var ':' Mul Typ { DSig $2 (inject $4) $5 } 105 | | val var Bindings Check '=' Exp { DFun $2 $3 $6 $4 } 106 | | Typ '<:' Typ { DSub $1 $3 } 107 | | Typ '=:' Typ { DEqv $1 $3 } 108 | | '=' var Exp Exp { DSubst $2 $3 $4 } 109 | | assume TENV Cmd { DAssume $2 $3 } 110 | 111 | Check : {Nothing} 112 | | ':' Typ {Just $2} 113 | 114 | TENV : { [] } 115 | | '[' Assumptions ']' { $2 } 116 | 117 | Binding : Mul '(' var ':' Typ ')' { ($1, $3, $5) } 118 | Bindings : { [] } 119 | | Binding Bindings { $1 : $2 } 120 | 121 | Assumption : var ':' Mul Typ { ($1, (inject $3, $4)) } 122 | 123 | Assumptions : { [] } 124 | | Assumption ',' Assumptions { $1 : $3 } 125 | 126 | Mul : '!' { MOne } 127 | | { MMany } 128 | 129 | Of : of {()} | {()} 130 | 131 | AExp 132 | : int { Lit $ if $1 < 0 then LInt $1 else LNat $1 } 133 | | double { Lit $ LDouble $1 } 134 | | string { Lit $ LString (trimQuote $1) } 135 | | var { Var $1 } 136 | | lab { Lit $ LLab $1 } 137 | | '(' Exp ')' { $2 } 138 | 139 | Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } 140 | | Exp '+' Exp { Math $ Add $1 $3 } 141 | | Exp '-' Exp { Math $ Sub $1 $3 } 142 | | Exp '*' Exp { Math $ Mul $1 $3 } 143 | | Exp '/' Exp { Math $ Div $1 $3 } 144 | | '(' Exp ')' { $2 } 145 | | '+' Exp %prec POS { $2 } 146 | | '-' Exp %prec NEG { Math $ Neg $2 } 147 | | int { Lit $ if $1 < 0 then LInt $1 else LNat $1 } 148 | | double { Lit $ LDouble $1 } 149 | | string { Lit $ LString (trimQuote $1) } 150 | | Exp ':' Typ '=>' Typ { Cast $1 $3 $5 } 151 | | var { Var $1 } 152 | | lab { Lit $ LLab $1 } 153 | | case Exp Of '{' ExpCases '}' { Case $2 $5 } 154 | | natrec Exp '{' Exp ',' var '.' tid '.' '(' var ':' Typ ')' '.' Exp '}' 155 | { NatRec $2 $4 $6 $8 $11 $13 $16 } 156 | | new_natrec var ':' var '.' tid '.' Typ '{' Exp ',' var '.' Exp '}' 157 | { NewNatRec $2 $4 $6 $8 $10 $12 $14 } 158 | | '()' { Lit LUnit } 159 | | lam Mul '(' var ':' Typ ')' Exp { Lam $2 $4 $6 $8 } 160 | | rec var '(' var '.' Exp ')' Exp { Rec $2 $4 $6 $8 } 161 | | '<' Mul var '=' Exp ',' Exp '>' { Pair $2 $3 $5 $7 } 162 | | let '<' var ',' var '>' '=' Exp in Exp %prec LET { LetPair $3 $5 $8 $10 } 163 | | fst Exp { Fst $2 } 164 | | snd Exp { Snd $2 } 165 | | new Typ { New $2 } 166 | | fork Exp { Fork $2 } 167 | | send Exp %prec send { Send $2 } 168 | | recv Exp %prec recv { Recv $2 } 169 | | Exp Exp %prec APP { App $1 $2 } 170 | 171 | Labs : lab { [$1] } 172 | | lab ',' Labs { $1 : $3 } 173 | 174 | TypCase : lab ':' Typ { ($1, $3) } 175 | 176 | TypCases : TypCase { [$1] } 177 | | TypCase ',' TypCases { $1 : $3 } 178 | 179 | ExpCase : lab ':' Exp { ($1, $3) } 180 | 181 | ExpCases : ExpCase { [$1] } 182 | | ExpCase ',' ExpCases { $1 : $3 } 183 | 184 | ATyp : Unit { TUnit } 185 | | Int { TInt } 186 | | Nat { TNat } 187 | | Double { TDouble } 188 | | String { TString } 189 | | Bot { TBot } 190 | | '*' { TDyn } 191 | | tid { TName False $1 } 192 | | '{' Labs '}' { TLab $2 } 193 | | '[' Mul var ':' Typ ',' Typ ']' { TPair $3 $5 $7 } 194 | | '[' Mul Typ ',' Typ ']' { TPair "#*" $3 $5 } 195 | | '{{' Exp '=' Exp ':' Typ '}}' { TEqn $2 $4 $6 } 196 | | '(' Typ ')' { $2 } 197 | 198 | Typ : ATyp { $1 } 199 | | ATyp Mul '->' Typ { TFun $2 "#!" $1 $4 } 200 | | '(' var ':' Typ ')' Mul '->' Typ { TFun $6 $2 $4 $8 } 201 | | '!' '(' var ':' Typ ')' Typ { TSend $3 $5 $7 } 202 | | '?' '(' var ':' Typ ')' Typ { TRecv $3 $5 $7 } 203 | | '!' ATyp '.' Typ { TSend "#!" $2 $4 } 204 | | '?' ATyp '.' Typ { TRecv "#?" $2 $4 } 205 | | case Exp Of '{' TypCases '}' { TCase $2 $5 } 206 | | natrec Exp '{' Typ ',' tid '.' Typ '}' { TNatRec $2 $4 $6 $8 } 207 | | dualof ATyp { dualof $2 } 208 | 209 | { 210 | parseError (T (T.AlexPn _ line column) t) = do 211 | nextTokens <- filter (/= T.EOF) . (t:) <$> replicateM 9 (tokVal <$> T.alexMonadScan) 212 | let err | null nextTokens = "parse error: unexpected end of file" 213 | | otherwise = mconcat 214 | [ "parse error at line " 215 | , show line 216 | , ", column " 217 | , show column 218 | , ": unexpected token" 219 | , if null (tail nextTokens) then " " else "s " 220 | , List.intercalate ", " $ showToken <$> nextTokens 221 | ] 222 | T.alexError err 223 | 224 | showToken t = "›" ++ show t ++ "‹" 225 | 226 | trimQuote :: String -> String 227 | trimQuote (_:xs) = init xs 228 | } 229 | -------------------------------------------------------------------------------- /src/Parsing/Tokens.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE BlockArguments #-} 3 | module Parsing.Tokens 4 | ( -- * Tokens 5 | Token(..) 6 | , AlexPosn(..) 7 | , T(..) 8 | 9 | -- * Alex monad 10 | , Alex 11 | , runAlex 12 | , alexMonadScan 13 | , alexError 14 | ) where 15 | 16 | import Kinds 17 | import Text.Read (readMaybe) 18 | } 19 | 20 | %wrapper "monad" 21 | 22 | $digit = 0-9 -- digits 23 | $alpha = [a-zA-Z] -- alphabetic characters 24 | $lower = [a-z] 25 | $upper = [A-Z] 26 | 27 | tokens :- 28 | 29 | $white+ ; 30 | "--".* ; 31 | assume { tok $ const Assume } 32 | case { tok $ const Case } 33 | type { tok $ const Type } 34 | let { tok $ const Let } 35 | rec { tok $ const Rec } 36 | fst { tok $ const Fst } 37 | snd { tok $ const Snd } 38 | in { tok $ const In } 39 | of { tok $ const Of } 40 | val { tok $ const Val } 41 | fork { tok $ const Fork } 42 | new { tok $ const New } 43 | send { tok $ const Send } 44 | recv { tok $ const Recv } 45 | 46 | -- for Binary Session Types; obsolete for Label Dependent ones 47 | select { tok $ const Select } 48 | rcase { tok $ const Rcase } 49 | close { tok $ const Close } 50 | wait { tok $ const Wait } 51 | 52 | expect { tok $ const Expect } 53 | $digit+ "." $digit+ { tok $ Double . read } 54 | $digit+ { tok $ Int . read } 55 | Bot { tok $ const TBot } 56 | Unit { tok $ const TUnit } 57 | Int { tok $ const TInt } 58 | String { tok $ const TString } 59 | natrec { tok $ const NatRec } 60 | new_natrec { tok $ const NewNatRec } 61 | Nat { tok $ const TNat } 62 | Double { tok $ const TDouble } 63 | dualof { tok $ const DualOf } 64 | "_|_" { tok $ const TBot } 65 | "()" { tok $ const Unit } 66 | "->" { tok $ const Arrow } 67 | "=>" { tok $ const DoubleArrow } 68 | "{{" { tok $ const OpenEqn } 69 | "}}" { tok $ const CloseEqn } 70 | "<:" { tok $ const Subtype } 71 | "=:" { tok $ const Equiv } 72 | ":" { tok $ const Colon } 73 | "," { tok $ const Comma } 74 | "." { tok $ const Dot } 75 | fn | 𝜆 { tok $ const Lambda } 76 | [\=\+\-\*\/\(\)\:\!\?\{\}\[\]\<\>] { tok $ Sym . head } 77 | "'" [$alpha $digit]+ { tok $ Lab } 78 | "~" $alpha+ { tokKind } 79 | \"[^\"]*\" { tok $ Str } 80 | $lower [$alpha $digit \_ \']* { tok $ Var } 81 | $upper [$alpha $digit \_ \']* { tok $ TID } 82 | 83 | { 84 | -- The token type: 85 | data Token = 86 | Let | 87 | Rec | 88 | Fst | 89 | Snd | 90 | Case | 91 | Assume | 92 | In | 93 | Of | 94 | Val | 95 | Fork | 96 | New | 97 | Send | 98 | Recv | 99 | 100 | -- for Binary Session Types; obsolete for Label Dependent ones 101 | Select | 102 | Rcase | 103 | Close | 104 | Wait | 105 | 106 | Expect | 107 | Type | 108 | Sym Char | 109 | Kind Kind | 110 | Lab String | 111 | Var String | 112 | TID String | 113 | Str String | 114 | Unit | 115 | TBot | 116 | TUnit | 117 | TString | 118 | TInt | 119 | TNat | 120 | TDouble | 121 | NatRec | 122 | NewNatRec | 123 | Subtype | 124 | Equiv | 125 | OpenEqn | 126 | CloseEqn | 127 | Arrow | 128 | DoubleArrow | 129 | Colon | 130 | Comma | 131 | Dot | 132 | Lambda | 133 | DualOf | 134 | Int Int | 135 | Double Double | 136 | EOF 137 | deriving (Eq,Show) 138 | 139 | data T = T { tokPos :: AlexPosn, tokVal :: !Token } 140 | 141 | alexEOF :: Alex T 142 | alexEOF = do 143 | (pos, _, _, _) <- alexGetInput 144 | pure $ T pos EOF 145 | 146 | tok :: (String -> Token) -> AlexAction T 147 | tok f = tok' (Right . f) 148 | 149 | tok' :: (String -> Either String Token) -> AlexAction T 150 | tok' f (pos@(AlexPn _ line column), _, _, inp) len = do 151 | let inp' = take len inp 152 | case f inp' of 153 | Left err -> alexError $ mconcat 154 | [ "lexical error at line " 155 | , show line 156 | , ", column " 157 | , show column 158 | , if null err then "" else (": " ++ err) 159 | ] 160 | Right tok -> pure $ T pos tok 161 | 162 | tokKind :: AlexAction T 163 | tokKind = tok' \k -> 164 | maybe (Left $ "invalid kind " ++ k) (Right . Kind) 165 | $ readMaybe 166 | $ ('K':) -- Subsitutes the initial '~' with 'K' 167 | $ tail k 168 | } 169 | -------------------------------------------------------------------------------- /src/PrettySyntax.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | {-# OPTIONS_GHC -Wno-incomplete-patterns #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module PrettySyntax (Pretty(), pretty, pshow) where 6 | 7 | import Kinds 8 | import Syntax 9 | import ProcessEnvironment 10 | 11 | import Data.Text.Prettyprint.Doc 12 | import qualified Data.Set as Set 13 | 14 | pshow :: Pretty a => a -> String 15 | pshow x = show (pretty x) 16 | 17 | instance Pretty Constraint where 18 | pretty (t1 :<: t2) = pretty t1 <+> pretty "<:" <+> pretty t2 19 | 20 | instance Pretty Multiplicity where 21 | pretty MMany = mempty 22 | pretty MOne = pretty "!" 23 | 24 | instance Pretty Occurrence where 25 | pretty Many = pretty "_" 26 | pretty One = pretty '1' 27 | pretty Zero = pretty '0' 28 | 29 | instance Pretty Kind where 30 | pretty k = pretty (show k) 31 | 32 | instance Pretty TypeSegment where 33 | pretty (Seg SegSend x t) = pretty "!" <> ptyped x t 34 | pretty (Seg SegRecv x t) = pretty "?" <> ptyped x t 35 | pretty (Seg (SegFun m) x t) = pretty "Pi" <> pretty m <> ptyped x t 36 | pretty (Seg (SegPair) x t) = pretty "Sg" <> ptyped x t 37 | 38 | 39 | plab :: String -> Doc ann 40 | plab = pretty 41 | -- pretty "'" <> -- seem built into the lab string 42 | 43 | ptyped' :: Ident -> Type -> Doc ann 44 | ptyped' ('#':_) t1 = 45 | pretty t1 46 | ptyped' id t1 = 47 | parens (pretty id <+> colon <+> pretty t1) 48 | 49 | ptyped :: Ident -> Type -> Doc ann 50 | ptyped ('#':_) t1 = 51 | pretty t1 <> dot 52 | ptyped id t1 = 53 | parens (pretty id <+> colon <+> pretty t1) 54 | 55 | instance Pretty Type where 56 | pretty TUnit = pretty "()" 57 | pretty TInt = pretty "Int" 58 | pretty TNat = pretty "Nat" 59 | pretty TBot = pretty "_|_" 60 | pretty TDyn = pretty "★" 61 | pretty TDouble = pretty "Double" 62 | pretty TString = pretty "String" 63 | -- the bool indicates whether the type needs to be dualized 64 | pretty (TName b s) = (if b then pretty "~" else mempty) <> pretty s 65 | pretty (TVar b s) = (if b then pretty "~" else mempty) <> brackets (pretty s) 66 | pretty (TLab (str:strs)) = braces (plab str <> foldr f mempty strs) 67 | where 68 | f str rest = comma <+> plab str <> rest 69 | pretty (TFun m id t1 t2) = 70 | pretty m <> ptyped' id t1 <+> pretty "->" <+> pretty t2 71 | pretty (TPair id t1 t2) = 72 | brackets (pretty id <+> colon <+> pretty t1 <> comma <+> pretty t2) 73 | pretty (TSend id t1 t2) = 74 | pretty "!" <> ptyped id t1 <+> pretty t2 75 | pretty (TRecv id t1 t2) = 76 | pretty "?" <> ptyped id t1 <+> pretty t2 77 | pretty (TCase e (st : sts)) = 78 | pcase e (st : sts) 79 | pretty (TEqn e1 e2 t) = 80 | pretty "{{" <> pretty e1 <+> equals <> equals <+> pretty e2 <+> colon <+> pretty t <> pretty "}}" 81 | pretty (TSingle x) = 82 | pretty "S" <> parens (pretty x) 83 | pretty (TNatRec e tz y ts) = 84 | pretty "natrec" <+> pretty e <+> 85 | braces (pretty "Z:" <+> pretty tz <> comma <+> 86 | pretty "S_:" <+> pretty y <+> dot <+> pretty ts) 87 | -- print as a telescope 88 | pretty (TAbs id t1 t2) = 89 | ptyped id t1 <+> pretty t2 90 | 91 | pcase :: Pretty a => Exp -> [(String, a)] -> Doc ann 92 | pcase e (st : sts) = 93 | pretty "case" <+> pretty e <+> 94 | braces (g st <> foldr f mempty sts) 95 | where g (s, t) = plab s <> colon <> pretty t 96 | f st rest = comma <+> g st <> rest 97 | 98 | instance Pretty Exp where 99 | pretty (Let id e1 e2) = 100 | pretty "let" <+> pretty id <+> equals <+> pretty e1 <+> pretty "in" <+> 101 | pretty e2 102 | pretty (Var id) = 103 | pretty id 104 | pretty (Lit l) = 105 | pretty l 106 | pretty (Math m) = 107 | pretty m 108 | pretty (Lam m id t e) = 109 | pretty "𝜆" <> pretty m <+> ptyped id t <+> 110 | pretty e 111 | pretty (Rec f x e1 e0) = 112 | pretty "rec" <+> pretty f <+> pretty x <> 113 | colon <> pretty e1 <+> pretty e0 114 | pretty (App e1 e2) = 115 | pretty e1 <+> pretty e2 116 | pretty (Pair m id e1 e2) = 117 | angles (pretty m <> pretty id <+> equals <+> pretty e1 <> comma <+> pretty e2) 118 | pretty (LetPair x y e1 e2) = 119 | pretty "let" <+> angles (pretty x <> comma <> pretty y) <+> equals <+> pretty e1 <+> pretty "in" <+> pretty e2 120 | pretty (Fst e) = pretty "fst" <+> pretty e 121 | pretty (Snd e) = pretty "snd" <+> pretty e 122 | pretty (Fork e) = pretty "fork" <+> pretty e 123 | pretty (New t) = pretty "new" <+> pretty t 124 | pretty (Send e) = pretty "send" <+> pretty e 125 | pretty (Recv e) = pretty "recv" <+> pretty e 126 | pretty (Case e ses) = 127 | pcase e ses 128 | pretty (Cast e t1 t2) = 129 | pretty "(" <+> pretty e <+> pretty ":" <+> pretty t1 <+> pretty "⇒" <+> pretty t2 <+> pretty ")" 130 | pretty (Succ e) = 131 | pretty "succ" <+> pretty e 132 | pretty (NatRec e ez x t y tyy es) = 133 | pretty "natrec" <+> pretty e <+> 134 | braces (pretty ez <> comma <+> 135 | pretty x <> dot <+> 136 | pretty t <> dot <+> ptyped y tyy <+> pretty es) 137 | pretty (NewNatRec f n a ty ezero n1 esucc) = 138 | pretty "new_natrec" <+> 139 | parens (pretty f <> colon <> pretty n <> dot <> pretty a <> pretty ty) <+> 140 | braces (pretty ezero <> comma <+> 141 | pretty n1 <> dot <+> pretty esucc) 142 | 143 | instance Pretty Literal where 144 | pretty = \case 145 | LInt i -> pretty i 146 | LNat n -> pretty n 147 | LDouble d -> pretty d 148 | LString s -> pretty s 149 | LLab s -> plab s 150 | LUnit -> pretty "()" 151 | 152 | instance Pretty e => Pretty (MathOp e) where 153 | pretty = \case 154 | Add a b -> pretty a <+> pretty "+" <+> pretty b 155 | Sub a b -> pretty a <+> pretty "-" <+> pretty b 156 | Mul a b -> pretty a <+> pretty "*" <+> pretty b 157 | Div a b -> pretty a <+> pretty "/" <+> pretty b 158 | Neg a -> pretty "-" <> pretty a 159 | 160 | instance Pretty Value where 161 | pretty = \case 162 | VUnit -> pretty "()" 163 | VLabel s -> pretty s 164 | VInt i -> pretty $ show i 165 | VDouble d -> pretty $ show d 166 | VString s -> pretty $ show s 167 | VChan _ _ -> pretty "VChan" 168 | VSend v -> pretty "VSend" 169 | VPair a b -> pretty "<" <+> pretty a <+> pretty ", " <+> pretty b <+> pretty ">" 170 | VType t -> pretty t 171 | VFunc _ s exp -> pretty "λ" <+> pretty s <+> pretty " (" <+> pretty exp <+> pretty ")" 172 | VDynCast v t -> pretty "(" <+> pretty v <+> pretty " : " <+> pretty t <+> pretty " ⇒ ★)" 173 | VFuncCast v ft1 ft2 -> pretty "(" <+> pretty v <+> pretty " : " <+> pretty ft1 <+> pretty " ⇒ " <+> pretty ft2 <+> pretty ")" 174 | VRec {} -> pretty "VRec" 175 | VNewNatRec {} -> pretty "VNewNatRec" 176 | 177 | instance Pretty FuncType where 178 | pretty (FuncType _ s t1 t2) = pretty "Π(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 179 | 180 | instance Pretty GType where 181 | pretty = \case 182 | GUnit -> pretty "()" 183 | GLabel ls -> braces (plab str <> foldr f mempty strs) 184 | where 185 | ll = Set.toList ls 186 | str = head ll 187 | strs = tail ll 188 | f str rest = comma <+> plab str <> rest 189 | GFunc s -> pretty "Π(" <+> pretty s <+> pretty ":★)★" 190 | GPair -> pretty "Σ(" <+> pretty ":★)★" 191 | GNat -> pretty "Nat" 192 | GNatLeq n -> pretty "Nat(" <+> pretty n <+> pretty ")" 193 | GInt -> pretty "Int" 194 | GDouble -> pretty "Double" 195 | GString -> pretty "String" 196 | 197 | instance Pretty Decl where 198 | pretty = \case 199 | DType s _ k t -> pretty "type " <+> pretty s <+> pretty " : " <+> pretty k <+> pretty " = " <+> pretty t 200 | DSig s _ t -> pretty "val " <+> pretty s <+> pretty " : " <+> pretty t 201 | DFun s _ exp _ -> pretty "val " <+> pretty s <+> pretty " = " <+> pretty exp 202 | 203 | instance Pretty NFType where 204 | pretty = \case 205 | NFBot -> pretty "⊥" 206 | NFDyn -> pretty "★" 207 | NFFunc (FuncType _ s t1 t2) -> pretty "Π(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 208 | NFPair (FuncType _ s t1 t2) -> pretty "Σ(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 209 | NFGType gt -> pretty gt 210 | -------------------------------------------------------------------------------- /src/ProcessEnvironment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module ProcessEnvironment where 4 | import Syntax as S 5 | import Control.Concurrent.Chan as C 6 | import Control.Monad.Reader as T 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | import Kinds (Multiplicity(..)) 10 | 11 | -- | the interpretation monad 12 | type InterpretM a = T.ReaderT PEnv IO a 13 | 14 | extendEnv :: String -> Value -> PEnv -> PEnv 15 | extendEnv = curry (:) 16 | 17 | -- | a Process Envronment maps identifiers to Values of expressions and stores 18 | type PEnv = [PEnvEntry] 19 | type PEnvEntry = (String, Value) 20 | 21 | type Label = String 22 | type LabelType = Set Label 23 | 24 | labelsFromList :: [Label] -> LabelType 25 | labelsFromList = Set.fromList 26 | 27 | data FuncType = FuncType PEnv String S.Type S.Type 28 | deriving Eq 29 | 30 | instance Show FuncType where 31 | show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 32 | 33 | -- | (Unit, Label, Int, Values of self-declared Data Types), Channels 34 | data Value 35 | = VUnit 36 | | VLabel String 37 | | VInt Int 38 | | VDouble Double 39 | | VString String 40 | -- we have two channels, one for reading and one for writing to the other 41 | -- end, so we do not read our own written values 42 | | VChan (C.Chan Value) (C.Chan Value) 43 | | VSend Value 44 | | VPair Value Value -- pair of ids that map to two values 45 | | VType S.Type 46 | | VFunc PEnv String Exp 47 | | VDynCast Value GType -- (Value : G => *) 48 | | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) 49 | | VRec PEnv String String Exp Exp 50 | | VNewNatRec PEnv String String String Type Exp String Exp 51 | deriving Eq 52 | 53 | instance Show Value where 54 | show = \case 55 | VUnit -> "VUnit" 56 | VLabel s -> "VLabel " ++ s 57 | VInt i -> "VInt " ++ show i 58 | VDouble d -> "VDouble " ++ show d 59 | VString s -> "VString \"" ++ show s ++ "\"" 60 | VChan _ _ -> "VChan" 61 | VSend v -> "VSend (" ++ show v ++ ")" 62 | VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" 63 | VType t -> "VType " ++ show t 64 | VFunc _ s exp -> "VFunc " ++ show s ++ " " ++ show exp 65 | VDynCast v t -> "VDynCast (" ++ show v ++ ") (" ++ show t ++ ")" 66 | VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" 67 | VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 68 | VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es 69 | 70 | class Subtypeable t where 71 | isSubtypeOf :: t -> t -> Bool 72 | 73 | -- Types in Head Normal Form 74 | data NFType 75 | = NFBot 76 | | NFDyn 77 | | NFFunc FuncType -- (ρ, α, Π(x: A) B) 78 | | NFPair FuncType -- (ρ, α, Σ(x: A) B) 79 | | NFGType GType -- every ground type is also a type in normal form 80 | deriving (Show, Eq) 81 | 82 | instance Subtypeable NFType where 83 | -- NFFunc and NFPair default to false, which is not really correct. 84 | -- Implementation would be quite complicated and its not necessary, 85 | -- i.e. not used anywhere. 86 | isSubtypeOf NFBot _ = True 87 | isSubtypeOf NFDyn NFDyn = True 88 | isSubtypeOf (NFGType gt1) (NFGType gt2) = gt1 `isSubtypeOf` gt2 89 | isSubtypeOf _ _ = False 90 | 91 | data GType 92 | = GUnit 93 | | GLabel LabelType 94 | | GFunc Multiplicity -- Π(x: *) * 95 | | GPair -- Σ(x: *) * 96 | | GNat 97 | | GNatLeq Integer 98 | | GInt 99 | | GDouble 100 | | GString 101 | deriving (Show, Eq) 102 | 103 | instance Subtypeable GType where 104 | isSubtypeOf GUnit GUnit = True 105 | isSubtypeOf (GLabel ls1) (GLabel ls2) = ls1 `Set.isSubsetOf` ls2 106 | isSubtypeOf (GFunc _) (GFunc _) = True 107 | isSubtypeOf (GPair) (GPair) = True 108 | isSubtypeOf GNat GNat = True 109 | isSubtypeOf (GNatLeq _) GNat = True 110 | isSubtypeOf (GNatLeq n1) (GNatLeq n2) = n1 <= n2 111 | isSubtypeOf GInt GInt = True 112 | isSubtypeOf GDouble GDouble = True 113 | isSubtypeOf GString GString = True 114 | isSubtypeOf _ _ = False 115 | -------------------------------------------------------------------------------- /src/TCXMonad.hs: -------------------------------------------------------------------------------- 1 | module TCXMonad ( 2 | M, runM, 3 | mget, mstate, mupdate, mfail, tell, listen, censor, catchError 4 | ) where 5 | 6 | import Control.Monad.Reader 7 | import Control.Monad.Writer 8 | import Control.Monad.State.Strict 9 | import Control.Monad.Except 10 | 11 | type M r s w a = 12 | ReaderT r (WriterT w (ExceptT String (State s))) a 13 | 14 | runM :: M r s w a -> r -> s -> (Either String (a, w), s) 15 | runM ma r = 16 | runState (runExceptT (runWriterT (runReaderT ma r))) 17 | 18 | mget :: Monoid w => M r s w r 19 | mget = ask 20 | 21 | mstate :: Monoid w => M r s w s 22 | mstate = get 23 | 24 | mupdate :: Monoid w => (s -> s) -> M r s w s 25 | mupdate g = do 26 | s <- get 27 | modify g 28 | return s 29 | 30 | mfail :: Monoid w => String -> M r s w a 31 | mfail = throwError 32 | 33 | -------------------------------------------------------------------------------- /src/Typechecker.hs: -------------------------------------------------------------------------------- 1 | module Typechecker (typecheck, Options(..)) where 2 | 3 | import Control.Monad 4 | import Control.Monad.Except 5 | import Data.Map.Strict (Map) 6 | import qualified Data.Map.Strict as Map 7 | 8 | import qualified Kinds as K 9 | import qualified Syntax as G 10 | import qualified PrettySyntax as PS 11 | import qualified TCSubtyping as TS 12 | import qualified TCTyping as TT 13 | import qualified TCXMonad as TC 14 | import Config as C 15 | 16 | data Seen = SeenSig G.Type | SeenDef 17 | deriving (Eq) 18 | 19 | data Options = Options 20 | { gradual :: Bool 21 | } 22 | 23 | -- | Typecheck a list of declarations. 24 | -- Left -> Error Ok <- Right 25 | typecheck :: Options -> [G.Decl] -> Either String () 26 | typecheck tcOptions decls = do 27 | C.traceM "-------- Running Typecheck Request --------" 28 | exec tcOptions Map.empty [] [] decls 29 | 30 | exec :: Options -> Map G.Ident Seen -> [G.TEnvEntry] -> G.KEnv -> [G.Decl] -> Either String () 31 | exec _ _ _ _ [] = return () 32 | exec tcOptions seendIds tenv kenv (cmd:cmds) = execCmd cmd 33 | where 34 | execCmd :: G.Decl -> Either String () 35 | execCmd (G.DSub ty1 ty2) = do 36 | C.traceM "--- subtyping ---" 37 | void $ runTC tcOptions (TS.subtype tenv ty1 ty2) kenv 38 | exec tcOptions seendIds tenv kenv cmds 39 | execCmd (G.DEqv ty1 ty2) = do 40 | C.traceM "--- equivalence ---" 41 | void $ runTC tcOptions (TS.eqvtype tenv ty1 ty2) kenv 42 | exec tcOptions seendIds tenv kenv cmds 43 | execCmd (G.DSubst x e1 e2) = do 44 | C.traceShowM $ G.subst x e1 e2 45 | exec tcOptions seendIds tenv kenv cmds 46 | execCmd (G.DSig x m ty) = do 47 | C.traceM ("--- signature: " ++ x ++ " ---") 48 | case Map.lookup x seendIds of 49 | Just (SeenSig _) -> 50 | throwError $ "duplicate signatures for ‘" ++ x ++ "’" 51 | Just SeenDef -> 52 | throwError $ "signature for ‘" ++ x ++ "’ given after its definition" 53 | Nothing -> 54 | exec tcOptions (Map.insert x (SeenSig ty) seendIds) ((x,(m, ty)) : tenv) kenv cmds 55 | execCmd (G.DFun f binds e mty) = do 56 | traceM ("--- type checking: " ++ f ++ " ---") 57 | let buildFunction c = foldr (\(m, v, ty) -> c m v ty) 58 | buildty = buildFunction G.TFun 59 | eAlpha = G.alphaConversion e 60 | e' = buildFunction G.Lam eAlpha binds 61 | (tenv', cmds') <- case (Map.lookup f seendIds, mty) of 62 | (Nothing, Nothing) -> do 63 | -- Synthesize the type of the definition. 64 | (ty, _) <- runTC tcOptions (TT.tySynthUnfold tenv e') kenv 65 | return ((f, (K.Many, ty)) : tenv, cmds) 66 | (Nothing, Just ty) -> do 67 | -- Check the definition against the given type. 68 | let fty = buildty ty binds 69 | tenv' = (f, (K.Many, fty)) : tenv 70 | void $ runTC tcOptions (TT.tyCheck tenv' e' fty) kenv 71 | return (tenv', cmds) 72 | (Just (SeenSig sigTy), _) -> do 73 | -- Check the definition against the signatures type. 74 | void $ runTC tcOptions (TT.tyCheck tenv e' sigTy) kenv 75 | -- If mty is given, check type equivalence between it and sigTy 76 | -- next. 77 | let eqv rty = G.DEqv sigTy (buildty rty binds) 78 | return (tenv, maybe id ((:) . eqv) mty cmds) 79 | (Just SeenDef, _) -> 80 | throwError $ "duplicate definition for ‘" ++ f ++ "’" 81 | exec tcOptions (Map.insert f SeenDef seendIds) tenv' kenv cmds' 82 | execCmd (G.DType tid _m k ty) = do 83 | traceM ("--- type declaration: " ++ tid ++ " ---") 84 | -- TODO: in general, we need to wait with this check until all types are declared 85 | let kenv' = (tid, (ty, k)):kenv 86 | -- C.printDebug (Ty.kiCheck tenv ty k) 87 | runTC tcOptions (TT.kiCheck tenv ty k) kenv' 88 | exec tcOptions seendIds tenv kenv' cmds 89 | execCmd (G.DAssume _ _) = do 90 | exec tcOptions seendIds tenv kenv cmds 91 | 92 | runTC :: (PS.Pretty a, PS.Pretty w) => Options -> TC.M TS.ReadOnly TS.Caches w a -> G.KEnv -> Either String a 93 | runTC tcOptions m kenv = 94 | let mReadOnly = TS.ReadOnly { TS.kenv = kenv, TS.gradual = gradual tcOptions } in 95 | case fst $ TC.runM m mReadOnly TS.initCaches of 96 | Left err -> throwError err 97 | Right res -> fst res <$ traceSuccess res 98 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.8 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.7" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /syntax.txt: -------------------------------------------------------------------------------- 1 | ## Mutually recursive type definitions ## 2 | 3 | TID --- type identifier, starts with uppercase letter 4 | 5 | # Declarations 6 | 7 | The top-level accepts a *sequence* of declarations as follows: 8 | 9 | * type declaration with multiplicity and kind (accumulates assumptions) 10 | * variable declaration with multiplicity (accumulates assumptions) 11 | * function definition (runs type checker with assumptions) 12 | * run subtyping (runs subtyping with assumptions) 13 | * run type equivalence 14 | * (obsolete) compute least upper bound of types 15 | * (obsolete) compute greatest lower bound of types 16 | 17 | D ::= "type" TID ":" m K "=" T 18 | | "val" id ":" m T 19 | | "val" id { m "(" id ":" T ")" } "=" M 20 | | T "<:" T 21 | | T "=:" T 22 | | T "\/" T 23 | | T "/\" T 24 | 25 | # Multiplicities: unrestricted (nothing) or single-use 26 | 27 | m ::= | "!" 28 | 29 | # Kinds 30 | 31 | K ::= "~" K' 32 | K' ::= "un" | "lin" | "unit" | "ssn" | "idx" 33 | 34 | # labels 35 | 36 | lab ::= "'" id 37 | 38 | # Types 39 | 40 | T ::= "Unit" 41 | | "Int" 42 | | "Bot" 43 | | TID 44 | | "{" lab { "," lab } "}" 45 | | "case" M "of" "{" lab ":" T { "," lab ":" T } "}" 46 | | "(" id ":" T ")" m "->" T 47 | | "[" m id ":" T "," T "]" 48 | | "!" "(" id ":" T ")" T 49 | | "?" "(" id ":" T ")" T 50 | | "[" m T "," T "]" 51 | | "!" T "." T 52 | | "?" T "." T 53 | | "{{" M "=" M ":" T "}}" 54 | | "dualof" T 55 | 56 | 57 | M ::= "()" 58 | | lab 59 | | id 60 | | "fun" m "(" id ":" T ")" M 61 | | "rec" id "(" id ":" T ")" ":" T "=" M 62 | | M M 63 | | "let" id "=" M "in" M 64 | | "<" m id "=" M "," M ">" m 65 | | "let" "<" id "," id ">" "=" M "in" M 66 | | "fst" M 67 | | "snd" M 68 | | "fork" M 69 | | "new" T 70 | | "send" M 71 | | "recv" M 72 | | "case" M "of" "{" lab ":" M { "," lab ":" M } "}" 73 | | "(" M ")" 74 | 75 | ## later: 76 | 77 | | "select" lab 78 | | "rcase" M "of" "{" lab ":" M { "," lab ":" M } "}" 79 | | "close" M 80 | | "wait" M 81 | -------------------------------------------------------------------------------- /test/ArithmeticSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module ArithmeticSpec (spec) where 4 | 5 | import Test.Hspec 6 | import Utils 7 | 8 | import Syntax 9 | import Kinds 10 | 11 | spec :: Spec 12 | spec = 13 | describe "LDGV parser arithmetic tests" $ do 14 | it "parses an addition" $ do 15 | "val f (m:Int) (n:Int) = m + n" `shouldParseDecl` 16 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 17 | (Math $ Add (Var "m") (Var "n")) 18 | Nothing 19 | 20 | it "parses a subtraction" $ do 21 | "val f (m:Int) (n:Int) = m - n" `shouldParseDecl` 22 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 23 | (Math $ Sub (Var "m") (Var "n")) 24 | Nothing 25 | 26 | it "parses a negation" $ do 27 | "val f (m:Int) (n:Int) = - n" `shouldParseDecl` 28 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 29 | (Math $ Neg (Var "n")) 30 | Nothing 31 | 32 | it "parses a negation with multiplication" $ do 33 | "val f (m:Int) (n:Int) = - 2 * n" `shouldParseDecl` 34 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 35 | (Math $ Neg (Math $ Mul (Lit $ LNat 2) (Var "n"))) 36 | Nothing 37 | 38 | it "parses a negation with subtraction" $ do 39 | "val f (m:Int) (n:Int) = - 2 - n" `shouldParseDecl` 40 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 41 | (Math $ Sub (Math $ Neg (Lit $ LNat 2)) (Var "n")) 42 | Nothing 43 | 44 | it "parses a double negation" $ do 45 | "val f (m:Int) (n:Int) = - - n" `shouldParseDecl` 46 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 47 | (Math $ Neg (Math $ Neg (Var "n"))) 48 | Nothing 49 | 50 | it "parses precedence of multiplication left over subtraction" $ do 51 | "val f (m:Int) (n:Int) = m - 2 * n" `shouldParseDecl` 52 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 53 | (Math $ Sub (Var "m") (Math $ Mul (Lit $ LNat 2) (Var "n"))) 54 | Nothing 55 | 56 | it "parses precedence of multiplication right over subtraction" $ do 57 | "val f (m:Int) (n:Int) = m * 2 - n" `shouldParseDecl` 58 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 59 | (Math $ Sub (Math $ Mul (Var "m") (Lit $ LNat 2)) (Var "n")) 60 | Nothing 61 | 62 | it "parses a division" $ do 63 | "val f (m:Int) (n:Int) = m / n" `shouldParseDecl` 64 | DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 65 | (Math $ Div (Var "m") (Var "n")) 66 | Nothing 67 | 68 | it "parses substraction of negative double literals" $ do 69 | "val f = -12.34 - -56.78" `shouldParseDecl` 70 | DFun "f" [] (Math $ Sub 71 | (Math (Neg (Lit $ LDouble 12.34))) 72 | (Math (Neg (Lit $ LDouble 56.78)))) 73 | Nothing 74 | 75 | it "parses addition of explicitly positive double literals" $ do 76 | "val f = +12.34 + +56.78" `shouldParseDecl` 77 | DFun "f" [] (Math $ Add 78 | (Lit $ LDouble 12.34) (Lit $ LDouble 56.78)) 79 | Nothing 80 | 81 | it "parses substraction of negative integer literals" $ do 82 | "val f = -12 - -56" `shouldParseDecl` 83 | DFun "f" [] (Math $ Sub 84 | (Math (Neg (Lit $ LNat 12))) 85 | (Math (Neg (Lit $ LNat 56)))) 86 | Nothing 87 | 88 | it "parses addition of explicitly positive integer literals" $ do 89 | "val f = +12 + +56" `shouldParseDecl` 90 | DFun "f" [] (Math $ Add 91 | (Lit $ LNat 12) (Lit $ LNat 56)) 92 | Nothing 93 | -------------------------------------------------------------------------------- /test/CSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | module CSpec (spec) where 7 | 8 | import Control.Monad.Reader 9 | import Data.ByteString.Builder (hPutBuilder) 10 | import Data.Text.Lazy (Text) 11 | import Data.Text.Lazy.Encoding (decodeUtf8) 12 | import System.Exit 13 | import System.FilePath 14 | import System.Process.Typed 15 | import Test.Hspec 16 | import UnliftIO 17 | import Utils 18 | import qualified Data.Map as Map 19 | import qualified Data.Text.Lazy as TL 20 | 21 | import C.Compile as C 22 | import C.Generate 23 | import Interpreter (interpret) 24 | import Parsing 25 | import ProcessEnvironment (Value(..)) 26 | import Typechecker (typecheck, Options(..)) 27 | import qualified Examples 28 | 29 | spec :: Spec 30 | spec = parallel do 31 | describe "simple returns" do 32 | it "prints integer" do 33 | let src = unlines 34 | [ "val main : Int" 35 | , "val main = 42" 36 | ] 37 | src `shouldEvaluateTo` Right "Int 42" 38 | 39 | it "prints double" do 40 | let src = unlines 41 | [ "val main : Double" 42 | , "val main = 42.23" 43 | ] 44 | src `shouldEvaluateTo` Right "Double 42.230000" 45 | 46 | it "prints labels" do 47 | let src = unlines 48 | [ "val main : { 'A, 'B }" 49 | , "val main = 'A" 50 | ] 51 | src `shouldEvaluateTo` Right "Label 'A" 52 | 53 | it "prints pairs" do 54 | let src = unlines 55 | [ "val main : [ Int, { 'A, 'B } ]" 56 | , "val main = < n = 42, 'B >" 57 | ] 58 | src `shouldEvaluateTo` Right "" 59 | 60 | -- This tests for miscompilation of shadowed variables. 61 | describe "name shadowing" do 62 | context "in the source language" do 63 | it "shadows only locally" do 64 | let src = unlines 65 | [ "val add (a : Int) (b : Int) = a + b" 66 | , "val main : Int" 67 | , "val main = " 68 | , " let x = 10 in" 69 | , " (let x = 20 in add x) x" 70 | ] 71 | src `shouldEvaluateTo` Right "Int 30" 72 | 73 | it "pair construction" do 74 | let src = unlines 75 | [ "val main : [ Int, [ Int, [ Int, Int ] ] ]" 76 | , "val main = < n = 1, < n = 2, < n = 3, 4 > > >" 77 | ] 78 | src `shouldEvaluateTo` Right ">>" 79 | 80 | it "pair access with fst/snd" do 81 | let src = unlines 82 | [ "val main : [ {'A}, Int ]" 83 | , "val main = " 84 | , " let letpair = 'A in " 85 | , " let x = snd in " 86 | , " " 87 | ] 88 | src `shouldEvaluateTo` Right "