├── .merlin ├── IDEAS.md ├── global-synthesis ├── type.txt ├── synth.ml ├── README.md └── cfsm.ml ├── vm ├── build.sh ├── src │ ├── qvm_interpreter.h │ ├── qvm_instrs.h │ ├── main.cpp │ ├── qvm_instrs.cpp │ ├── qvm_types.h │ ├── qvm_types.cpp │ └── qvm_interpreter.cpp └── IDEAS.md ├── examples ├── basic_stmt.qrz ├── exprs.qrz └── basic.qrz ├── .gitignore ├── configure ├── opam ├── _oasis ├── src ├── pos.ml ├── main.ml ├── lexer.mll ├── typecheck.ml ├── type.ml ├── parser.mly ├── ast.ml └── emit.ml ├── Makefile ├── setup.ml ├── README.md ├── typing.pl └── LICENSE /.merlin: -------------------------------------------------------------------------------- 1 | S src/ 2 | B _build/src/ 3 | -------------------------------------------------------------------------------- /IDEAS.md: -------------------------------------------------------------------------------- 1 | * ML-style module system 2 | * Sum, product types 3 | * `&` operator to run in parallel 4 | -------------------------------------------------------------------------------- /global-synthesis/type.txt: -------------------------------------------------------------------------------- 1 | # Alternative way of defining implicit types/vars? 2 | exists C. 3 | [ c : C ]. 4 | ?c{Hello ~> End} 5 | -------------------------------------------------------------------------------- /vm/build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | g++ -g -std=c++17 -lpthread src/qvm_types.cpp src/qvm_interpreter.cpp src/qvm_instrs.cpp src/main.cpp |& less 3 | ./a.out |& less 4 | -------------------------------------------------------------------------------- /examples/basic_stmt.qrz: -------------------------------------------------------------------------------- 1 | module Examples 2 | require Prelude # Imports some stuff 3 | 4 | session Client(server) 5 | server 6 | end 7 | 8 | fun main() 9 | foreach 10 | end 11 | end 12 | -------------------------------------------------------------------------------- /vm/src/qvm_interpreter.h: -------------------------------------------------------------------------------- 1 | #ifndef QVM_INTERPRETER_H 2 | #define QVM_INTERPRETER_H 3 | 4 | #include "qvm_types.h" 5 | 6 | namespace qz { namespace vm { 7 | 8 | void qz_run_local(std::shared_ptr vm, 9 | std::shared_ptr ctx, 10 | std::shared_ptr message_queue); 11 | 12 | } } 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /global-synthesis/synth.ml: -------------------------------------------------------------------------------- 1 | type ident = string 2 | 3 | module StringMap = Map.Make(String) 4 | 5 | type quantified = Quant of ident StringMap.s * local 6 | 7 | type system = quantified list 8 | 9 | type session = 10 | { params : ident StringMap.s 11 | ; t : quantified 12 | } 13 | 14 | type all_session = session StringMap.t 15 | 16 | type all_instances = quantified StringMap.t 17 | -------------------------------------------------------------------------------- /examples/exprs.qrz: -------------------------------------------------------------------------------- 1 | let x = 5.7 2 | let y = 3 | |a, b| 4 | let z = add(a, b) 5 | print("Test") 6 | print_num(z) 7 | end 8 | end 9 | 10 | fun main(args) 11 | if greater_than(length(args), 0) 12 | do_thing(true, x, args) 13 | else 14 | spawn M(1, 2, 3) 15 | end 16 | foreach(args, |arg| print(arg)) 17 | foreach(args, |arg| 18 | print(arg) 19 | end) 20 | end 21 | -------------------------------------------------------------------------------- /global-synthesis/README.md: -------------------------------------------------------------------------------- 1 | # global-synthesis 2 | 3 | Based on [Multiparty Compatability in Communicating Automata: 4 | Characterisation and Synthesis of Global Session Types](https://arxiv.org/pdf/1304.1902.pdf). 5 | 6 | Implements an inference system that turns local views of multiparty session types into global multiparty session 7 | types, eventually for use in the Quartz compiler. Can be thought of as stage 2 of the compiler's typing pipeline. 8 | -------------------------------------------------------------------------------- /examples/basic.qrz: -------------------------------------------------------------------------------- 1 | module Examples 2 | require Prelude # Imports some stuff 3 | 4 | session Client(server) 5 | server!Hello 6 | on Ready(my_id) from server 7 | server!Log(my_id, "What's up?") 8 | close 9 | or Busy 10 | print("Server busy, retrying in 10s") 11 | wait(10) 12 | loop 13 | end 14 | end 15 | 16 | fun main() 17 | foreach(args, |arg| 18 | print(arg) 19 | end) 20 | end 21 | end 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | # causes problems when switching compiler versions 22 | setup.ml 23 | 24 | # compiler generated files 25 | examples/*.erl 26 | examples/*.beam 27 | 28 | # project specific files 29 | spec/ 30 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "ohadrau " 3 | authors: "ohadrau " 4 | homepage: "http://ohad.space/proj/Quartz" 5 | bug-reports: "http://ohad.space/proj/Quartz/issues" 6 | license: "GPL" 7 | dev-repo: "http://ohad.space/proj/Quartz.git" 8 | build: [ 9 | ["./configure" "--prefix=%{prefix}%"] 10 | [make] 11 | ] 12 | install: [make "install"] 13 | remove: ["ocamlfind" "remove" "Quartz"] 14 | depends: [ 15 | "ocamlfind" {build} 16 | "oasis" {build} 17 | "menhir" 18 | ] 19 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | Name: Quartz 2 | Version: 0.1.0 3 | Synopsis: A strongly-typed concurrent programming language 4 | Authors: ohadrau 5 | License: GPL 6 | 7 | OASISFormat: 0.4 8 | BuildTools: ocamlbuild 9 | Plugins: META (0.4), DevFiles (0.4) 10 | 11 | AlphaFeatures: 12 | ocamlbuild_more_args 13 | 14 | XOCamlbuildExtraArgs: 15 | -use-menhir 16 | -yaccflag --unused-tokens 17 | # -yaccflag --list-errors 18 | # -yaccflag --interpret 19 | # -yaccflag --interpret-show-cst 20 | # -yaccflag --trace 21 | 22 | Executable "Quartz" 23 | Path: src/ 24 | MainIs: main.ml 25 | CompiledObject: best 26 | BuildDepends: 27 | BuildTools+: menhir, ocamllex 28 | -------------------------------------------------------------------------------- /src/pos.ml: -------------------------------------------------------------------------------- 1 | open Lexing 2 | 3 | type pos = 4 | { file_name : string 5 | ; line_number : int 6 | ; column_number : int 7 | } 8 | 9 | let mk_pos pos = 10 | { file_name = pos.pos_fname 11 | ; line_number = pos.pos_lnum 12 | ; column_number = pos.pos_bol 13 | } 14 | 15 | let string_of_pos p = 16 | "line " ^ string_of_int p.line_number ^ ", column " ^ 17 | string_of_int p.column_number ^ " in file " ^ p.file_name 18 | 19 | type range = 20 | { start : pos 21 | ; finish : pos 22 | } 23 | 24 | let make_range startpos endpos = 25 | { start = mk_pos startpos 26 | ; finish = mk_pos endpos 27 | } 28 | 29 | let string_of_range r = 30 | string_of_pos r.start ^ " to " ^ string_of_pos r.finish 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Emit 3 | 4 | let type_test () = 5 | let type1 = Type.(TRec (1, TVar 1)) 6 | and type2 = Type.(TRec (2, TVar 2)) in 7 | let subst = Typecheck.(unify empty_env type1 type2) in 8 | print_endline @@ Type.string_of_type (Typecheck.apply subst type1) 9 | 10 | let () = 11 | let lexbuf = Lexing.from_channel (open_in Sys.argv.(1)) in 12 | let ast = 13 | try Parser.ast Lexer.token lexbuf 14 | with exn -> 15 | let tok = Lexing.lexeme lexbuf in 16 | print_endline tok; 17 | raise exn in 18 | print_endline @@ "AST:\n" ^ string_of_ast ast; 19 | print_endline @@ "Output:\n" ^ emit (make_env Filename.(Sys.argv.(1) |> basename |> chop_extension)) ast; 20 | print_endline @@ "Type:\n" ^ Type.(begin 21 | string_of_type @@ 22 | TQuant (0, Some (LChoose [ "Start", LApp ("()", []), 23 | LOffer [ "Ok", LApp ("()", []), LApp ("Eps", []) 24 | ; "Err", LApp ("()", [LApp ("String", [])]), LApp ("Eps", []) 25 | ] 26 | ]), 27 | TRec (1, 28 | TImplicit ("client", TVar 0, 29 | TOffer ("client", [ "Start", TApp ("()", []), 30 | TChoose ("client", [ "Ok", TApp ("()", []), TVar 1 31 | ; "Err", TApp ("()", [TApp ("String", [])]), TVar 1 32 | ]) 33 | ])))) 34 | end); 35 | type_test () 36 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | (* setup.ml generated for the first time by OASIS v0.4.6 *) 2 | 3 | (* OASIS_START *) 4 | (* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) 5 | (******************************************************************************) 6 | (* OASIS: architecture for building OCaml libraries and applications *) 7 | (* *) 8 | (* Copyright (C) 2011-2013, Sylvain Le Gall *) 9 | (* Copyright (C) 2008-2011, OCamlCore SARL *) 10 | (* *) 11 | (* This library is free software; you can redistribute it and/or modify it *) 12 | (* under the terms of the GNU Lesser General Public License as published by *) 13 | (* the Free Software Foundation; either version 2.1 of the License, or (at *) 14 | (* your option) any later version, with the OCaml static compilation *) 15 | (* exception. *) 16 | (* *) 17 | (* This library is distributed in the hope that it will be useful, but *) 18 | (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) 19 | (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) 20 | (* details. *) 21 | (* *) 22 | (* You should have received a copy of the GNU Lesser General Public License *) 23 | (* along with this library; if not, write to the Free Software Foundation, *) 24 | (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) 25 | (******************************************************************************) 26 | 27 | let () = 28 | try 29 | Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 30 | with Not_found -> () 31 | ;; 32 | #use "topfind";; 33 | #require "oasis.dynrun";; 34 | open OASISDynRun;; 35 | 36 | (* OASIS_STOP *) 37 | let () = setup ();; 38 | -------------------------------------------------------------------------------- /vm/src/qvm_instrs.h: -------------------------------------------------------------------------------- 1 | #ifndef QVM_INSTRS_H 2 | #define QVM_INSTRS_H 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | namespace qz { namespace vm { 11 | 12 | // TODO: REFACTOR: Make statically typed versions of ADD, SUB, etc. 13 | enum Opcode { 14 | NOP, 15 | PUSH, 16 | POP, 17 | ADD, 18 | SUB, 19 | MUL, 20 | DIV, 21 | MOD, 22 | AND, 23 | OR, 24 | XOR, 25 | NOT, 26 | DUP, 27 | SWAP, 28 | EXCHANGE, 29 | CMP, 30 | TCHECK, 31 | JEQ, 32 | JNE, 33 | JLT, 34 | JGT, 35 | JMP, 36 | CALL, 37 | RET, 38 | CONSTRUCT_ASYNC, 39 | SPAWN_EMPTY, 40 | SPAWN_CONSTRUCT, 41 | SEND_MSG, 42 | AWAIT_MSG, 43 | KILL, 44 | CLOSE, 45 | CLOSE_ERR 46 | }; 47 | 48 | enum OperandType { 49 | ILiteral, 50 | FLiteral, 51 | String, 52 | Symbol, 53 | StackRef, 54 | FuncRef 55 | }; 56 | 57 | struct TILiteral { std::int64_t i; }; 58 | struct TFLiteral { double f; }; 59 | struct TString { std::string s; }; 60 | struct TSymbol { std::string s; }; 61 | struct TStackRef { std::int64_t s; }; 62 | struct TFuncRef { std::string f; }; 63 | 64 | struct Operand { 65 | OperandType type; 66 | 67 | union { 68 | std::int64_t int_; 69 | double float_; 70 | std::shared_ptr string; 71 | std::shared_ptr symbol; 72 | std::int64_t stackref; 73 | std::shared_ptr funcref; 74 | }; 75 | 76 | Operand(TILiteral); 77 | Operand(TFLiteral); 78 | Operand(TString); 79 | Operand(TSymbol); 80 | Operand(TStackRef); 81 | Operand(TFuncRef); 82 | 83 | Operand(const Operand &o); 84 | 85 | Operand &operator=(const Operand &o); 86 | 87 | ~Operand(); 88 | }; 89 | 90 | struct Instruction { 91 | Opcode rator; 92 | std::optional rand1; 93 | std::optional rand2; 94 | std::optional rand3; 95 | 96 | Instruction(Opcode oc); 97 | Instruction(Opcode oc, Operand o1); 98 | Instruction(Opcode oc, Operand o1, Operand o2); 99 | Instruction(Opcode oc, Operand o1, Operand o2, Operand o3); 100 | 101 | Instruction(const Instruction &i); 102 | }; 103 | 104 | } } 105 | 106 | #endif 107 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Parser 4 | 5 | let keyword_table = 6 | let hash = Hashtbl.create 20 in 7 | List.iter (fun (keyword, token) -> Hashtbl.add hash keyword token) 8 | [ "close", CLOSE 9 | ; "else", ELSE 10 | ; "end", END 11 | ; "false", FALSE 12 | ; "from", FROM 13 | ; "fun", FUN 14 | ; "if", IF 15 | ; "let", LET 16 | ; "loop", LOOP 17 | ; "module", MODULE 18 | ; "on", ON 19 | ; "or", OR 20 | ; "require", REQUIRE 21 | ; "session", SESSION 22 | ; "spawn", SPAWN 23 | ; "true", TRUE 24 | ]; 25 | hash 26 | } 27 | 28 | let ident_start = ['A'-'Z' 'a'-'z' '_'] 29 | let ident_chars = ['A'-'Z' 'a'-'z' '0'-'9' '_'] 30 | 31 | let digit = ['0'-'9'] 32 | 33 | rule token = parse 34 | | [' ' '\t' '\r'] 35 | { token lexbuf } 36 | | '\n'+ as ns 37 | { for i = 0 to String.length ns do 38 | new_line lexbuf 39 | done; DELIMIT } 40 | | ';' 41 | { DELIMIT } 42 | | '#' 43 | { comment lexbuf } 44 | | '"' 45 | { string_literal (Buffer.create 100) lexbuf } 46 | | '(' 47 | { OPEN_PAREN } 48 | | ')' 49 | { CLOSE_PAREN } 50 | | ',' 51 | { COMMA } 52 | | '|' 53 | { PIPE } 54 | | '!' 55 | { SEND } 56 | | '=' 57 | { EQUALS } 58 | | digit+ as i 59 | { NUMBER (int_of_string i, 0) } 60 | | (digit* as i1) '.' (digit+ as i2) 61 | { NUMBER (int_of_string i1, int_of_string i2) } 62 | | (ident_start ident_chars*) as id 63 | { if Hashtbl.mem keyword_table id 64 | then Hashtbl.find keyword_table id 65 | else IDENT id } 66 | | eof 67 | { EOF } 68 | 69 | and comment = parse 70 | (* TODO: Test more examples, as this 71 | may require a more robust solution *) 72 | | '\n' ['\r' '\t' ' ']* '#' 73 | { new_line lexbuf; comment lexbuf } 74 | | '\n'+ as ns 75 | { let times = String.length ns in 76 | for i = 1 to times do 77 | new_line lexbuf 78 | done; DELIMIT } 79 | | eof 80 | { EOF } 81 | | _ 82 | { comment lexbuf } 83 | 84 | and string_literal strbuf = parse 85 | | eof 86 | { EOF } 87 | | "\\\"" as q 88 | { Buffer.add_string strbuf q; 89 | string_literal strbuf lexbuf } 90 | | '"' 91 | { STRING (Buffer.contents strbuf |> Scanf.unescaped) } 92 | | '\n' 93 | { new_line lexbuf; 94 | Buffer.add_char strbuf '\n'; 95 | string_literal strbuf lexbuf } 96 | | _ as c 97 | { Buffer.add_char strbuf c; 98 | string_literal strbuf lexbuf } 99 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Quartz 2 | 3 | Quartz is a statically typed, concurrent programming language for the BEAM VM based on the actor model with a sleek, Ruby-based syntax and support for functional and object-oriented programming. 4 | 5 | ## Features 6 | 7 | * Familiar Ruby-like syntax 8 | * First-class concurrency primitives 9 | * Actor model message passing à la Erlang 10 | * Static typing for messages based on multiparty session types 11 | * Duality checking 12 | * Structural subtyping 13 | * First-class functions 14 | 15 | ## Roadmap 16 | 17 | - [x] AST 18 | - [x] Pretty Printing 19 | - [x] Core Compiler 20 | - [X] Lexer 21 | - [X] Parser 22 | - [X] FFI 23 | - [ ] Tuples 24 | - [ ] Instance Variables (Mutability) 25 | - [ ] Comparison, arithmetic operators 26 | - [ ] Module Compiler 27 | - [X] Type.t 28 | - [ ] Type parser 29 | - [ ] Type Inference/Type Checking 30 | - [ ] Pattern Matching 31 | - [ ] Syntax Cleanup 32 | 33 | ## Examples 34 | 35 | ``` 36 | # Server: forall c < ...!{Start ~> ...?{Ok ~> Eps, Err(String) ~> Eps}}. 37 | # rec self. 38 | # [client : c] 39 | # ?client{Start ~> !client{Ok ~> self, Err(String) ~> self}} 40 | session Server 41 | on Start from sender 42 | case File.open("file.txt") 43 | when Success(f) 44 | sender!Ok 45 | File.read_into(f, |x| sender!Value(x) end) 46 | else 47 | sender!Err("Could not open file.txt!") 48 | end 49 | end 50 | loop 51 | end 52 | 53 | # Client: (target : Server) -> 54 | # !target{Start ~> ?target{Ok ~> Eps, Err(String) ~> Eps}} 55 | session Client (target : Server) 56 | target!Start 57 | 58 | on Ok from target 59 | on Value(status) from target 60 | print(status) 61 | end 62 | or Err(e) 63 | print("Server-side error when opening file: " ++ e) 64 | end 65 | close # Closes by default, but can be provided explicitly. Can also use `loop`. 66 | end 67 | 68 | fun main 69 | let server = spawn Server 70 | spawn Client(server) 71 | end 72 | ``` 73 | 74 | The above example compiles into the following Erlang output: 75 | 76 | ```erlang 77 | -export([server/1, client/1, main/1]). 78 | 79 | server(unit) -> 80 | receive {start, Sender} -> 81 | io:format("Starting~n", []), 82 | case file:open("file.txt") of 83 | {success, F} -> 84 | Sender!{ok, self()}, 85 | file:read_into(F)(fun(Value) -> Sender!{{value, Value}, self()} end); 86 | _ -> 87 | Sender!{err, self()} 88 | end 89 | end. 90 | 91 | client(Target) -> 92 | io:format("Starting~n", []), 93 | Target!{start, self()}, 94 | 95 | receive 96 | {ok, Sender} -> 97 | receive {{value, Status}, Sender} -> 98 | print(Status), 99 | close(unit) 100 | end; 101 | {err, Sender} -> 102 | print("Server-side error when opening file"), 103 | close(unit) 104 | end. 105 | 106 | main(_) -> 107 | Server = spawn(ex, server, [unit]), 108 | spawn(ex, client, [Server]). 109 | ``` 110 | -------------------------------------------------------------------------------- /vm/src/main.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include "qvm_types.h" 7 | #include "qvm_instrs.h" 8 | 9 | using namespace qz::vm; 10 | 11 | int main(int argc, char **argv) { 12 | auto functions = std::vector { 13 | QzFunction { 14 | .name = "", 15 | .arity = 0, 16 | .program_ptr = 0 17 | }, 18 | QzFunction { 19 | .name = "wait_for_hello", 20 | .arity = 0, 21 | .program_ptr = 3 22 | }, 23 | QzFunction { 24 | .name = "std::print", 25 | .arity = 1, 26 | .program_ptr = 0, 27 | .lambda = [](std::shared_ptr vm, std::shared_ptr ctx) { 28 | auto str = *ctx->stack[ctx->stack_ptr - 1].string; 29 | std::cout << str << std::endl; 30 | } 31 | } 32 | }; 33 | 34 | std::vector instrs = { 35 | Instruction(PUSH, Operand(TString {"Hello, world!"})), 36 | Instruction(CALL, Operand(TFuncRef {"std::print"})), 37 | Instruction(CLOSE), 38 | Instruction(PUSH, Operand(TString {"Awaiting messages!"})), 39 | Instruction(CALL, Operand(TFuncRef {"std::print"})), 40 | Instruction(AWAIT_MSG), 41 | Instruction(CMP, Operand(TSymbol {"Hello"})), 42 | Instruction(JEQ, Operand(TILiteral {0})), 43 | Instruction(SPAWN_EMPTY), 44 | Instruction(PUSH, Operand(TString {"Hello from constructor 1"})), 45 | /* WEIRDEST FUCKING ERROR: 46 | Replace this with any other opcode and it works without a hitch. Comment it out and it works too. 47 | As in, the next CONSTRUCT_ASYNC works just fine as long as it's not right here in the vector. 48 | But if this is placed on this line, we get a segfault on QzThread::create(vm); in this file. 49 | Seems to somehow break the way the vm gets copied with this instruction vector. This makes literally 50 | 0 sense and I'm convinced this is some kind of compiler/STL bug because I can't see how my code would 51 | actually affect what is happening on that line. */ 52 | Instruction(CONSTRUCT_ASYNC, Operand(TILiteral {1}), Operand(TFuncRef {"std::print"})), 53 | Instruction(SPAWN_EMPTY), 54 | Instruction(PUSH, Operand(TString {"Hello from constructor 2"})), 55 | Instruction(CONSTRUCT_ASYNC, Operand(TILiteral {1}), Operand(TFuncRef {"std::print"}), Operand(TStackRef {-2})), 56 | Instruction(CLOSE), 57 | }; 58 | 59 | /* 60 | : 61 | push "Hello, world!" 62 | call @std::print 63 | close 64 | wait_for_hello: 65 | push "Awaiting messages!" 66 | call @std::print 67 | await_msg 68 | cmp $Hello 69 | jeq // print "Hello, world!" 70 | spawn_empty 71 | push "Hello from constructor 1" 72 | construct_async(1) @std::print 73 | spawn_empty 74 | push "Hello from constructor 2" 75 | construct_async(1) @std::print [-2] 76 | close 77 | */ 78 | 79 | // stack_size: 512 * 8 * 8 = 32KiB 80 | // heap_size: 67108864 * 8 = 64MiB 81 | auto vm = QzVm::create_and_run(512, 67108864, functions, instrs); 82 | 83 | auto threadA = QzThread::create(vm); 84 | auto threadB = QzThread::create(vm); 85 | 86 | threadB->exec_function("wait_for_hello"); 87 | threadB->resume(); 88 | 89 | threadB->enqueue_msg( 90 | QzMessage { 91 | .message_symbol = std::hash{}("Hello"), 92 | .message_name = "Hello", 93 | .message_params = std::vector(), 94 | .sender_id = threadA->thread_id 95 | } 96 | ); 97 | 98 | while (true) {} 99 | } 100 | -------------------------------------------------------------------------------- /vm/src/qvm_instrs.cpp: -------------------------------------------------------------------------------- 1 | #include "qvm_instrs.h" 2 | 3 | namespace qz { namespace vm { 4 | 5 | Operand::Operand(TILiteral i) { 6 | this->type = ILiteral; 7 | this->int_ = i.i; 8 | } 9 | Operand::Operand(TFLiteral f) { 10 | this->type = FLiteral; 11 | this->float_ = f.f; 12 | } 13 | Operand::Operand(TString s) : string{} { 14 | this->type = String; 15 | this->string = std::make_shared(s.s); 16 | } 17 | Operand::Operand(TSymbol s) : symbol{} { 18 | this->type = Symbol; 19 | this->symbol = std::make_shared(s.s); 20 | } 21 | Operand::Operand(TStackRef s) { 22 | this->type = StackRef; 23 | this->stackref = s.s; 24 | } 25 | Operand::Operand(TFuncRef f) : funcref{} { 26 | this->type = FuncRef; 27 | this->funcref = std::make_shared(f.f); 28 | } 29 | 30 | // WARNING: unions don't allow multiple initialization. 31 | // However, if we don't initialize the shared_ptr's this 32 | // leads to undefined behavior and segfaults in some 33 | // cases. To get around this, I only initialize string. 34 | // This ONLY works because string, symbol, and funcref 35 | // are all shared_ptr. 36 | Operand::Operand(const Operand &o) : string{} { 37 | this->type = o.type; 38 | switch (o.type) { 39 | case ILiteral: 40 | this->int_ = o.int_; 41 | break; 42 | case FLiteral: 43 | this->float_ = o.float_; 44 | break; 45 | case String: 46 | this->string = o.string; 47 | break; 48 | case Symbol: 49 | this->symbol = o.symbol; 50 | break; 51 | case StackRef: 52 | this->stackref = o.stackref; 53 | break; 54 | case FuncRef: 55 | this->funcref = o.funcref; 56 | break; 57 | } 58 | } 59 | 60 | Operand &Operand::operator=(const Operand &o) { 61 | this->type = o.type; 62 | switch (o.type) { 63 | case ILiteral: 64 | this->int_ = o.int_; 65 | break; 66 | case FLiteral: 67 | this->float_ = o.float_; 68 | break; 69 | case String: 70 | this->string = o.string; 71 | break; 72 | case Symbol: 73 | this->symbol = o.symbol; 74 | break; 75 | case StackRef: 76 | this->stackref = o.stackref; 77 | break; 78 | case FuncRef: 79 | this->funcref = o.funcref; 80 | break; 81 | } 82 | } 83 | 84 | Operand::~Operand() { 85 | switch (this->type) { 86 | case String: 87 | this->string.~shared_ptr(); 88 | break; 89 | case Symbol: 90 | this->symbol.~shared_ptr(); 91 | break; 92 | case FuncRef: 93 | this->funcref.~shared_ptr(); 94 | break; 95 | } 96 | } 97 | 98 | Instruction::Instruction(Opcode oc) : rand1{}, rand2{}, rand3{} { 99 | this->rator = oc; 100 | } 101 | 102 | Instruction::Instruction(Opcode oc, Operand o1) : rand1{}, rand2{}, rand3{} { 103 | this->rator = oc; 104 | this->rand1 = std::optional{o1}; 105 | } 106 | 107 | Instruction::Instruction(Opcode oc, Operand o1, Operand o2) : rand1{}, rand2{}, rand3{} { 108 | this->rator = oc; 109 | this->rand1 = std::optional{o1}; 110 | this->rand2 = std::optional{o2}; 111 | } 112 | 113 | Instruction::Instruction(Opcode oc, Operand o1, Operand o2, Operand o3) : rand1{}, rand2{}, rand3{} { 114 | this->rator = oc; 115 | this->rand1 = std::optional{o1}; 116 | this->rand2 = std::optional{o2}; 117 | this->rand3 = std::optional{o3}; 118 | } 119 | 120 | Instruction::Instruction(const Instruction &i) : rand1{}, rand2{}, rand3{} { 121 | this->rator = i.rator; 122 | this->rand1 = i.rand1; 123 | this->rand2 = i.rand2; 124 | this->rand3 = i.rand3; 125 | } 126 | 127 | } } 128 | -------------------------------------------------------------------------------- /src/typecheck.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Type 3 | 4 | module Scope = Map.Make(struct 5 | type t = identifier 6 | let compare = compare 7 | end) 8 | 9 | module Subst = Map.Make(struct 10 | type t = Type.t 11 | let compare = compare 12 | end) 13 | 14 | type env = 15 | { scope : Type.t Scope.t 16 | ; subst : Type.t Subst.t 17 | ; state : int 18 | } 19 | 20 | let empty_env = { scope = Scope.empty 21 | ; subst = Subst.empty 22 | ; state = 0 23 | } 24 | 25 | let fresh env = 26 | ({ env with state = env.state + 1 }, TVar env.state) 27 | 28 | let rec apply env = function 29 | | TVar _ as tvar -> 30 | if Subst.mem tvar env.subst 31 | then apply env (Subst.find tvar env.subst) 32 | else tvar 33 | | TApp (f, xs) -> TApp (f, List.map (apply env) xs) 34 | | TArrow (a, b) -> TArrow (List.map (apply env) a, apply env b) 35 | | TImplicit (n, t, u) -> TImplicit (n, apply env t, apply env u) 36 | | TNamed (n, t) -> TNamed (n, apply env t) 37 | | TRec (r, t) -> TRec (r, apply env t) 38 | | TOffer (w, offers) -> TOffer (w, List.map (fun (n, p, c) -> (n, apply env p, apply env c)) offers) 39 | | TChoose (w, offers) -> TChoose (w, List.map (fun (n, p, c) -> (n, apply env p, apply env c)) offers) 40 | | TQuant (q, l, t) -> TQuant (q, l, apply env t) 41 | 42 | let rec contains(t2) = function 43 | | TApp (_, xs) -> List.exists (contains(t2)) xs 44 | | TArrow (a, b) -> List.exists (contains(t2)) a || contains(t2) b 45 | | TImplicit (_, a, b) -> contains(t2) a || contains(t2) b 46 | | TNamed (_, t) -> contains(t2) t 47 | | TRec (_, t) -> contains(t2) t 48 | | TOffer (_, offers) | TChoose (_, offers) -> List.exists (fun (_, p, c) -> contains(t2) p || contains(t2) c) offers 49 | | TQuant (_, _, t) -> contains(t2) t 50 | | t1 -> t1 = t2 51 | 52 | let rec unify env t1 t2 = 53 | let t1 = apply env t1 and t2 = apply env t2 in 54 | match t1, t2 with 55 | | _, _ when t1 = t2 -> env 56 | | TVar _, _ when not (contains(t2) t1) -> { env with subst = Subst.add t1 t2 env.subst } 57 | | _, TVar _ when not (contains(t1) t2) -> { env with subst = Subst.add t2 t1 env.subst } 58 | | TApp (f, xs), TApp (g, ys) when f = g -> List.fold_left2 unify env xs ys 59 | | TArrow (args1, r1), TArrow (args2, r2) -> unify (List.fold_left2 unify env args1 args2) r1 r2 60 | | TImplicit (n1, t1, c1), TImplicit (n2, t2, c2) when n1 = n2 -> unify (unify env t1 t2) c1 c2 61 | | TNamed (n1, t1), TNamed (n2, t2) when n1 = n2 -> unify env t1 t2 62 | | TRec (r1, t1), TRec (r2, t2) -> unify (unify env (TVar r1) (TVar r2)) t1 t2 63 | | TQuant (q1, l1, t1), TQuant (q2, l2, t2) when l1 = l2 -> unify (unify env (TVar q1) (TVar q2)) t1 t2 64 | | TOffer (w1, o1), TOffer (w2, o2) | TChoose (w1, o1), TChoose (w2, o2) when w1 = w2 -> 65 | begin (* TODO: Make this create the substitutions necessary to make o1 = o2; 66 | Currently, this will not work if both types have unique names 67 | (e.g. o1 { a, b, c } & o2 { b, c, d }) because the substitutions 68 | will only be applied to one of the two types. *) 69 | let module Offers = Set.Make(String) in 70 | let name_of_offer (n, _, _) = n in 71 | let names = Offers.(elements @@ union (of_list @@ List.map name_of_offer o1) (of_list @@ List.map name_of_offer o2)) in 72 | let rec loop env = function 73 | | [] -> env 74 | | name::names -> 75 | begin 76 | let matcher = List.find (fun o -> name_of_offer o = name) in 77 | match (matcher o1, matcher o2) with 78 | | (_, t1, c1), (_, t2, c2) -> 79 | let env = unify env t1 t2 in 80 | let env = unify env c1 c2 in 81 | loop env names 82 | | exception Not_found -> loop env names 83 | end in 84 | loop env names 85 | end 86 | | _, _ -> failwith @@ "Could not unify type " ^ string_of_type t1 ^ " with type " ^ string_of_type t2 87 | -------------------------------------------------------------------------------- /src/type.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | TVar of int 3 | | TApp of string * t list 4 | | TArrow of t list * t 5 | | TQuant of int * limit option * t 6 | | TImplicit of string * t * t 7 | | TNamed of string * t 8 | | TRec of int * t 9 | | TOffer of string * (string * t * t) list 10 | | TChoose of string * (string * t * t) list 11 | 12 | and limit = 13 | | LVar of int 14 | | LApp of string * limit list 15 | | LArrow of limit list * limit 16 | | LRec of string * limit 17 | | LOffer of (string * limit * limit) list 18 | | LChoose of (string * limit * limit) list 19 | 20 | let rec string_of_type = function 21 | | TVar i -> "_" ^ string_of_int i 22 | | TApp (t, args) -> t ^ "(" ^ String.concat ", " (List.map string_of_type args) ^ ")" 23 | | TArrow (t, u) -> 24 | let params = String.concat ", " @@ List.map string_of_type t in 25 | "(" ^ params ^ ") -> " ^ string_of_type u 26 | | TQuant (v, None, t) -> "forall _" ^ string_of_int v ^ ". " ^ string_of_type t 27 | | TQuant (v, Some l, t) -> "forall _" ^ string_of_int v ^ " < ..." ^ string_of_limit l ^ ". " ^ string_of_type t 28 | | TImplicit (s, t, u) -> "[" ^ s ^ " : " ^ string_of_type t ^ "] " ^ string_of_type u 29 | | TNamed (s, t) -> "(" ^ s ^ " : " ^ string_of_type t ^ ")" 30 | | TRec (v, t) -> "rec _" ^ string_of_int v ^ ". " ^ string_of_type t 31 | | TOffer (w, offers) -> "?" ^ w ^ "{" ^ String.concat ", " (List.map string_of_toffer offers) ^ "}" 32 | | TChoose (w, offers) -> "!" ^ w ^ "{" ^ String.concat ", " (List.map string_of_toffer offers) ^ "}" 33 | 34 | and string_of_limit = function 35 | | LVar i -> "_" ^ string_of_int i 36 | | LApp (t, args) -> t ^ "(" ^ String.concat ", " (List.map string_of_limit args) ^ ")" 37 | | LArrow (t, u) -> 38 | let params = String.concat ", " @@ List.map string_of_limit t in 39 | "(" ^ params ^ ") -> " ^ string_of_limit u 40 | | LRec (v, t) -> "rec _" ^ v ^ ". " ^ string_of_limit t 41 | | LOffer offers -> "?{" ^ String.concat ", " (List.map string_of_loffer offers) ^ "}" 42 | | LChoose offers -> "!{" ^ String.concat ", " (List.map string_of_loffer offers) ^ "}" 43 | 44 | and string_of_toffer (msg, t1, t2) = 45 | msg ^ string_of_type t1 ^ " ~> " ^ string_of_type t2 46 | 47 | and string_of_loffer (msg, l1, l2) = 48 | msg ^ string_of_limit l1 ^ " ~> ..." ^ string_of_limit l2 49 | 50 | (* Get the names of all sessions that a type communicates with *) 51 | let neighbors t = 52 | let module S = Set.Make(String) in 53 | let fold_set f xs = 54 | List.fold_right (fun x s -> S.union s (f x)) xs S.empty in 55 | let rec traverse = function 56 | | TVar _ -> S.empty 57 | | TApp (_, xs) -> fold_set traverse xs 58 | | TArrow (xs, y) -> S.union (fold_set traverse xs) (traverse y) 59 | | TQuant (_, _, t) -> traverse t 60 | | TImplicit (_, t, c) -> S.union (traverse t) (traverse c) 61 | | TNamed (_, t) -> traverse t 62 | | TRec (_, t) -> traverse t 63 | | TOffer (w, offers) | TChoose (w, offers) -> 64 | S.add w (fold_set (fun (_, t, c) -> S.union (traverse t) (traverse c)) offers) in 65 | traverse t |> S.elements 66 | 67 | (* Make a session type binary with respect to the session named w *) 68 | let rec binary w = function 69 | | TVar i -> TVar i 70 | | TApp (s, ts) -> TApp (s, List.map (binary w) ts) 71 | | TArrow (xs, y) -> TArrow (List.map (binary w) xs, binary w y) 72 | | TQuant (i, l, t) -> TQuant (i, l, binary w t) 73 | | TImplicit (s, x, y) -> TImplicit (s, binary w x, binary w y) 74 | | TNamed (s, t) -> TNamed (s, binary w t) 75 | | TRec (i, t) -> TRec (i, binary w t) 76 | | TOffer (s, offers) when s = w -> 77 | TOffer (w, List.map (fun (n, t, c) -> (n, binary w t, binary w c)) offers) 78 | | TChoose (s, offers) when s = w -> 79 | TChoose (w, List.map (fun (n, t, c) -> (n, binary w t, binary w c)) offers) 80 | (* FIXME: This assumes that each offer provides a unifiable continuation *) 81 | | TOffer (_, (_, _, c)::_) | TChoose (_, (_, _, c)::_) -> binary w c 82 | | TOffer (_, []) | TChoose (_, []) -> TApp ("End", []) 83 | -------------------------------------------------------------------------------- /typing.pl: -------------------------------------------------------------------------------- 1 | :- set_prolog_flag(occurs_check, true). 2 | 3 | type(X, T) :- type([], X, T). 4 | 5 | type(Gamma, var(X), U) :- contains(Gamma, X:T), instantiate(T, U). 6 | type(Gamma, lam(X, E), T -> U) :- type([X:mono(T) | Gamma], E, U). 7 | type(Gamma, app(F, X), U) :- type(Gamma, F, T -> U), type(Gamma, X, T). 8 | type(Gamma, let(X, E0, E1), T) :- type(Gamma, E0, U), type([X:poly(Gamma, U) | Gamma], E1, T). 9 | 10 | type(Gamma, sendMsg(Who, Msg, Args, Then), sendMsg(Who, [Msg-(AT, TT)])) :- 11 | type(Gamma, Who, W), 12 | compatible(sendMsg(Who, [Msg-(AT, TT)]), W), 13 | type(Gamma, Args, AT), 14 | type(Gamma, Then, TT). 15 | 16 | type(Gamma, recvMsg(Who, Msg, Args, Then), recvMsg(Who, [Msg-(AT, TT)])) :- 17 | compatible(recvMsg(Who, [Msg-(AT, TT)]), W), 18 | % FIXME: What to do if Who is already bound? Conditional breaks this. 19 | Gamma1 = [Who:W, Args:mono(AT) | Gamma], 20 | type(Gamma1, Then, TT). 21 | 22 | type(Gamma, [E], T) :- type(Gamma, E, T). 23 | 24 | type(Gamma, [E | Es], sendMsg(Who, Msgs)) :- 25 | type(Gamma, E, sendMsg(Who, M)), 26 | type(Gamma, Es, sendMsg(Who, Ms)), 27 | append(M, Ms, Msgs). 28 | 29 | type(Gamma, [E | Es], recvMsg(Who, Msgs)) :- 30 | type(Gamma, E, recvMsg(Who, M)), 31 | type(Gamma, Es, recvMsg(Who, Ms)), 32 | append(M, Ms, Msgs). 33 | 34 | type(Gamma, [_ | Es], T) :- type(Gamma, Es, T). 35 | 36 | type(_, [], eps). 37 | 38 | contains([K1:V1 | _], K:V) :- K = K1, V = V1. 39 | contains([K1:_ | Gamma], K:V) :- K \== K1, contains(Gamma, K:V). 40 | 41 | instantiate(poly(Gamma, T), U) :- copy_term(Gamma |- T, Gamma |- U). 42 | instantiate(mono(T), T). 43 | 44 | % Check that a session is able to receive all incoming messages 45 | receivesAll(CList, AList) :- 46 | catch(keysort(CList, Concrete), _, true), 47 | catch(keysort(AList, Abstract), _, true), 48 | pairs_keys(Abstract, Keys), % Sent messages => all matched 49 | allCompatibleAux(Keys, Concrete, Abstract), 50 | CList = Concrete, 51 | AList = Abstract. 52 | 53 | % Check that a session is only sending valid messages that can be received 54 | sendsValid(CList, AList) :- 55 | catch(keysort(CList, Concrete), _, true), 56 | catch(keysort(AList, Abstract), _, true), 57 | pairs_keys(Concrete, Keys), % Sent messages => all matched 58 | allCompatibleAux(Keys, Concrete, Abstract), 59 | CList = Concrete, 60 | AList = Abstract. 61 | 62 | allCompatibleAux([], _, _). 63 | allCompatibleAux([Key | Keys], [Key-(CArg, CThen) | Concrete], [Key-(AArg, AThen) | Abstract]) :- 64 | % All keys in concrete are tested 65 | CArg = AArg, 66 | compatible(CThen, AThen), 67 | allCompatibleAux(Keys, Concrete, Abstract). 68 | allCompatibleAux([Key | Keys], [Key-(CArg, CThen) | Concrete], [_ | Abstract]) :- 69 | allCompatibleAux([Key | Keys], [Key-(CArg, CThen) | Concrete], Abstract). 70 | allCompatibleAux([Key | Keys], [_ | Concrete], [Key-(AArg, AThen) | Abstract]) :- 71 | allCompatibleAux([Key | Keys], Concrete, [Key-(AArg, AThen) | Abstract]). 72 | 73 | compatible(recvMsg(_, B1), sendMsg(B2)) :- receivesAll(B1, B2). 74 | compatible(sendMsg(_, B1), recvMsg(B2)) :- sendsValid(B1, B2). 75 | 76 | compatible(T, T) :- 77 | T \= sendMsg(_), 78 | T \= recvMsg(_), 79 | T \= sendMsg(_, _), 80 | T \= recvMsg(_, _). % Any normal type is compatible with itself 81 | 82 | test(T) :- 83 | G = [ get_time : mono(unit -> time) 84 | , unit : mono(unit) 85 | , diff_time : mono(time -> time -> time) 86 | , string_of_time : mono(time -> string) 87 | , print : mono(string -> unit) 88 | , server : mono(recvMsg(client, [ 89 | login-(strings, sendMsg(client, [success-(token, eps), failure-(unit, eps)])), 90 | ping-(unit, sendMsg(client, [pong-(time, eps)]))])) 91 | ], 92 | Expr = 93 | let(client, lam(s, 94 | let(time, app(var(get_time), var(unit)), 95 | sendMsg(var(s), ping, var(unit), [ 96 | recvMsg(var(s), pong, t, [ 97 | let(ping, app(app(var(diff_time), var(t)), var(time)), 98 | app(var(print), app(var(string_of_time), var(ping))))])]))), 99 | var(client)), 100 | type(G, Expr, T). 101 | -------------------------------------------------------------------------------- /vm/src/qvm_types.h: -------------------------------------------------------------------------------- 1 | #ifndef QVM_TYPES_H 2 | #define QVM_TYPES_H 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | #include "qvm_instrs.h" 15 | 16 | namespace qz { namespace vm { 17 | 18 | struct QzVm; 19 | 20 | struct QzContext; 21 | struct QzDatum; 22 | struct QzFunction; 23 | struct QzThread; 24 | 25 | struct QzMessage; 26 | 27 | struct QzVm { 28 | std::mutex vm_lock; 29 | 30 | std::size_t stack_size; 31 | std::size_t heap_size; 32 | 33 | std::vector heap; 34 | 35 | std::map function_table; 36 | std::map> thread_map; 37 | 38 | QzVm(std::size_t stack_size, 39 | std::size_t heap_size, 40 | std::vector program, 41 | std::vector instrs); 42 | 43 | static std::shared_ptr create_and_run(std::size_t stack_size, std::size_t heap_size, std::vector program, std::vector instrs); 44 | }; 45 | 46 | // Should be thread-safe. The assumption is that the only time this is accessed from another thread 47 | // is when the thread holding the context has yielded control, for example when executing a native 48 | // function (wherein the thread pauses, and the native function can deal with threading issues if 49 | // that is necessary). 50 | struct QzContext { 51 | bool thread_running; 52 | 53 | std::size_t stack_ptr; 54 | std::size_t frame_ptr; 55 | std::size_t instr_ptr; 56 | 57 | std::vector stack; 58 | 59 | QzContext(std::size_t stack_size); 60 | }; 61 | 62 | enum QzDatumType { 63 | QZ_DATUM_INT, 64 | QZ_DATUM_FLOAT, 65 | QZ_DATUM_SYMBOL, 66 | QZ_DATUM_STRING, 67 | QZ_DATUM_FUNCTION_POINTER, 68 | QZ_DATUM_THREAD, 69 | QZ_DATUM_INTERNAL 70 | }; // TODO: Product types + sum types (or lists, arrays, etc.) 71 | 72 | struct QzDatum { 73 | QzDatumType type; 74 | union { 75 | std::int64_t int_; 76 | double float_; 77 | std::size_t symbol; 78 | std::shared_ptr string; 79 | std::shared_ptr function; 80 | std::thread::id thread; 81 | std::array internal; 82 | }; 83 | 84 | QzDatum(); 85 | QzDatum(const QzDatum &d); 86 | 87 | QzDatum(std::int64_t i); 88 | QzDatum(double d); 89 | QzDatum(std::size_t s); 90 | QzDatum(std::string s); 91 | QzDatum(std::shared_ptr s); 92 | QzDatum(std::shared_ptr f); 93 | QzDatum(std::thread::id); 94 | QzDatum(std::array a); 95 | 96 | QzDatum &operator=(const QzDatum &d); 97 | 98 | ~QzDatum(); 99 | }; 100 | 101 | struct QzFunction { 102 | std::string name; 103 | std::size_t arity; 104 | std::size_t program_ptr; 105 | std::optional, std::shared_ptr)>> lambda; 106 | }; 107 | 108 | struct QzMailbox { 109 | std::mutex mail_lock; 110 | std::queue message_queue; 111 | }; 112 | 113 | enum QzThreadType { 114 | QZ_THREAD_LOCAL, 115 | QZ_THREAD_FOREIGN 116 | }; 117 | 118 | struct QzLocalThread { 119 | std::shared_ptr vm; 120 | std::shared_ptr ctx; 121 | std::shared_ptr thread; 122 | std::shared_ptr mailbox; 123 | }; 124 | 125 | struct QzThread { 126 | std::thread::id thread_id; 127 | 128 | QzThreadType type; 129 | union { 130 | QzLocalThread local; 131 | // or 132 | 133 | // Socket 134 | }; 135 | 136 | QzThread(std::shared_ptr vm); 137 | 138 | // FUTURE: We could switch to a single unique_ptr to the thread and 139 | // simply return the thread ID here. However, this would require us 140 | // to move all thread related function outside the QzThread class. 141 | // So for example we could do qz::vm::send(thread, "kill"); or even 142 | // thread_ref.kill(), which would wrap that. However, it's not clear 143 | // whether this is really worth adding or not so I'll leave it for 144 | // now. The one nice thing is I could move away from a union and 145 | // instead have a QzThread class that Local and Foreign both inherit 146 | // from. 147 | static std::shared_ptr create(std::shared_ptr vm); 148 | 149 | ~QzThread(); 150 | 151 | void kill(); 152 | void enqueue_msg(QzMessage m); 153 | void clear_msg_queue(); 154 | void exec_function(std::string name); 155 | std::shared_ptr fork(); 156 | void migrate(QzThreadType t); 157 | void pause(); 158 | void resume(); 159 | }; 160 | 161 | struct QzMessage { 162 | std::size_t message_symbol; 163 | std::string message_name; 164 | std::vector message_params; 165 | std::thread::id sender_id; 166 | }; 167 | 168 | } } 169 | 170 | #endif 171 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Ast 3 | open Pos 4 | 5 | let mk_ast desc pos = 6 | { ast_desc = desc 7 | ; ast_src = None 8 | ; ast_pos = pos 9 | } 10 | 11 | let mk_stmt desc pos = 12 | { stmt_desc = desc 13 | ; stmt_type = Nothing 14 | ; stmt_src = None 15 | ; stmt_pos = pos 16 | } 17 | 18 | let mk_expr desc pos = 19 | { expr_desc = Left desc 20 | ; expr_type = Nothing 21 | ; expr_src = None 22 | ; expr_pos = pos 23 | } 24 | 25 | let mk_sesh desc pos = 26 | { expr_desc = Right desc 27 | ; expr_type = Nothing 28 | ; expr_src = None 29 | ; expr_pos = pos 30 | } 31 | %} 32 | 33 | %token CLOSE CLOSE_PAREN COMMA ELSE END EOF EQUALS FALSE FROM FUN IF LET LOOP MODULE DELIMIT ON OPEN_PAREN OR PIPE REQUIRE SEND SESSION SPAWN TRUE 34 | %token IDENT STRING 35 | %token NUMBER 36 | 37 | %nonassoc below_DELIMIT 38 | %nonassoc DELIMIT 39 | 40 | %start ast 41 | %type <[`No] Ast.ast> ast 42 | 43 | %% 44 | 45 | ast: 46 | | stmts EOF 47 | { mk_ast $1 (mk_pos $startpos) } 48 | ; 49 | 50 | stmts: 51 | | stmt DELIMIT 52 | { [$1] } 53 | | stmt DELIMIT stmts 54 | { $1::$3 } 55 | ; 56 | 57 | stmt: 58 | | REQUIRE IDENT 59 | { mk_stmt (SRequire (Value $2)) (mk_pos $startpos) } 60 | | MODULE IDENT DELIMIT stmts END 61 | { mk_stmt (SModule ($2, $4)) (mk_pos $startpos) } 62 | | LET IDENT EQUALS expr 63 | { mk_stmt (SLet ($2, [$4])) (mk_pos $startpos) } 64 | | LET IDENT EQUALS DELIMIT exprs END 65 | { mk_stmt (SLet ($2, $5)) (mk_pos $startpos) } 66 | | FUN IDENT OPEN_PAREN params CLOSE_PAREN DELIMIT exprs END 67 | { let lam = mk_expr (ELam ($4, $7)) (mk_pos $startpos) in 68 | mk_stmt (SLet ($2, [lam])) (mk_pos $startpos) } 69 | | SESSION IDENT OPEN_PAREN params CLOSE_PAREN DELIMIT sessions END 70 | { let sesh = mk_expr (ESession $7) (mk_pos $startpos) in 71 | let lam = mk_expr (ELam ($4, [sesh])) (mk_pos $startpos) in 72 | mk_stmt (SLet ($2, [lam])) (mk_pos $startpos) } 73 | ; 74 | 75 | params: 76 | | separated_list(COMMA, IDENT) 77 | { $1 } 78 | ; 79 | 80 | exprs: 81 | | expr %prec below_DELIMIT 82 | { [$1] } 83 | | expr DELIMIT 84 | { [$1] } 85 | | expr DELIMIT exprs 86 | { $1::$3 } 87 | ; 88 | 89 | sessions: 90 | | session %prec below_DELIMIT 91 | { [$1] } 92 | | session DELIMIT 93 | { [$1] } 94 | | session DELIMIT sessions 95 | { $1::$3 } 96 | ; 97 | 98 | expr: 99 | | NUMBER 100 | { mk_expr (ELiteral (Number $1)) (mk_pos $startpos) } 101 | | TRUE 102 | { mk_expr (ELiteral (Bool true)) (mk_pos $startpos) } 103 | | FALSE 104 | { mk_expr (ELiteral (Bool false)) (mk_pos $startpos) } 105 | | STRING 106 | { mk_expr (ELiteral (String $1)) (mk_pos $startpos) } 107 | | IDENT 108 | { mk_expr (EIdent (Value $1)) (mk_pos $startpos) } 109 | | LET IDENT EQUALS expr DELIMIT exprs 110 | { mk_expr (ELet ($2, [$4], $6)) (mk_pos $startpos) } 111 | | LET IDENT EQUALS DELIMIT exprs END DELIMIT exprs 112 | { mk_expr (ELet ($2, $5, $8)) (mk_pos $startpos) } 113 | | FUN IDENT OPEN_PAREN params CLOSE_PAREN DELIMIT exprs END DELIMIT exprs 114 | { let lam = mk_expr (ELam ($4, $7)) (mk_pos $startpos) in 115 | mk_expr (ELet ($2, [lam], $10)) (mk_pos $startpos) } 116 | | SESSION IDENT OPEN_PAREN params CLOSE_PAREN DELIMIT sessions END DELIMIT exprs 117 | { let sesh = mk_expr (ESession $7) (mk_pos $startpos) in 118 | let lam = mk_expr (ELam ($4, [sesh])) (mk_pos $startpos) in 119 | mk_expr (ELet ($2, [lam], $10)) (mk_pos $startpos) } 120 | | PIPE params PIPE expr 121 | { mk_expr (ELam ($2, [$4])) (mk_pos $startpos) } 122 | | PIPE params PIPE DELIMIT exprs END 123 | { mk_expr (ELam ($2, $5)) (mk_pos $startpos) } 124 | | expr OPEN_PAREN separated_list(COMMA, expr) CLOSE_PAREN 125 | { mk_expr (EApp ($1, $3)) (mk_pos $startpos) } 126 | | IF expr DELIMIT exprs ELSE DELIMIT exprs END 127 | { mk_expr (ECond ($2, $4, $7)) (mk_pos $startpos) } 128 | | SPAWN IDENT OPEN_PAREN separated_list(COMMA, expr) CLOSE_PAREN 129 | { mk_expr (ESpawn (Value $2, $4)) (mk_pos $startpos) } 130 | /* No rule for parsing sessions, since anonymous sessions 131 | are not yet supported */ 132 | ; 133 | 134 | session: 135 | | expr 136 | { Obj.magic $1 } 137 | | CLOSE 138 | { mk_sesh EClose (mk_pos $startpos) } 139 | | LOOP 140 | { mk_sesh (ELoop None) (mk_pos $startpos) } 141 | | LOOP OPEN_PAREN separated_list(COMMA, session) CLOSE_PAREN 142 | { mk_sesh (ELoop (Some $3)) (mk_pos $startpos) } 143 | | IDENT SEND IDENT DELIMIT sessions 144 | { mk_sesh (ESend (Value $1, $3, [], $5)) (mk_pos $startpos) } 145 | | IDENT SEND IDENT OPEN_PAREN separated_list(COMMA, session) CLOSE_PAREN DELIMIT sessions 146 | { mk_sesh (ESend (Value $1, $3, $5, $8)) (mk_pos $startpos) } 147 | | ON IDENT FROM IDENT DELIMIT sessions or_branches 148 | { mk_sesh (EBranch ($4, ($2, [], $6)::$7)) (mk_pos $startpos) } 149 | | ON IDENT OPEN_PAREN separated_list(COMMA, IDENT) CLOSE_PAREN FROM IDENT DELIMIT sessions or_branches 150 | { mk_sesh (EBranch ($7, ($2, $4, $9)::$10)) (mk_pos $startpos) } 151 | ; 152 | 153 | or_branches: 154 | | END 155 | { [] } 156 | | OR IDENT DELIMIT sessions or_branches 157 | { ($2, [], $4)::$5 } 158 | | OR IDENT OPEN_PAREN separated_list(COMMA, IDENT) CLOSE_PAREN DELIMIT sessions or_branches 159 | { ($2, $4, $7)::$8 } 160 | ; 161 | -------------------------------------------------------------------------------- /vm/IDEAS.md: -------------------------------------------------------------------------------- 1 | The Quartz VM: 2 | ------------- 3 | 4 | * Probably needs some fancy rock-related name (SiO2, Silicon/Silica, Oxygen, Mineral, Amethyst) 5 | * Exceptions are first-class 6 | * Concurrency/parallelism are first-class 7 | * Message passing is first-class (w/ message queues) 8 | + All threads have implicit mailboxes 9 | + Thread type can be defined as: 10 | ```ocaml 11 | type qthread = { 12 | address : int; 13 | mailbox : message_queue; (* What happens if the thread is on a different computer? *) 14 | proc : [ `Process of native_process | `Thread of native_thread | `Socket of native_socket ]; 15 | } 16 | ``` 17 | + Thread objects have the following (external) operations: 18 | - `kill` => Forcibly terminate the thread 19 | - `enqueue_msg` => Add a message to a thread's message queue 20 | - `clear_queue` => Clear a thread's message queue 21 | - `exec_program` => Set the program (function/session) to run on that thread 22 | - `fork` => Duplicate the thread 23 | - `migrate` => Move a thread to a different native thread/process or a different computer and change the socket 24 | - `pause_exec` => Temporarily pause execution of the thread's program 25 | - `resume_exec` => Resume execution of the thread's program 26 | * Built-in GC 27 | * Stack-based probably 28 | * Doesn't need to be extremely low-level 29 | * Maybe sessions should mimic classes in JVM bytecode 30 | + Top-level export with type signatures 31 | * Somewhat dynamically typed 32 | + When code hops between computers, we need some checks to make sure everything is okay 33 | + E.g. if one server goes AWOL, we need dynamic chceks in place to respond 34 | + We can assume that all local threads are safe at runtime 35 | 36 | ## Ideas: 37 | 38 | * OCaml bytecode 39 | * JVM bytecode 40 | * BEAM bytecode 41 | 42 | ## Examples: 43 | 44 | ``` 45 | session Timer(s) 46 | on Start from s 47 | let now = std::get_time_ms() 48 | on Stop from s 49 | let new = std::get_time_ms() 50 | s!Took(new - now) 51 | end 52 | end 53 | end 54 | 55 | session P(q) 56 | t = spawn Timer(self) 57 | t!Start 58 | q!Ping 59 | on Pong from q 60 | t!Stop 61 | on Took(ms) 62 | std::print(ms) 63 | end 64 | end 65 | end 66 | 67 | session Q(p) 68 | on Ping from p 69 | std::wait(10) 70 | p!Pong 71 | end 72 | end 73 | 74 | fun main() 75 | let p = spawn P(q) 76 | and q = spawn Q(p) 77 | end 78 | ``` 79 | 80 | ``` 81 | session Timer < exists S. [s : S] -> ?s{Start ~> ?s{Stop ~> !s{Took(int) ~> End}}} >: 82 | # push s 83 | await_msg [0] 84 | cmp $Start 85 | jne _nomatch0 86 | call_function @std::get_time_ms 87 | await_msg [-1] 88 | cmp $Stop 89 | jne _nomatch0 90 | pop 91 | call_function @std::get_time_ms 92 | sub 93 | send_msg(1) [-1] $Took 94 | close 95 | 96 | _nomatch0: 97 | close_err "Session Timer received unmatched message from ?S" # Better example would use exceptions 98 | 99 | session P < exists Q. (q : Q) -> [t : Timer] -> !t{Start ~> !q{Ping ~> ?q{Pong ~> !t{Stop ~> ?t{Took(int) ~> End}}}}} >: 100 | # push q 101 | push @self 102 | call_constructor_spawn @Timer # Call and push spawn Timer(self) 103 | send_msg [0] $Start 104 | send_msg [-1] $Ping 105 | await_msg [-1] 106 | cmp $Pong 107 | jne _nomatch0 108 | send_msg [-1] $Stop 109 | await_msg(1) [-1] # Takes an additional arg (goes argN, ..., arg0, N, msg) 110 | cmp $Took 111 | jne _nomatch1 112 | pop 113 | pop 114 | call_function @std::print 115 | close 116 | 117 | _nomatch0: 118 | close_err "Session P received unmatched message from Q" # Better example would use exceptions 119 | 120 | _nomatch1: 121 | close_err "Session P received unmatched message from Timer" # Better example would use exceptions 122 | 123 | session Q < exists P. (p : P) -> ?p{Ping ~> !p{Pong ~> End}} >: 124 | # push p 125 | await_msg [0] # Await a message from p 126 | cmp $Ping # Compare last item on stack (the message) to $Ping 127 | jne _nomatch0 128 | push 10 129 | call_function @std::wait 130 | send_msg [-1] $Pong # Send $Pong to p 131 | close 132 | 133 | _nomatch0: 134 | close_err "Session Q received unmatched message from P" # Better example would use exceptions 135 | 136 | function main < () -> void >: 137 | spawn_empty # Push thread p onto stack 138 | spawn_empty # Push thread q onto stack 139 | call_constructor_async @P [-1] # Takes 1 off the stack (q) and runs on thread p 140 | swap 141 | call_constructor_async @Q [-1] # Takes 1 off the stack (p) and runs on thread q 142 | ``` 143 | 144 | ## The QuartzVM Protocol 145 | 146 | * VMs will often be running either in separate processes or on separate systems 147 | * We can use network sockets to communicate between these on some protocol 148 | + Most likely TCP-based, UDP would be nice but safety is more important => maybe compiler flag? 149 | * Can occur at macro level (entire VMs communicating) or micro level (sessions communicating across servers) 150 | 151 | ### Definition: 152 | 153 | ``` 154 | [QVM_OPERATION][QVM_NUM_PARAMS][QVM_PARAMS...] 155 | 156 | QVM_OPERATION = 157 | | "qvm_immigrate" -- (thread_id, context, code_pointer) -> status => Take an "immigrant" thread 158 | | "qvm_emigrate" -- (thread_id) -> (status, context, code_pointer) => Give thread information 159 | | "qvm_kill" -- (thread_id) -> status => Kill a thread 160 | ``` 161 | -------------------------------------------------------------------------------- /vm/src/qvm_types.cpp: -------------------------------------------------------------------------------- 1 | #include "qvm_types.h" 2 | 3 | #include "qvm_interpreter.h" 4 | 5 | namespace qz { namespace vm { 6 | 7 | QzVm::QzVm(std::size_t stack_size, std::size_t heap_size, std::vector program, std::vector instrs) { 8 | std::lock_guard lock(this->vm_lock); 9 | 10 | this->stack_size = stack_size; 11 | this->heap_size = heap_size; 12 | 13 | this->heap = std::vector(heap_size); 14 | int8_t *ibase_ptr = (int8_t *)&instrs[0]; 15 | for (int i = 0; i < instrs.size() * sizeof(Instruction); i++) 16 | this->heap[i] = ibase_ptr[i]; 17 | // TODO: Allocate portions of the heap 18 | 19 | for (auto fn : program) { 20 | this->function_table[fn.name] = fn; 21 | } 22 | } 23 | 24 | std::shared_ptr QzVm::create_and_run(std::size_t stack_size, std::size_t heap_size, std::vector program, std::vector instrs) { 25 | std::shared_ptr vm = std::make_shared(stack_size, heap_size, program, instrs); 26 | 27 | auto main_thread = QzThread::create(vm); 28 | main_thread->exec_function(""); 29 | main_thread->resume(); 30 | 31 | return vm; 32 | } 33 | 34 | QzContext::QzContext(std::size_t stack_size) { 35 | this->thread_running = false; 36 | this->stack = std::vector(stack_size); 37 | this->stack_ptr = this->frame_ptr = 0; 38 | this->instr_ptr = 0; 39 | } 40 | 41 | QzDatum::QzDatum() : string{} { // HACK 42 | this->type = QZ_DATUM_INTERNAL; 43 | this->internal = std::array {}; 44 | } 45 | 46 | QzDatum::QzDatum(std::int64_t i) { 47 | this->type = QZ_DATUM_INT; 48 | this->int_ = i; 49 | } 50 | 51 | QzDatum::QzDatum(double f) { 52 | this->type = QZ_DATUM_FLOAT; 53 | this->float_ = f; 54 | } 55 | 56 | QzDatum::QzDatum(std::size_t s) { 57 | this->type = QZ_DATUM_SYMBOL; 58 | this->symbol = s; 59 | } 60 | 61 | QzDatum::QzDatum(std::string s) : string{} { 62 | this->type = QZ_DATUM_STRING; 63 | this->string = std::make_shared(s); 64 | } 65 | 66 | QzDatum::QzDatum(std::shared_ptr s) : string{} { 67 | this->type = QZ_DATUM_STRING; 68 | this->string = s; 69 | } 70 | 71 | QzDatum::QzDatum(std::shared_ptr f) : function{} { 72 | this->type = QZ_DATUM_FUNCTION_POINTER; 73 | this->function = f; 74 | } 75 | 76 | QzDatum::QzDatum(std::thread::id t) { 77 | this->type = QZ_DATUM_THREAD; 78 | this->thread = t; 79 | } 80 | 81 | QzDatum::QzDatum(std::array a) { 82 | this->type = QZ_DATUM_INTERNAL; 83 | this->internal = a; 84 | } 85 | 86 | QzDatum::QzDatum(const QzDatum &d) : string{} { // HACK 87 | this->type = d.type; 88 | switch (d.type) { 89 | case QZ_DATUM_INT: 90 | this->int_ = d.int_; 91 | break; 92 | case QZ_DATUM_FLOAT: 93 | this->float_ = d.float_; 94 | break; 95 | case QZ_DATUM_SYMBOL: 96 | this->symbol = d.symbol; 97 | break; 98 | case QZ_DATUM_STRING: 99 | this->string = d.string; 100 | break; 101 | case QZ_DATUM_FUNCTION_POINTER: 102 | this->function = d.function; 103 | break; 104 | case QZ_DATUM_THREAD: 105 | this->thread = d.thread; 106 | break; 107 | } 108 | } 109 | 110 | QzDatum &QzDatum::operator=(const QzDatum &d) { 111 | this->type = d.type; 112 | switch (d.type) { 113 | case QZ_DATUM_INT: 114 | this->int_ = d.int_; 115 | break; 116 | case QZ_DATUM_FLOAT: 117 | this->float_ = d.float_; 118 | break; 119 | case QZ_DATUM_SYMBOL: 120 | this->symbol = d.symbol; 121 | break; 122 | case QZ_DATUM_STRING: 123 | this->string = d.string; 124 | break; 125 | case QZ_DATUM_FUNCTION_POINTER: 126 | this->function = d.function; 127 | break; 128 | case QZ_DATUM_THREAD: 129 | this->thread = d.thread; 130 | break; 131 | } 132 | } 133 | 134 | QzDatum::~QzDatum() { 135 | switch (this->type) { 136 | case QZ_DATUM_STRING: 137 | this->string.~shared_ptr(); 138 | break; 139 | case QZ_DATUM_FUNCTION_POINTER: 140 | this->function.~shared_ptr(); 141 | break; 142 | } 143 | } 144 | 145 | QzThread::QzThread(std::shared_ptr vm) { 146 | std::lock_guard lock(vm->vm_lock); 147 | 148 | this->type = QZ_THREAD_LOCAL; 149 | 150 | this->local.vm = vm; 151 | this->local.ctx = std::make_shared(vm->stack_size); 152 | this->local.mailbox = std::make_shared(); 153 | this->local.thread = std::make_shared(&qz_run_local, vm, this->local.ctx, this->local.mailbox); 154 | this->local.thread->detach(); 155 | 156 | this->thread_id = this->local.thread->get_id(); 157 | } 158 | 159 | std::shared_ptr QzThread::create(std::shared_ptr vm) { 160 | std::shared_ptr qt = std::make_shared(vm); 161 | 162 | std::lock_guard lock(vm->vm_lock); 163 | 164 | if (qt->type == QZ_THREAD_LOCAL) 165 | vm->thread_map[qt->thread_id] = qt; 166 | 167 | return qt; 168 | } 169 | 170 | void QzThread::kill() { 171 | std::lock_guard lock(this->local.vm->vm_lock); 172 | 173 | if (this->type == QZ_THREAD_LOCAL) 174 | this->local.vm->thread_map.erase(this->thread_id); 175 | this->pause(); 176 | } 177 | 178 | void QzThread::enqueue_msg(QzMessage m) { 179 | this->local.mailbox->mail_lock.lock(); 180 | if (this->type == QZ_THREAD_LOCAL) 181 | this->local.mailbox->message_queue.push(m); 182 | this->local.mailbox->mail_lock.unlock(); 183 | } 184 | 185 | void QzThread::clear_msg_queue() { 186 | this->local.mailbox->mail_lock.lock(); 187 | if (this->type == QZ_THREAD_LOCAL) 188 | this->local.mailbox = std::make_shared(); 189 | this->local.mailbox->mail_lock.unlock(); // Not strictly necessary 190 | } 191 | 192 | void QzThread::exec_function(std::string name) { // Assumes you already pushed the params 193 | std::lock_guard lock(this->local.vm->vm_lock); 194 | 195 | if (this->type == QZ_THREAD_LOCAL) { 196 | this->pause(); 197 | auto found = this->local.vm->function_table.find(name); 198 | if (found != this->local.vm->function_table.end()) { 199 | this->local.ctx->instr_ptr = found->second.program_ptr * sizeof(Instruction); 200 | } 201 | this->resume(); 202 | } 203 | } 204 | 205 | void QzThread::pause() { 206 | this->local.ctx->thread_running = false; 207 | } 208 | 209 | void QzThread::resume() { 210 | this->local.ctx->thread_running = true; 211 | } 212 | 213 | QzThread::~QzThread() { 214 | this->kill(); 215 | } 216 | 217 | } } 218 | -------------------------------------------------------------------------------- /src/ast.ml: -------------------------------------------------------------------------------- 1 | open Pos 2 | 3 | type ('a, 'b) static_maybe = 4 | | Just : 'a -> ('a, [> `Yes]) static_maybe 5 | | Nothing : ('a, [> `No]) static_maybe 6 | 7 | type ('a, 'b, 'c) static_either = 8 | | Right : 'b -> ('a, 'b, [> `Right]) static_either 9 | | Left : 'a -> ('a, 'b, [> `Left]) static_either 10 | 11 | type literal = 12 | | Number of (int * int) 13 | | Bool of bool 14 | | String of string 15 | 16 | type identifier = 17 | | Value of string 18 | | Qualify of string * identifier 19 | 20 | type ('is_typed, 'is_session) expr = 21 | { expr_desc : (('is_typed, 'is_session) expr_desc, 'is_typed session_desc, 'is_session) static_either 22 | ; expr_type : (Type.t, 'is_typed) static_maybe 23 | ; expr_pos : pos 24 | ; expr_src : string option 25 | } 26 | 27 | and ('is_typed, 'is_session) expr_desc = 28 | | ELiteral of literal 29 | | EIdent of identifier 30 | | ELet of string * ('is_typed, 'is_session) expr list * ('is_typed, 'is_session) expr list 31 | | ELam of string list * ('is_typed, 'is_session) expr list 32 | | EApp of ('is_typed, 'is_session) expr * ('is_typed, 'is_session) expr list 33 | | ECond of ('is_typed, 'is_session) expr * ('is_typed, 'is_session) expr list * ('is_typed, 'is_session) expr list 34 | | ESpawn of identifier * ('is_typed, 'is_session) expr list 35 | | ESession of ('is_typed, [`Left | `Right]) expr list 36 | 37 | and 'is_typed session_desc = 38 | | EClose 39 | | ELoop of ('is_typed, [`Left | `Right]) expr list option 40 | | ESend of identifier * string * ('is_typed, [`Left | `Right]) expr list * ('is_typed, [`Left | `Right]) expr list 41 | | EBranch of string * (string * string list * ('is_typed, [`Left | `Right]) expr list) list 42 | 43 | type 'is_typed stmt = 44 | { stmt_desc : 'is_typed stmt_desc 45 | ; stmt_type : (Type.t, 'is_typed) static_maybe 46 | ; stmt_pos : pos 47 | ; stmt_src : string option 48 | } 49 | 50 | and 'is_typed stmt_desc = 51 | | SRequire of identifier 52 | | SModule of string * 'is_typed stmt list 53 | | SFfi of string * Type.t * string 54 | | SLet of string * ('is_typed, [`Left]) expr list 55 | 56 | type 'is_typed ast = 57 | { ast_desc : 'is_typed stmt list 58 | ; ast_src : string option 59 | ; ast_pos : pos 60 | } 61 | 62 | let indent_string n str = 63 | String.make n ' ' ^ str 64 | 65 | let string_of_literal = function 66 | | Number (n1, n2) -> string_of_int n1 ^ "." ^ string_of_int n2 67 | | Bool b -> string_of_bool b 68 | | String s -> "\"" ^ s ^ "\"" 69 | 70 | let rec string_of_identifier = function 71 | | Value s -> s 72 | | Qualify (s, id) -> s ^ "." ^ string_of_identifier id 73 | 74 | let rec string_of_expr : type t s. ?indent:int -> (t, s) expr -> string 75 | = fun ?(indent=0) -> function 76 | | { expr_src = Some txt } -> txt 77 | | { expr_desc = Left desc } -> 78 | begin match desc with 79 | | ELiteral lit -> indent_string indent (string_of_literal lit) 80 | | EIdent id -> indent_string indent (string_of_identifier id) 81 | | ELet (name, body, context) -> 82 | indent_string indent ("let " ^ name ^ " =\n") ^ 83 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) body) ^ "\n" ^ 84 | indent_string indent "end\n" ^ 85 | String.concat "\n" (List.map (string_of_expr ~indent) context) 86 | | ELam (names, body) -> 87 | indent_string indent ("| " ^ String.concat ", " names ^ " |\n") ^ 88 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) body) ^ "\n" ^ 89 | indent_string indent "end" 90 | | EApp (f, args) -> 91 | indent_string indent (string_of_expr f ^ "(" ^ String.concat ", " (List.map string_of_expr args) ^ ")") 92 | | ECond (pred, t, f) -> 93 | indent_string indent ("if " ^ string_of_expr pred ^ " then\n") ^ 94 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) t) ^ "\n" ^ 95 | indent_string indent "else\n" ^ 96 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) f) ^ "\n" ^ 97 | indent_string indent "end" 98 | | ESpawn (id, args) -> 99 | indent_string indent (string_of_identifier id ^ "(" ^ String.concat ", " (List.map string_of_expr args) ^ ")") 100 | | ESession body -> 101 | indent_string indent "session\n" ^ 102 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) body) ^ "\n" ^ 103 | indent_string indent "end" 104 | end 105 | | { expr_desc = Right desc } -> 106 | begin match desc with 107 | | EClose -> indent_string indent "close" 108 | | ELoop (None) -> indent_string indent "loop" 109 | | ELoop (Some args) -> 110 | let args = String.concat ", " (List.map (string_of_expr ~indent) args) in 111 | indent_string indent ("loop(" ^ args ^ ")") 112 | | ESend (id, msg, args, context) -> 113 | indent_string indent (string_of_identifier id ^ "!" ^ msg ^ "(" ^ String.concat ", " (List.map string_of_expr args) ^ ")") ^ "\n" ^ 114 | String.concat "\n" (List.map (string_of_expr ~indent) context) 115 | | EBranch (id, branches) -> 116 | let string_of_branch (msg, args, body) = 117 | indent_string indent ("branch " ^ msg ^ "(" ^ String.concat ", " args ^ ") from " ^ id) ^ "\n" ^ 118 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) body) ^ "\n" ^ 119 | indent_string indent "end" in 120 | String.concat "\n" @@ List.map string_of_branch branches 121 | end 122 | 123 | let rec string_of_stmt ?(indent=0) = function 124 | | { stmt_src = Some txt } -> txt 125 | | { stmt_desc } -> 126 | begin match stmt_desc with 127 | | SRequire id -> indent_string indent ("open " ^ string_of_identifier id) 128 | | SModule (name, body) -> 129 | indent_string indent ("module " ^ name ^ "\n") ^ 130 | String.concat "\n" (List.map (string_of_stmt ~indent:(indent+2)) body) ^ "\n" ^ 131 | indent_string indent "end" 132 | | SLet (name, body) -> 133 | indent_string indent ("let " ^ name ^ " =\n") ^ 134 | String.concat "\n" (List.map (string_of_expr ~indent:(indent+2)) body) ^ "\n" ^ 135 | indent_string indent "end" 136 | | SFfi (name, t, erl_name) -> 137 | indent_string indent ("ffi " ^ name ^ " : " ^ Type.string_of_type t ^ " = " ^ erl_name) 138 | end 139 | 140 | let string_of_ast ?(indent=0) = function 141 | | { ast_src = Some txt } -> txt 142 | | { ast_desc } -> 143 | String.concat "\n" (List.map (string_of_stmt ~indent) ast_desc) 144 | -------------------------------------------------------------------------------- /src/emit.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Pos 3 | 4 | exception SyntaxError of string 5 | 6 | module Scope = Map.Make (String) 7 | 8 | type env = 9 | { module_name : string 10 | ; exports : (string * int) list 11 | ; scope : [ `Toplevel | `Local | `Ffi of string ] Scope.t 12 | ; session : string 13 | ; state : int 14 | } 15 | 16 | let make_env module_name = 17 | { module_name; exports = []; scope = Scope.empty; session = ""; state = 0 } 18 | 19 | let prefix_name env name = 20 | match Scope.find name env.scope with 21 | | `Toplevel -> 22 | let id = "quartz_" ^ name in 23 | begin match List.assoc name env.exports with 24 | | 0 -> id ^ "()" 25 | | n -> id 26 | | exception Not_found -> id 27 | end 28 | | `Local -> "Quartz_" ^ name 29 | | `Ffi erl_name -> erl_name 30 | | exception Not_found -> "quartz_" ^ name (* Symbol if no ID found? *) 31 | 32 | (* FIXME: Should check for arity 0 with imported symbols *) 33 | let rec prefix_identifier env id = 34 | let rec format_identifier = function 35 | | Value v -> "quartz_" ^ v 36 | | Qualify (mod1, Value v) -> mod1 ^ ":quartz_" ^ v 37 | | Qualify (mod1, Qualify (mod2, id)) -> format_identifier (Qualify (mod1 ^ "." ^ mod2, id)) in 38 | match id with 39 | | Value name -> prefix_name env name 40 | | id -> format_identifier id 41 | 42 | let rec name_and_arity = function 43 | | { stmt_desc = SLet (name, [{ expr_desc = Left (ELam (args, _)) }]) } -> (name, List.length args) 44 | | { stmt_desc = SLet (name, _::rest) } as s -> name_and_arity { s with stmt_desc = SLet (name, rest) } 45 | | { stmt_desc = SLet (name, _) } -> (name, 0) 46 | | { stmt_pos } -> raise @@ SyntaxError ("Invalid top-level declaration on " ^ string_of_pos stmt_pos) 47 | 48 | let is_session = function 49 | | [{ expr_desc = Left (ESession _) }] 50 | | [{ expr_desc = Left (ELam (_, [{ expr_desc = Left (ESession _) }])) }] -> true 51 | | _ -> false 52 | 53 | let rec emit_expr : type t s. env -> (t, s) expr -> (env * string) 54 | = fun env expr -> 55 | match expr.expr_desc with 56 | | Left desc -> 57 | begin match desc with 58 | | ELiteral (Number (n1, n2)) -> (env, string_of_int n1 ^ "." ^ string_of_int n2) 59 | | ELiteral (Bool b) -> (env, string_of_bool b) 60 | | ELiteral (String s) -> (env, "\"" ^ s ^ "\"") 61 | | EIdent id -> (env, prefix_identifier env id) 62 | | ELet (name, body, context) -> 63 | let env' = { env with scope = Scope.add name `Local env.scope 64 | ; session = if is_session body 65 | then name 66 | else env.session } in 67 | let txt = 68 | Printf.sprintf 69 | {erl| 70 | Quartz_%s = begin 71 | %s 72 | end%s 73 | %s 74 | |erl} 75 | name 76 | (emit_exprs env' body) 77 | (if context = [] then "" else ",") 78 | (emit_exprs env' context) in 79 | (env, txt) 80 | | ELam (names, body) -> 81 | let prefixed_names = List.map (fun s -> "Quartz_" ^ s) names in 82 | let env' = { env with scope = List.fold_right (fun name scope -> Scope.add name `Local scope) names env.scope } in 83 | let txt = 84 | Printf.sprintf 85 | {erl| 86 | fun(%s) -> 87 | %s 88 | end 89 | |erl} 90 | (String.concat "," prefixed_names) 91 | (emit_exprs env' body) in 92 | (env', txt) 93 | | EApp (fn, args) -> 94 | let txt = 95 | Printf.sprintf 96 | {erl|(%s)(%s)|erl} 97 | (snd @@ emit_expr env fn) 98 | (emit_exprs env args) in 99 | (env, txt) 100 | | ECond (pred, t, f) -> 101 | let txt = 102 | Printf.sprintf 103 | {erl| 104 | if 105 | %s -> %s; 106 | true -> %s 107 | end 108 | |erl} 109 | (snd @@ emit_expr env pred) 110 | (emit_exprs env t) 111 | (emit_exprs env f) in 112 | (env, txt) 113 | | ESpawn (id, args) -> 114 | (* FIXME: Support spawning sessions in other modules *) 115 | let prefixed = prefix_identifier env id in 116 | let txt = 117 | Printf.sprintf 118 | {erl| 119 | spawn(%s, %s, [%s]) 120 | |erl} 121 | env.module_name 122 | prefixed 123 | (emit_exprs env args) in 124 | (env, txt) 125 | | ESession body -> 126 | let txt = 127 | Printf.sprintf 128 | {erl| 129 | Loop = fun(Loop) -> 130 | %s 131 | end, 132 | Loop(Loop) 133 | |erl} 134 | (emit_exprs env body) in 135 | (env, txt) 136 | end 137 | | Right desc -> 138 | begin match desc with 139 | | EClose -> (env, "exit(normal)") 140 | | ELoop (None) -> (env, "Loop(Loop)") 141 | | ELoop (Some args) -> 142 | let fn = env.session in 143 | let txt = 144 | Printf.sprintf {erl|%s(%s)|erl} 145 | (prefix_name env fn) 146 | (emit_exprs env args) in 147 | (env, txt) 148 | | ESend (id, msg, args, context) -> 149 | let prefixed = prefix_identifier env id in 150 | let txt = 151 | Printf.sprintf 152 | {erl| 153 | %s!{quartz_%s, {%s}, self()}%s 154 | %s 155 | |erl} 156 | prefixed 157 | msg 158 | (emit_exprs env args) 159 | (if context = [] then "" else ",") 160 | (emit_exprs env context) in 161 | (env, txt) 162 | | EBranch (id, branches) -> 163 | begin match Scope.find id env.scope with 164 | | `Local -> 165 | let env' = { env with state = env.state + 1 } in 166 | let emit_branch (msg, names, body) = 167 | let env'' = { env' with scope = List.fold_right (fun name scope -> Scope.add name `Local scope) names env'.scope } in 168 | Printf.sprintf 169 | {erl| 170 | {quartz_%s, {%s}, Ignore_%s} -> 171 | %s 172 | |erl} 173 | msg 174 | (String.concat "," @@ List.map (fun name -> "Quartz_" ^ name) names) 175 | (string_of_int env.state) 176 | (emit_exprs env'' body) in 177 | let txt = 178 | Printf.sprintf 179 | {erl| 180 | receive 181 | %s 182 | end 183 | |erl} 184 | (String.concat ";\n" @@ List.map emit_branch branches) in 185 | (env', txt) 186 | | `Toplevel | `Ffi _ -> 187 | let env' = { env with scope = Scope.add id `Local env.scope } in 188 | let emit_branch (msg, names, body) = 189 | let env'' = { env' with scope = List.fold_right (fun name scope -> Scope.add name `Local scope) names env'.scope } in 190 | Printf.sprintf 191 | {erl| 192 | {quartz_%s, {%s}, Quartz_%s} -> 193 | %s 194 | |erl} 195 | msg 196 | (String.concat "," @@ List.map (fun name -> "Quartz_" ^ name) names) 197 | id 198 | (emit_exprs env'' body) in 199 | let txt = 200 | Printf.sprintf 201 | {erl| 202 | receive 203 | %s 204 | end 205 | |erl} 206 | (String.concat ";\n" @@ List.map emit_branch branches) in 207 | (env', txt) 208 | end 209 | end 210 | 211 | and emit_exprs : type t s. env -> (t, s) expr list -> string 212 | = fun env -> function 213 | | [] -> "" 214 | | [expr] -> snd (emit_expr env expr) 215 | | expr::exprs -> 216 | let (env', txt) = emit_expr env expr in 217 | txt ^ ",\n" ^ emit_exprs env' exprs 218 | 219 | let rec emit_stmt env stmt = 220 | match stmt.stmt_desc with 221 | | SRequire _ -> (env, "") 222 | | SModule (name, body) -> 223 | let env' = { env with module_name = name } in 224 | (env', emit_stmts env' body) 225 | | SLet (name, es) -> 226 | let (params, body, env) = 227 | let env' = { env with scope = Scope.add name `Toplevel env.scope } in 228 | match es with 229 | | [{ expr_desc = Left (ELam (names, body)) }] -> 230 | let prefixed_names = List.map (fun s -> "Quartz_" ^ s) names in 231 | let env'' = { env' with scope = List.fold_right (fun name scope -> Scope.add name `Local scope) names env'.scope 232 | ; session = if is_session body 233 | then name 234 | else env'.session } in 235 | (String.concat "," prefixed_names, emit_exprs env'' body, env') 236 | | es -> ("", emit_exprs env' es, env') in 237 | let txt = 238 | Printf.sprintf 239 | {erl| 240 | quartz_%s(%s) -> 241 | %s. 242 | |erl} 243 | name 244 | params 245 | body in 246 | (env, txt) 247 | | SFfi (name, _, erl_name) -> 248 | ({ env with scope = Scope.add name (`Ffi erl_name) env.scope }, "") 249 | 250 | and emit_stmts env = function 251 | | [] -> "" 252 | | stmt::stmts -> 253 | let (env', txt) = emit_stmt env stmt in 254 | txt ^ "\n" ^ emit_stmts env' stmts 255 | 256 | let emit env { ast_desc = ast } = 257 | let exports = 258 | let is_decl = function 259 | | { stmt_desc = SLet (_, _) } -> true 260 | | _ -> false in 261 | List.filter is_decl ast |> List.map name_and_arity in 262 | let env = { env with exports } in 263 | Printf.sprintf 264 | {erl| 265 | -module(%s). 266 | -export([%s]). 267 | 268 | %s 269 | |erl} 270 | env.module_name 271 | (exports |> List.map (fun (name, arity) -> "quartz_" ^ name ^ "/" ^ string_of_int arity) |> String.concat ",") 272 | (emit_stmts env ast) 273 | -------------------------------------------------------------------------------- /vm/src/qvm_interpreter.cpp: -------------------------------------------------------------------------------- 1 | #include "qvm_interpreter.h" 2 | 3 | #include "qvm_instrs.h" 4 | #include "qvm_types.h" 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #define PUSH(X) ctx->stack[ctx->stack_ptr++] = QzDatum(X) 12 | #define PUSH_RAW(X) ctx->stack[ctx->stack_ptr++] = X 13 | #define POP() ctx->stack[--ctx->stack_ptr] 14 | #define PEEK() ctx->stack[ctx->stack_ptr - 1] 15 | #define DEREF(X) ctx->stack[ctx->stack_ptr + X - 1] 16 | 17 | namespace qz { namespace vm { 18 | 19 | void qz_run_local(std::shared_ptr vm, 20 | std::shared_ptr ctx, 21 | std::shared_ptr msgs) { 22 | auto hash = std::hash{}; 23 | auto idHash = std::hash{}; 24 | while (true) { // NOTE: This doesn't actually take thread_id, messages into account 25 | while (!ctx->thread_running) 26 | std::this_thread::sleep_for(std::chrono::milliseconds(5)); // TODO: HACK: Should use concurrency primitives 27 | 28 | vm->vm_lock.lock(); 29 | auto instr = *((Instruction *) &vm->heap[ctx->instr_ptr]); // HACK: WARNING: INCREMENTS IP BY DEFAULT 30 | vm->vm_lock.unlock(); 31 | std::cout << "\tIP=" << ctx->instr_ptr << ", OP=" << instr.rator << std::endl; 32 | 33 | ctx->instr_ptr += sizeof(Instruction); 34 | 35 | switch(instr.rator) { 36 | case NOP: { 37 | break; 38 | } 39 | case PUSH: { 40 | if (!instr.rand1) break; 41 | switch (instr.rand1->type) { 42 | case ILiteral: 43 | PUSH(instr.rand1->int_); 44 | break; 45 | case FLiteral: 46 | PUSH(instr.rand1->float_); 47 | break; 48 | case String: 49 | PUSH(instr.rand1->string); 50 | break; 51 | case Symbol: 52 | PUSH(hash(*instr.rand1->symbol)); 53 | break; 54 | case FuncRef: 55 | vm->vm_lock.lock(); 56 | PUSH(std::make_shared(vm->function_table[*instr.rand1->funcref])); 57 | vm->vm_lock.unlock(); 58 | break; 59 | } 60 | break; 61 | } 62 | case POP: { 63 | if (!instr.rand1) ctx->stack_ptr--; 64 | if (instr.rand1->type != Symbol) break; 65 | auto tmp = POP(); 66 | if (tmp.type != QZ_DATUM_INT) break; 67 | if (*instr.rand1->symbol == "SP") 68 | ctx->stack_ptr = tmp.int_; 69 | else if (*instr.rand1->symbol == "FP") 70 | ctx->frame_ptr = tmp.int_; 71 | else if (*instr.rand1->symbol == "IP") 72 | ctx->instr_ptr = tmp.int_; 73 | break; 74 | } 75 | case ADD: { 76 | if (!instr.rand1) { 77 | auto tmp1 = POP(); 78 | auto tmp2 = POP(); 79 | if (tmp1.type == QZ_DATUM_INT && tmp2.type == QZ_DATUM_INT) { 80 | PUSH(tmp1.int_ + tmp2.int_); 81 | } else { 82 | PUSH(tmp1.float_ + tmp2.float_); 83 | } 84 | } else if (!instr.rand2) { 85 | auto tmp = POP(); 86 | if (instr.rand1->type == ILiteral) { 87 | PUSH(instr.rand1->int_ + tmp.int_); 88 | } else { 89 | PUSH(instr.rand1->float_ + tmp.float_); 90 | } 91 | } else { 92 | if (instr.rand1->type == ILiteral) { 93 | PUSH(instr.rand1->int_ + instr.rand2->int_); 94 | } else { 95 | PUSH(instr.rand1->float_ + instr.rand2->float_); 96 | } 97 | } 98 | break; 99 | } 100 | case SUB: { 101 | if (!instr.rand1) { 102 | auto tmp1 = POP(); 103 | auto tmp2 = POP(); 104 | if (tmp1.type == QZ_DATUM_INT && tmp2.type == QZ_DATUM_INT) { 105 | PUSH(tmp1.int_ - tmp2.int_); 106 | } else { 107 | PUSH(tmp1.float_ - tmp2.float_); 108 | } 109 | } else if (!instr.rand2) { 110 | auto tmp = POP(); 111 | if (instr.rand1->type == ILiteral) { 112 | PUSH(instr.rand1->int_ - tmp.int_); 113 | } else { 114 | PUSH(instr.rand1->float_ - tmp.float_); 115 | } 116 | } else { 117 | if (instr.rand1->type == ILiteral) { 118 | PUSH(instr.rand1->int_ - instr.rand2->int_); 119 | } else { 120 | PUSH(instr.rand1->float_ - instr.rand2->float_); 121 | } 122 | } 123 | break; 124 | } 125 | case MUL: { 126 | if (!instr.rand1) { 127 | auto tmp1 = POP(); 128 | auto tmp2 = POP(); 129 | if (tmp1.type == QZ_DATUM_INT && tmp2.type == QZ_DATUM_INT) { 130 | PUSH(tmp1.int_ * tmp2.int_); 131 | } else { 132 | PUSH(tmp1.float_ * tmp2.float_); 133 | } 134 | } else if (!instr.rand2) { 135 | auto tmp = POP(); 136 | if (instr.rand1->type == ILiteral) { 137 | PUSH(instr.rand1->int_ * tmp.int_); 138 | } else { 139 | PUSH(instr.rand1->float_ * tmp.float_); 140 | } 141 | } else { 142 | if (instr.rand1->type == ILiteral) { 143 | PUSH(instr.rand1->int_ * instr.rand2->int_); 144 | } else { 145 | PUSH(instr.rand1->float_ * instr.rand2->float_); 146 | } 147 | } 148 | break; 149 | } 150 | case DIV: { 151 | if (!instr.rand1) { 152 | auto tmp1 = POP(); 153 | auto tmp2 = POP(); 154 | if (tmp1.type == QZ_DATUM_INT && tmp2.type == QZ_DATUM_INT) { 155 | PUSH(tmp1.int_ / tmp2.int_); 156 | } else { 157 | PUSH(tmp1.float_ / tmp2.float_); 158 | } 159 | } else if (!instr.rand2) { 160 | auto tmp = POP(); 161 | if (instr.rand1->type == ILiteral) { 162 | PUSH(instr.rand1->int_ / tmp.int_); 163 | } else { 164 | PUSH(instr.rand1->float_ / tmp.float_); 165 | } 166 | } else { 167 | if (instr.rand1->type == ILiteral) { 168 | PUSH(instr.rand1->int_ / instr.rand2->int_); 169 | } else { 170 | PUSH(instr.rand1->float_ / instr.rand2->float_); 171 | } 172 | } 173 | break; 174 | } 175 | case MOD: { 176 | if (!instr.rand1) { 177 | auto tmp1 = POP(); 178 | auto tmp2 = POP(); 179 | PUSH(tmp1.int_ % tmp2.int_); 180 | } else if (!instr.rand2) { 181 | auto tmp = POP(); 182 | PUSH(instr.rand1->int_ % tmp.int_); 183 | } else { 184 | PUSH(instr.rand1->int_ % instr.rand2->int_); 185 | } 186 | break; 187 | } 188 | case AND: { 189 | if (!instr.rand1) { 190 | auto tmp1 = POP(); 191 | auto tmp2 = POP(); 192 | PUSH(tmp1.int_ & tmp2.int_); 193 | } else if (!instr.rand2) { 194 | auto tmp = POP(); 195 | PUSH(instr.rand1->int_ & tmp.int_); 196 | } else { 197 | PUSH(instr.rand1->int_ & instr.rand2->int_); 198 | } 199 | break; 200 | } 201 | case OR: { 202 | if (!instr.rand1) { 203 | auto tmp1 = POP(); 204 | auto tmp2 = POP(); 205 | PUSH(tmp1.int_ | tmp2.int_); 206 | } else if (!instr.rand2) { 207 | auto tmp = POP(); 208 | PUSH(instr.rand1->int_ | tmp.int_); 209 | } else { 210 | PUSH(instr.rand1->int_ | instr.rand2->int_); 211 | } 212 | break; 213 | } 214 | case XOR: { 215 | if (!instr.rand1) { 216 | auto tmp1 = POP(); 217 | auto tmp2 = POP(); 218 | PUSH(tmp1.int_ ^ tmp2.int_); 219 | } else if (!instr.rand2) { 220 | auto tmp = POP(); 221 | PUSH(instr.rand1->int_ ^ tmp.int_); 222 | } else { 223 | PUSH(instr.rand1->int_ ^ instr.rand2->int_); 224 | } 225 | break; 226 | } 227 | case NOT: { 228 | if (!instr.rand1) { 229 | PUSH(~POP().int_); 230 | } else { 231 | PUSH(~instr.rand1->int_); 232 | } 233 | break; 234 | } 235 | case DUP: { 236 | PUSH(PEEK()); 237 | break; 238 | } 239 | case SWAP: { 240 | auto tmp = PEEK(); 241 | DEREF(0) = DEREF(-1); 242 | DEREF(-1) = tmp; 243 | break; 244 | } 245 | case EXCHANGE: { 246 | auto tmp = DEREF(instr.rand1->stackref); 247 | DEREF(instr.rand1->stackref) = DEREF(instr.rand2->stackref); 248 | DEREF(instr.rand1->stackref) = tmp; 249 | break; 250 | } 251 | case CMP: { // TODO: ** Should ** allow for more than just int/float comparisons 252 | if (!instr.rand1) { 253 | auto tmp1 = POP(); 254 | auto tmp2 = POP(); 255 | if (tmp1.type == QZ_DATUM_INT && tmp2.type == QZ_DATUM_INT) { 256 | PUSH(tmp1.int_ - tmp2.int_); 257 | } else if (tmp1.type == QZ_DATUM_FLOAT && tmp2.type == QZ_DATUM_FLOAT) { 258 | PUSH(tmp1.float_ - tmp2.float_); 259 | } else if (tmp1.type == QZ_DATUM_SYMBOL && tmp2.type == QZ_DATUM_SYMBOL) { 260 | PUSH(tmp1.symbol - tmp2.symbol); 261 | } else if (tmp1.type == QZ_DATUM_STRING && tmp2.type == QZ_DATUM_STRING) { 262 | PUSH((std::int64_t) tmp1.string->compare(*tmp2.string)); 263 | } else if (tmp1.type == QZ_DATUM_THREAD && tmp2.type == QZ_DATUM_THREAD) { 264 | PUSH(idHash(tmp1.thread) - idHash(tmp2.thread)); 265 | } else { // QZ_DATUM_FUNCTION_POINTER, QZ_DATUM_INTERNAL, types not equal => false 266 | PUSH((std::int64_t) -1); 267 | } 268 | } else if (!instr.rand2) { 269 | auto tmp = POP(); 270 | if (instr.rand1->type == ILiteral && tmp.type == QZ_DATUM_INT) { 271 | PUSH(instr.rand1->int_ - tmp.int_); 272 | } else if (instr.rand1->type == FLiteral && tmp.type == QZ_DATUM_FLOAT) { 273 | PUSH(instr.rand1->float_ - tmp.float_); 274 | } else if (instr.rand1->type == String && tmp.type == QZ_DATUM_STRING) { 275 | PUSH((std::int64_t) instr.rand1->string->compare(*tmp.string)); 276 | } else if (instr.rand1->type == Symbol && tmp.type == QZ_DATUM_SYMBOL) { 277 | PUSH(hash(*instr.rand1->symbol) - tmp.symbol); 278 | } else if (instr.rand1->type == StackRef && tmp.type == QZ_DATUM_THREAD) { 279 | PUSH(idHash(DEREF(instr.rand1->stackref).thread) - idHash(tmp.thread)); 280 | } else { 281 | PUSH((std::int64_t) -1); 282 | } // QZ_DATUM_FUNCTION_POINTER, QZ_DATUM_INTERNAL, types not equal => false 283 | } else { 284 | if (instr.rand1->type == ILiteral) { 285 | PUSH(instr.rand1->int_ - instr.rand2->int_); 286 | } else if (instr.rand1->type == FLiteral) { 287 | PUSH(instr.rand1->float_ - instr.rand2->float_); 288 | } else if (instr.rand1->type == String) { 289 | PUSH((std::int64_t) instr.rand1->string->compare(*instr.rand2->string)); 290 | } else if (instr.rand1->type == Symbol) { 291 | PUSH(hash(*instr.rand1->symbol) - hash(*instr.rand2->symbol)); 292 | } else { // QZ_DATUM_FUNCTION_POINTER, QZ_DATUM_THREAD, types not equal => false 293 | PUSH((std::int64_t) -1); 294 | } 295 | } 296 | break; 297 | } 298 | case TCHECK: { 299 | switch (instr.rand1->type) { 300 | case ILiteral: 301 | if (hash(*instr.rand2->symbol) == hash("INT")) { 302 | PUSH((std::int64_t) 0); 303 | } else { 304 | PUSH((std::int64_t) -1); 305 | } 306 | break; 307 | case FLiteral: 308 | if (hash(*instr.rand2->symbol) == hash("FLOAT")) { 309 | PUSH((std::int64_t) 0); 310 | } else { 311 | PUSH((std::int64_t) -1); 312 | } 313 | break; 314 | case String: 315 | if (hash(*instr.rand2->symbol) == hash("STRING")) { 316 | PUSH((std::int64_t) 0); 317 | } else { 318 | PUSH((std::int64_t) -1); 319 | } 320 | break; 321 | case Symbol: 322 | if (hash(*instr.rand2->symbol) == hash("SYMBOL")) { 323 | PUSH((std::int64_t) 0); 324 | } else { 325 | PUSH((std::int64_t) -1); 326 | } 327 | break; 328 | case StackRef: { 329 | auto tmp = DEREF(instr.rand1->stackref); 330 | switch (tmp.type) { 331 | case QZ_DATUM_INT: 332 | if (hash(*instr.rand2->symbol) == hash("INT")) { 333 | PUSH((std::int64_t) 0); 334 | } else { 335 | PUSH((std::int64_t) -1); 336 | } 337 | break; 338 | case QZ_DATUM_FLOAT: 339 | if (hash(*instr.rand2->symbol) == hash("FLOAT")) { 340 | PUSH((std::int64_t) 0); 341 | } else { 342 | PUSH((std::int64_t) -1); 343 | } 344 | break; 345 | case QZ_DATUM_STRING: 346 | if (hash(*instr.rand2->symbol) == hash("STRING")) { 347 | PUSH((std::int64_t) 0); 348 | } else { 349 | PUSH((std::int64_t) -1); 350 | } 351 | break; 352 | case QZ_DATUM_SYMBOL: 353 | if (hash(*instr.rand2->symbol) == hash("SYMBOL")) { 354 | PUSH((std::int64_t) 0); 355 | } else { 356 | PUSH((std::int64_t) -1); 357 | } 358 | break; 359 | case QZ_DATUM_FUNCTION_POINTER: 360 | if (hash(*instr.rand2->symbol) == hash("FUNCTION")) { 361 | PUSH((std::int64_t) 0); 362 | } else { 363 | PUSH((std::int64_t) -1); 364 | } 365 | break; 366 | case QZ_DATUM_THREAD: 367 | if (hash(*instr.rand2->symbol) == hash("THREAD")) { 368 | PUSH((std::int64_t) 0); 369 | } else { 370 | PUSH((std::int64_t) -1); 371 | } 372 | break; 373 | case QZ_DATUM_INTERNAL: 374 | if (hash(*instr.rand2->symbol) == hash("INTERNAL")) { 375 | PUSH((std::int64_t) 0); 376 | } else { 377 | PUSH((std::int64_t) -1); 378 | } 379 | break; 380 | } 381 | break; 382 | } 383 | case FuncRef: 384 | if (hash(*instr.rand2->symbol) == hash("FUNCTION")) { 385 | PUSH((std::int64_t) 0); 386 | } else { 387 | PUSH((std::int64_t) -1); 388 | } 389 | break; 390 | } 391 | break; 392 | } 393 | case JEQ: { 394 | if (DEREF(0).int_ == 0) { 395 | ctx->instr_ptr = instr.rand1->int_; 396 | } 397 | break; 398 | } 399 | case JNE: { 400 | if (DEREF(0).int_ != 0) { 401 | ctx->instr_ptr = instr.rand1->int_; 402 | } 403 | break; 404 | } 405 | case JLT: { 406 | if (DEREF(0).int_ < 0) { 407 | ctx->instr_ptr = instr.rand1->int_; 408 | } 409 | break; 410 | } 411 | case JGT: { 412 | if (DEREF(0).int_ > 0) { 413 | ctx->instr_ptr = instr.rand1->int_; 414 | } 415 | break; 416 | } 417 | case JMP: { 418 | ctx->instr_ptr = instr.rand1->int_; 419 | break; 420 | } 421 | case CALL: { 422 | vm->vm_lock.lock(); 423 | auto fn = vm->function_table[*instr.rand1->funcref]; 424 | vm->vm_lock.unlock(); 425 | if (fn.lambda) { 426 | auto fn_lambda = *fn.lambda; 427 | fn_lambda(vm, ctx); 428 | } else { 429 | auto f_addr = fn.program_ptr * sizeof(Instruction); 430 | PUSH(ctx->frame_ptr); 431 | PUSH(ctx->instr_ptr); 432 | ctx->frame_ptr = ++ctx->stack_ptr; 433 | ctx->instr_ptr = f_addr; 434 | } 435 | break; 436 | } 437 | case RET: { 438 | if (!instr.rand1) { 439 | ctx->instr_ptr = ctx->stack[ctx->frame_ptr - 1].int_; 440 | ctx->stack_ptr = ctx->frame_ptr; 441 | POP(); // Pops old instr_ptr 442 | ctx->frame_ptr = POP().int_; 443 | } else { 444 | QzDatum d; 445 | switch (instr.rand1->type) { 446 | case ILiteral: 447 | d = QzDatum(instr.rand1->int_); 448 | break; 449 | case FLiteral: 450 | d = QzDatum(instr.rand1->float_); 451 | break; 452 | case String: 453 | d = QzDatum(instr.rand1->string); 454 | break; 455 | case Symbol: 456 | d = QzDatum(hash(*instr.rand1->symbol)); 457 | break; 458 | case StackRef: 459 | d = DEREF(instr.rand1->stackref); 460 | break; 461 | case FuncRef: 462 | vm->vm_lock.lock(); 463 | d = QzDatum(std::make_shared(vm->function_table[*instr.rand1->funcref])); 464 | vm->vm_lock.lock(); 465 | break; 466 | } 467 | ctx->instr_ptr = ctx->stack[ctx->frame_ptr - 1].int_; 468 | ctx->stack_ptr = ctx->frame_ptr; 469 | POP(); // Pops old instr_ptr 470 | ctx->frame_ptr = POP().int_; 471 | PUSH_RAW(d); 472 | } 473 | break; 474 | } 475 | case CONSTRUCT_ASYNC: { 476 | if (instr.rand1->type == FuncRef) { 477 | auto fn = instr.rand1->funcref; 478 | vm->vm_lock.lock(); 479 | auto thread = instr.rand2 ? vm->thread_map[DEREF(instr.rand2->stackref).thread] : vm->thread_map[POP().thread]; 480 | vm->vm_lock.lock(); 481 | thread->exec_function(*fn); 482 | thread->resume(); 483 | } else { 484 | auto param_count = instr.rand1->int_; 485 | auto fn = instr.rand2->funcref; 486 | vm->vm_lock.lock(); 487 | auto thread = instr.rand3 ? vm->thread_map[DEREF(instr.rand3->stackref).thread] : vm->thread_map[DEREF(param_count).thread]; 488 | vm->vm_lock.unlock(); 489 | if (thread->type == QZ_THREAD_LOCAL) { 490 | auto lctx = thread->local.ctx; 491 | for (auto i = 0; i < param_count; i++) { 492 | std::cout << "T[" << lctx->stack_ptr + 1 << "] <- [" << i - param_count << "]" << std::endl; 493 | lctx->stack[lctx->stack_ptr++] = DEREF(i - param_count); 494 | } 495 | } 496 | thread->exec_function(*fn); 497 | thread->resume(); 498 | } 499 | break; 500 | } 501 | case SPAWN_EMPTY: { 502 | auto thread = QzThread::create(vm); 503 | PUSH(thread->thread_id); 504 | break; 505 | } 506 | case AWAIT_MSG: { 507 | if (!instr.rand1) { 508 | msgs->mail_lock.lock(); 509 | while (msgs->message_queue.empty()) { 510 | std::this_thread::sleep_for(std::chrono::milliseconds(5)); // TODO: HACK: Should use concurrency primitives 511 | } 512 | PUSH(msgs->message_queue.front().message_symbol); 513 | msgs->message_queue.pop(); 514 | msgs->mail_lock.unlock(); 515 | } else if (instr.rand1->type == StackRef) { 516 | } else if (instr.rand1->type == ILiteral) { 517 | if (!instr.rand2) { 518 | } else if (instr.rand2->type == StackRef) { 519 | } 520 | } 521 | break; 522 | } 523 | case CLOSE: { 524 | return; 525 | } 526 | case CLOSE_ERR: { 527 | throw instr.rand1->string; 528 | } 529 | } 530 | } 531 | } 532 | 533 | } } 534 | -------------------------------------------------------------------------------- /global-synthesis/cfsm.ml: -------------------------------------------------------------------------------- 1 | type state = int 2 | 3 | type participant = string 4 | 5 | type channel = participant * participant 6 | 7 | type message = string 8 | 9 | type action = Send of channel * message | Recv of channel * message 10 | 11 | let string_of_action = function 12 | | Send ((p, p'), m) -> p ^ "→" ^ p' ^ ":" ^ m 13 | | Recv ((p, p'), m) -> p' ^ "→" ^ p ^ ":" ^ m 14 | 15 | let subj = function 16 | | Send ((p, q), m) -> p 17 | | Recv ((p, q), m) -> q 18 | 19 | type ty = string 20 | 21 | module rec GMsgSet : Set.S with type elt = message * Global.global = Set.Make(struct 22 | type t = message * Global.global 23 | let compare (m1, _) (m2, _) = 24 | String.compare m1 m2 25 | end) 26 | 27 | and Global : sig 28 | type global = 29 | | GMsg of participant * participant * GMsgSet.t 30 | | GMIP of participant * participant * message * GMsgSet.t (* Message In Progress *) 31 | | GRec of ty * global 32 | | GType of ty 33 | | GEnd 34 | end = Global 35 | 36 | include Global 37 | 38 | let global_of_msg i msgs = 39 | GMsgSet.find (i, GEnd) msgs |> snd 40 | 41 | let rec string_of_global = function 42 | | GMsg (p, p', msgs) -> 43 | p ^ "→" ^ p' ^ ":{" ^ fmt_global_msgs msgs ^ "}" 44 | | GMIP (p, p', j, msgs) -> 45 | p ^ "⇝" ^ p' ^ ":" ^ j ^ "{" ^ fmt_global_msgs msgs ^ "}" 46 | | GRec (ty, g) -> 47 | "μ" ^ ty ^ "." ^ string_of_global g 48 | | GType ty -> ty 49 | | GEnd -> "end" 50 | 51 | (* Lazy coding *) 52 | and fmt_global_msgs set = match GMsgSet.elements set with 53 | | [] -> "" 54 | | [(m, g)] -> m ^ "." ^ string_of_global g 55 | | (m, g)::xs -> m ^ "." ^ string_of_global g ^ ", " ^ fmt_global_msgs (GMsgSet.of_list xs) 56 | 57 | let rec gsubst ~target ~replace = function 58 | | GMsg (p, p', msgs) -> GMsg (p, p', GMsgSet.map (fun (m, g) -> (m, gsubst ~target ~replace g)) msgs) 59 | | GMIP (p, p', j, msgs) -> GMIP (p, p', j, GMsgSet.map (fun (m, g) -> (m, gsubst ~target ~replace g)) msgs) 60 | | GRec (t, g) -> GRec (t, gsubst ~target ~replace g) 61 | | GType t when t = target -> replace 62 | | g -> g 63 | 64 | module rec MsgSet : Set.S with type elt = message * Local.local = Set.Make(struct 65 | type t = message * Local.local 66 | let compare (m1, _) (m2, _) = 67 | String.compare m1 m2 68 | end) 69 | 70 | and Local : sig 71 | type local = 72 | | LRecv of participant * MsgSet.t 73 | | LSend of participant * MsgSet.t 74 | | LRec of ty * local 75 | | LType of ty 76 | | LEnd 77 | end = Local 78 | 79 | include Local 80 | 81 | let local_of_msg i msgs = 82 | MsgSet.find (i, LEnd) msgs |> snd 83 | 84 | let rec string_of_local = function 85 | | LSend (p, msgs) -> 86 | p ^ "!{" ^ fmt_local_msgs msgs ^ "}" 87 | | LRecv (p, msgs) -> 88 | p ^ "?{" ^ fmt_local_msgs msgs ^ "}" 89 | | LRec (ty, g) -> 90 | "μ" ^ ty ^ "." ^ string_of_local g 91 | | LType ty -> ty 92 | | LEnd -> "end" 93 | 94 | and fmt_local_msgs set = match MsgSet.elements set with 95 | | [] -> "" 96 | | [(m, g)] -> m ^ "." ^ string_of_local g 97 | | (m, g)::xs -> m ^ "." ^ string_of_local g ^ ", " ^ fmt_local_msgs (MsgSet.of_list xs) 98 | 99 | let rec lsubst ~target ~replace = function 100 | | LSend (p, msgs) -> LSend (p, MsgSet.map (fun (m, l) -> (m, lsubst ~target ~replace l)) msgs) 101 | | LRecv (p, msgs) -> LRecv (p, MsgSet.map (fun (m, l) -> (m, lsubst ~target ~replace l)) msgs) 102 | | LRec (t, l) -> LRec (t, lsubst ~target ~replace l) 103 | | LType t when t = target -> replace 104 | | l -> l 105 | 106 | let rec mergeable l1 l2 = 107 | match (l1, l2) with 108 | | LRecv (p1, m1), LRecv (p2, m2) when p1 = p2 -> 109 | let k = m1 and j = m2 in 110 | let si = MsgSet.inter k j in 111 | MsgSet.for_all (fun (i, _) -> mergeable (local_of_msg i m1) (local_of_msg i m2)) si 112 | && 113 | let kj = MsgSet.diff k j and jk = MsgSet.diff j k in 114 | MsgSet.for_all (fun (k, _) -> 115 | MsgSet.for_all (fun (j, _) -> 116 | j <> k 117 | ) jk 118 | ) kj 119 | | LSend (p1, m1), LSend (p2, m2) when p1 = p2 -> 120 | let k = m1 and j = m2 in 121 | let si = MsgSet.inter k j in 122 | MsgSet.for_all (fun (i, _) -> mergeable (local_of_msg i m1) (local_of_msg i m2)) si 123 | && 124 | let kj = MsgSet.diff k j and jk = MsgSet.diff j k in 125 | MsgSet.for_all (fun (k, _) -> 126 | MsgSet.for_all (fun (j, _) -> 127 | j <> k 128 | ) jk 129 | ) kj 130 | | _ -> false 131 | 132 | let rec merge t1 t2 = 133 | match (t1, t2) with 134 | | LRecv (p1, m1), LRecv (p2, m2) when p1 = p2 -> 135 | let k = m1 and j = m2 in 136 | let i = MsgSet.inter k j in 137 | let merged = MsgSet.map (fun (m, _) -> (m, merge (local_of_msg m m1) (local_of_msg m m2))) i 138 | and kj = MsgSet.diff k j and jk = MsgSet.diff j k in 139 | LRecv (p1, MsgSet.union merged (MsgSet.union kj jk)) 140 | | LSend (p1, m1), LSend (p2, m2) when p1 = p2 -> 141 | let k = m1 and j = m2 in 142 | let i = MsgSet.inter k j in 143 | let merged = MsgSet.map (fun (m, _) -> (m, merge (local_of_msg m m1) (local_of_msg m m2))) i 144 | and kj = MsgSet.diff k j and jk = MsgSet.diff j k in 145 | LSend (p1, MsgSet.union merged (MsgSet.union kj jk)) 146 | | _ -> failwith @@ "Can't merge unmergeable local types: type " ^ string_of_local t1 ^ " is incompatible with type " ^ string_of_local t2 147 | 148 | let rec project global q = match global with 149 | | GMsg (p, p', msgs) when q = p -> 150 | LSend (p', project_msgs msgs q) 151 | | GMsg (p, p', msgs) when q = p' -> 152 | LRecv (p, project_msgs msgs q) 153 | | GMsg (p, p', msgs) -> 154 | let lmsgs = GMsgSet.elements msgs in 155 | begin match List.map (fun (_, g) -> project g q) lmsgs with 156 | | x::xs -> List.fold_left merge x xs 157 | | [] -> LEnd 158 | end 159 | | GRec (t, g) when project g q <> LType t -> 160 | LRec (t, project g q) 161 | | GRec (t, g) -> LEnd 162 | | GType t -> LType t 163 | | GEnd -> LEnd 164 | | GMIP (_, _, _, _) -> failwith "Cannot project a message-in-progress" 165 | 166 | and project_msgs msgs q = 167 | let lmsgs = GMsgSet.elements msgs in 168 | List.map (fun (m, g) -> (m, project g q)) lmsgs |> MsgSet.of_list 169 | 170 | let eg_commit = 171 | let global = 172 | GRec ("t", GMsg ("A", "B", GMsgSet.of_list [ 173 | "act", GMsg ("B", "C", GMsgSet.of_list [ 174 | "sig", GMsg ("A", "C", GMsgSet.of_list [ 175 | "commit", GType "t" 176 | ]) 177 | ]); 178 | "quit", GMsg ("B", "C", GMsgSet.of_list [ 179 | "save", GMsg ("A", "C", GMsgSet.of_list [ 180 | "finish", GEnd 181 | ]) 182 | ]) 183 | ])) in 184 | let local_c = project global "C" 185 | and local_c_expected = 186 | LRec ("t", LRecv ("B", MsgSet.of_list [ 187 | "sig", LRecv ("A", MsgSet.of_list [ 188 | "commit", LType "t" 189 | ]); 190 | "save", LRecv ("A", MsgSet.of_list [ 191 | "finish", LEnd 192 | ]) 193 | ])) in 194 | match local_c = local_c_expected with 195 | | true -> print_endline "[PASSED] Project" 196 | | false -> print_endline "[FAILED] Project"; 197 | print_endline ("When projecting " ^ string_of_global global); 198 | print_endline ("Got " ^ string_of_local local_c); 199 | print_endline ("Expected " ^ string_of_local local_c_expected) 200 | 201 | let rec advance_glts glts l = match (glts, l) with 202 | | GMsg (p, p', msgs), Send ((q, q'), m) 203 | when GMsgSet.mem (m, GEnd) msgs && p = q && p' = q' -> 204 | GMIP (p, p', m, msgs) 205 | | GMIP (p, p', j, msgs), Recv ((q, q'), m) 206 | when j = m && p = q && p' = q' -> 207 | global_of_msg j msgs 208 | | GRec (t, g), l -> 209 | advance_glts (gsubst ~target:t ~replace:(GRec (t, g)) g) l 210 | | GMsg (p, p', msgs), l -> GMsg (p, p', GMsgSet.map (fun (m, g) -> (m, advance_glts g l)) msgs) 211 | | GMIP (p, p', j, msgs), l -> GMIP (p, p', j, GMsgSet.map (fun (m, g) -> (m, advance_glts g l)) msgs) 212 | | glts, t -> glts 213 | 214 | let glts_test = 215 | let g1 = GMsg ("A", "B", GMsgSet.of_list [ 216 | "a", GMsg ("A", "C", GMsgSet.of_list [ 217 | "b", GEnd 218 | ]) 219 | ]) 220 | and l1 = Send (("A", "B"), "a") 221 | and l2 = Recv (("A", "B"), "a") 222 | and l3 = Send (("A", "C"), "b") 223 | and l4 = Recv (("A", "C"), "b") in 224 | let r1 = 225 | advance_glts (advance_glts (advance_glts (advance_glts g1 l1) l2) l3) l4 226 | and r2 = 227 | advance_glts (advance_glts (advance_glts (advance_glts g1 l1) l3) l2) l4 228 | and r3 = 229 | advance_glts (advance_glts (advance_glts (advance_glts g1 l1) l3) l4) l2 in 230 | match (r1, r2, r3) with 231 | | GEnd, GEnd, GEnd -> print_endline "[PASSED] GLTS Test" 232 | | r1, r2, r3 -> print_endline "[FAILED] GLTS Test" 233 | 234 | let rec advance_llts llts l = match (llts, l) with 235 | | LSend (q, msgs), Send ((_, q'), a) 236 | when MsgSet.mem (a, LEnd) msgs && q = q' -> 237 | local_of_msg a msgs 238 | | LRecv (q, msgs), Recv ((q', _), a) 239 | when MsgSet.mem (a, LEnd) msgs && q = q' -> 240 | local_of_msg a msgs 241 | | LRec (t, local), l -> 242 | advance_llts (lsubst ~target:t ~replace:(LRec (t, local)) local) l 243 | | LSend (q, msgs), l -> 244 | LSend (q, MsgSet.map (fun (m, ll) -> (m, advance_llts ll l)) msgs) 245 | | LRecv (q, msgs), l -> 246 | LRecv (q, MsgSet.map (fun (m, ll) -> (m, advance_llts ll l)) msgs) 247 | | llts, l -> llts 248 | 249 | type configuration = local list * message list 250 | 251 | (* Def'n 3.4 252 | advance_configuration c l = 253 | match l with 254 | | pq!a -> 255 | let t'p' = map (if [not p] advance_llts t l) tp 256 | and w'p'q' = map (if [not p] w ++ [a]) wpq in 257 | (t'p', w'p'q') 258 | | pq?a -> 259 | let t'p' = map (if [not p] advance_llts t l) tp 260 | and w'p'q' = map (if [not p && not q] a::w) wpq in 261 | (t'p', w'p'q') 262 | *) 263 | 264 | type transition = local * action * local 265 | 266 | let string_of_transition (l1, a, l2) = 267 | string_of_local l1 ^ "--[" ^ string_of_action a ^ "]-->" ^ string_of_local l2 268 | 269 | type cfsm = { 270 | (* Set of states *) 271 | q : local list; 272 | (* Set of channels: (p1, p2) | p1 <> p2 *) 273 | c : channel list; 274 | (* Initial state *) 275 | q0 : local; 276 | (* Set of messages *) 277 | a : message list; 278 | (* Set of transitions *) 279 | d : transition list 280 | } 281 | 282 | let string_of_cfsm cfsm = 283 | let q = "q = " ^ String.concat ",\n " (List.map string_of_local cfsm.q) 284 | and c = "c = " ^ String.concat ",\n " (List.map (fun (a, b) -> "(" ^ a ^ ", " ^ b ^ ")") cfsm.c) 285 | and q0 = "q0 = " ^ string_of_local cfsm.q0 286 | and a = "a = " ^ String.concat ",\n " cfsm.a 287 | and d = "d = " ^ String.concat ",\n " (List.map string_of_transition cfsm.d) in 288 | q ^ "\n" ^ c ^ "\n" ^ q0 ^ "\n" ^ a ^ "\n" ^ d 289 | 290 | let state_kind cfsm state = 291 | let transitions = 292 | List.filter (fun (a, x, b) -> a = state) cfsm.d in 293 | let rec identify kind = function 294 | | [] -> kind 295 | | (_, Send (_, _), _)::xs when kind = `Receiving -> 296 | `Mixed 297 | | (_, Send (_, _), _)::xs -> 298 | identify `Sending xs 299 | | (_, Recv (_, _), _)::xs when kind = `Sending -> 300 | `Mixed 301 | | (_, Recv (_, _), _)::xs -> 302 | identify `Receiving xs in 303 | identify `Final transitions 304 | 305 | let rec collect_local_types ?(lst=[]) = function 306 | | LSend (_, msgs) | LRecv (_, msgs) -> 307 | let ts = MsgSet.elements msgs |> List.map snd in 308 | List.fold_left (fun lst t -> collect_local_types ~lst t) (ts @ lst) ts 309 | | LRec (t, l) -> collect_local_types ~lst:(l::lst) l 310 | | LType ty -> lst 311 | | LEnd -> LEnd::lst 312 | 313 | module StringSet = Set.Make(String) 314 | 315 | let rec collect_participants ?(s=StringSet.empty) = function 316 | | GMsg (p, q, msgs) | GMIP (p, q, _, msgs) -> 317 | let s' = StringSet.(add p (add q s)) in 318 | let lmsgs = GMsgSet.elements msgs in 319 | List.fold_left (fun s (_, g) -> collect_participants ~s g) s' lmsgs 320 | | GRec (_, g) -> collect_participants ~s g 321 | | _ -> s 322 | 323 | let rec collect_messages ?(s=StringSet.empty) = function 324 | | GMsg (_, _, msgs) | GMIP (_, _, _, msgs) -> 325 | let lmsgs = GMsgSet.elements msgs in 326 | List.fold_left (fun s (m, t) -> collect_messages ~s:(StringSet.add m s) t) s lmsgs 327 | | GRec (_, g) -> collect_messages ~s g 328 | | _ -> s 329 | 330 | let rec combinations = function 331 | | [] -> [] 332 | | h::t -> 333 | let headed = List.map (fun t -> (h, t)) t 334 | and unheaded = combinations t in 335 | headed @ unheaded 336 | 337 | module BindingMap = Map.Make(struct 338 | type t = ty 339 | let compare = compare 340 | end) 341 | 342 | let rec collect_local_bindings ?(m=BindingMap.empty) = function 343 | | LSend (_, msgs) | LRecv (_, msgs) -> 344 | let lmsgs = MsgSet.elements msgs in 345 | List.fold_left (fun m (_, l) -> collect_local_bindings ~m l) m lmsgs 346 | | LRec (t, l) -> 347 | let m' = BindingMap.add t l m in 348 | collect_local_bindings ~m:m' l 349 | | LType _ -> m 350 | | LEnd -> m 351 | 352 | module TransitionSet = Set.Make(struct 353 | type t = transition 354 | let compare = compare 355 | end) 356 | 357 | let rec collect_transitions ?(s=TransitionSet.empty) local_bindings p = 358 | let get_t' = function 359 | | LType t when BindingMap.mem t local_bindings -> 360 | BindingMap.find t local_bindings 361 | | t -> t in 362 | function 363 | | LSend (q, msgs) as t -> 364 | let s' = MsgSet.fold (fun (a, t') s -> TransitionSet.add (t, Send ((p, q), a), get_t' t') s) msgs s in 365 | let lmsgs = MsgSet.elements msgs in 366 | List.fold_left (fun s (_, l) -> collect_transitions ~s local_bindings p l) s' lmsgs 367 | | LRecv (q, msgs) as t -> 368 | let s' = MsgSet.fold (fun (a, t') s -> TransitionSet.add (t, Recv ((p, q), a), get_t' t') s) msgs s in 369 | let lmsgs = MsgSet.elements msgs in 370 | List.fold_left (fun s (_, l) -> collect_transitions ~s local_bindings p l) s' lmsgs 371 | | LRec (_, t) -> collect_transitions ~s local_bindings p t 372 | | LType _ -> s 373 | | LEnd -> s 374 | 375 | let cfsm_of_projection g p = 376 | let t0 = project g p in 377 | let q = collect_local_types t0 378 | and c = combinations (StringSet.elements (collect_participants g)) 379 | and q0 = match t0 with 380 | | LRec (t, l) -> l 381 | | l -> l 382 | and a = StringSet.elements (collect_messages g) 383 | and d = TransitionSet.elements (collect_transitions (collect_local_bindings t0) p t0) in 384 | { q; c; q0; a; d } 385 | 386 | (* Def'n 3.6: Translation from a basic CFSM to a local type 387 | let local_of_cfsm mp = 388 | let t v q = (* Loop through participant, { !, ? }, etc. for t *) 389 | let sends = 390 | List.filter (function (t, Send (_, _), _) when r = q -> true 391 | | _ -> false) mp.d 392 | |> List.map (fun (t, Send ((p, p'), aj), tj) -> aj, tj) 393 | and recvs = 394 | List.filter (function (t, Recv (_, _), _) when r = q -> true 395 | | _ -> false) mp.d in 396 | match sends, recvs with 397 | | (_::_) as s, [] -> 398 | | [], (_::_) as r -> 399 | and t' v q = 400 | t [] mp.q0 401 | *) 402 | 403 | let cfsm_test = 404 | let g = 405 | GRec ("t", GMsg ("a", "b", GMsgSet.of_list [ 406 | "Hello", GMsg ("b", "c", GMsgSet.of_list [ 407 | "Start", GMsg ("c", "a", GMsgSet.of_list [ 408 | "Hello", GEnd 409 | ]) 410 | ]); 411 | "Ping", GMsg ("b", "c", GMsgSet.of_list [ 412 | "Pong", GType "t" 413 | ]) 414 | ])) 415 | and p = "a" in 416 | let cfsm_expected = 417 | { q = [] 418 | ; c = List.sort compare [ ("a", "b"); ("a", "c"); ("b", "c") ] 419 | ; q0 = LSend ("b", MsgSet.of_list [ 420 | "Hello", LRecv ("c", MsgSet.of_list [ 421 | "Hello", LEnd 422 | ]) 423 | ]) 424 | ; a = List.sort compare [ "Hello"; "Ping"; "Pong"; "Start" ] 425 | ; d = [] 426 | } 427 | and cfsm = cfsm_of_projection g p in 428 | print_endline (string_of_cfsm cfsm); 429 | match cfsm.q = cfsm_expected.q 430 | , cfsm.c = cfsm_expected.c 431 | , cfsm.q0 = cfsm_expected.q0 432 | , cfsm.a = cfsm_expected.a 433 | , cfsm.d = cfsm_expected.d with 434 | | _, true, true, true, _ -> print_endline "[PASSED] CFSM Test" 435 | | _ -> print_endline "[FAILED] CFSM Test" 436 | 437 | (* Def'n 3.6: Translation from a basic CFSM to a local type ... *) 438 | 439 | let rec binary_compatible = function 440 | | LRec (t, l) -> LRec (t, binary_compatible l) 441 | | LSend (p, msgs) -> LRecv (p, MsgSet.map (fun (a, t) -> (a, binary_compatible t)) msgs) 442 | | LRecv (p, msgs) -> LSend (p, MsgSet.map (fun (a, t) -> (a, binary_compatible t)) msgs) 443 | | LType t -> LType t 444 | | LEnd -> LEnd 445 | 446 | (* Global transition *) 447 | type gtransition = local list * action * local list 448 | 449 | let string_of_gtransition (gs, a, gs') = 450 | let string_of_locals ls = 451 | "(" ^ String.concat ", " (List.map string_of_local ls) ^ ")" in 452 | string_of_locals gs ^ "--[" ^ string_of_action a ^ "]-->" ^ string_of_locals gs' 453 | 454 | type gcfsm = { (* Global CFSM *) 455 | (* Set of states *) 456 | gq : local list; 457 | (* Set of channels: (p1, p2) | p1 <> p2 *) 458 | gc : channel list; 459 | (* Initial states *) 460 | gq0 : local list; 461 | (* Set of messages *) 462 | ga : message list; 463 | (* Set of transitions *) 464 | gd : gtransition list 465 | } 466 | 467 | let string_of_gcfsm gcfsm = 468 | let q = "q = " ^ String.concat ",\n " (List.map string_of_local gcfsm.gq) 469 | and c = "c = " ^ String.concat ",\n " (List.map (fun (a, b) -> "(" ^ a ^ ", " ^ b ^ ")") gcfsm.gc) 470 | and q0 = "q0 = " ^ String.concat ",\n " (List.map string_of_local gcfsm.gq0) 471 | and a = "a = " ^ String.concat ",\n " gcfsm.ga 472 | and d = "d = " ^ String.concat ",\n " (List.map string_of_gtransition gcfsm.gd) in 473 | q ^ "\n" ^ c ^ "\n" ^ q0 ^ "\n" ^ a ^ "\n" ^ d 474 | 475 | (* Def'n 4.1 476 | Merges cfsms into a gcfsm. 477 | Assumes that each cfsm has been set up with a proper label. 478 | *) 479 | let merge_cfsms cfsms = 480 | let ds = List.map (fun {d} -> d) cfsms |> List.concat 481 | and q0s = List.map (fun {q0} -> q0) cfsms in 482 | (* FIXME: follow_states will not trace states in the correct global order *) 483 | let rec follow_states qs lst = function 484 | | [] -> lst 485 | | (q, l, q')::states -> 486 | let qs' = List.map (function p when p = q -> q' | p -> p) qs in 487 | follow_states qs' ((qs, l, qs')::lst) states in 488 | { gq = List.fold_left (fun l {q} -> q @ l) [] cfsms 489 | (* FIXME: should be a set *) 490 | ; gc = List.map (fun {c} -> c) cfsms |> List.concat 491 | ; gq0 = q0s 492 | (* FIXME: should be a set *) 493 | ; ga = List.map (fun {a} -> a) cfsms |> List.concat 494 | ; gd = follow_states q0s [] ds 495 | } 496 | 497 | let gcfsm_test = 498 | let g = 499 | GRec ("t", GMsg ("a", "b", GMsgSet.of_list [ 500 | "Hello", GMsg ("b", "c", GMsgSet.of_list [ 501 | "Start", GMsg ("c", "a", GMsgSet.of_list [ 502 | "Hello", GEnd 503 | ]) 504 | ]); 505 | "Ping", GMsg ("b", "c", GMsgSet.of_list [ 506 | "Pong", GType "t" 507 | ]) 508 | ])) in 509 | let cfsm_a = cfsm_of_projection g "a" 510 | and cfsm_b = cfsm_of_projection g "b" 511 | and cfsm_c = cfsm_of_projection g "c" in 512 | let gcfsm = merge_cfsms [cfsm_a; cfsm_b; cfsm_c] in 513 | print_endline (string_of_gcfsm gcfsm) 514 | 515 | (* Pre-synth: 516 | - Take communicating system S, such that forall p in S, exists q in S, s.t. pq!a or pq?a 517 | - q : ((participant, id) list, local) where id = global name of session 518 | - Assign to each qn some unique identifier Un 519 | - Replace all instances referencing participantn/idn in each q with Un 520 | let synth qs = 521 | let pairs = StringMap.bindings qs |> combinations in 522 | let rec loop = function 523 | | [] -> StringMap.bindings qs |> List.map (fun (n, _) -> GType n) 524 | | ((pn, LSend (qn', qmsgs)), (qn, LRecv (pn', pmsgs)))::pqs when pn = pn' && qn = qn' -> 525 | | ((pn, LRecv (qn', qmsgs)), (qn, LSend (pn', pmsgs)))::pqs when pn = pn' && qn = qn' -> *) 526 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | --------------------------------------------------------------------------------