├── test ├── mbcheck.ml ├── dune ├── pat-tests │ ├── arith.pat │ ├── arith1.pat │ ├── functions.pat │ ├── arith2.pat │ ├── atoms.pat │ ├── let-annot-1.pat │ ├── let-annot-2.pat │ ├── let-annot-3.pat │ ├── n-tuples.pat │ ├── n-tuples-bad-1.pat │ ├── n-tuples-bad-2.pat │ ├── linfun-bad-2.pat │ ├── linfun-bad-3.pat │ ├── linfun-bad-1.pat │ ├── mb-function-return.pat │ ├── n-tuples-2.pat │ ├── linfun-good.pat │ ├── sum-2.pat │ └── sum-1.pat ├── examples │ ├── pair-ir-shadowing.pat │ ├── pair_unr_1.pat │ ├── pair_unr_2.pat │ ├── pat_constr.pat │ ├── products.pat │ ├── interfaces.pat │ ├── de_liguoro_padovani │ │ ├── future.pat │ │ ├── futurefail.pat │ │ ├── future_state_passing.pat │ │ ├── lock.pat │ │ ├── account.pat │ │ ├── sessions.pat │ │ ├── account_future.pat │ │ └── master_worker.pat │ ├── savina │ │ ├── kfork.pat │ │ ├── fib.pat │ │ ├── fib_pairs.pat │ │ ├── ping_pong_strict.pat │ │ ├── ping_pong.pat │ │ ├── count.pat │ │ ├── thread_ring.pat │ │ ├── philosopher.pat │ │ ├── cig_smok.pat │ │ ├── big.pat │ │ ├── log_map.pat │ │ └── banking.pat │ └── robotsn.pat ├── errors │ ├── unbound.pat │ ├── pat_constr.pat │ ├── useafterfree.pat │ ├── pat_constr2.pat │ ├── pat_constr4.pat │ ├── uaf1.pat │ ├── uaf2.pat │ ├── pat_constr3.pat │ ├── uaf3.pat │ ├── simple_alias_comm.pat │ ├── lock.pat │ ├── future.pat │ ├── alias_comm2.pat │ └── alias_comm1.pat ├── mklist.py ├── run-tests.py └── tests.json ├── lib ├── util │ ├── maps.ml │ ├── dune │ └── utility.ml ├── typecheck │ ├── solver_result.ml │ ├── pretypecheck.mli │ ├── dune │ ├── interface_env.mli │ ├── nullable_env.mli │ ├── interface_env.ml │ ├── constraint.ml │ ├── constraint.mli │ ├── nullable_env.ml │ ├── gen_constraints.mli │ ├── constraint_set.ml │ ├── ty_env.mli │ ├── presburger.ml │ ├── z3_solver.ml │ └── type_utils.ml ├── frontend │ ├── sugar_to_ir.mli │ ├── insert_pattern_variables.mli │ ├── pipeline.mli │ ├── dune │ ├── benchmark.ml │ ├── pipeline.ml │ ├── desugar_let_annotations.ml │ ├── parse.ml │ ├── desugar_sugared_guards.ml │ ├── insert_pattern_variables.ml │ └── lexer.mll ├── dune ├── mbcheck.ml └── common │ ├── dune │ ├── settings.mli │ ├── settings.ml │ ├── interface.ml │ ├── lib_types.ml │ ├── common_types.ml │ ├── pretype.ml │ ├── errors.ml │ ├── source_code.ml │ ├── sugar_ast.ml │ └── ir.ml ├── vim ├── ftplugin │ └── lmb.vim ├── ftdetect │ └── lmb.vim ├── indent │ └── lmb.vim └── syntax │ └── lmb.vim ├── bin ├── dune └── main.ml ├── .gitignore ├── Makefile ├── dune-project ├── dune ├── mbcheck.opam ├── .github └── workflows │ └── default.yml ├── generate-table.py ├── run-paper-examples.py ├── ARTIFACT.md └── README.md /test/mbcheck.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /lib/util/maps.ml: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name mbcheck)) 3 | -------------------------------------------------------------------------------- /test/pat-tests/arith.pat: -------------------------------------------------------------------------------- 1 | (1 + 2) == 3 2 | -------------------------------------------------------------------------------- /test/pat-tests/arith1.pat: -------------------------------------------------------------------------------- 1 | (1 + 2 * 3) == 7 2 | -------------------------------------------------------------------------------- /vim/ftplugin/lmb.vim: -------------------------------------------------------------------------------- 1 | setlocal commentstring=#\ %s 2 | -------------------------------------------------------------------------------- /test/pat-tests/functions.pat: -------------------------------------------------------------------------------- 1 | (fun (x: Int): Int { x })(5) 2 | -------------------------------------------------------------------------------- /vim/ftdetect/lmb.vim: -------------------------------------------------------------------------------- 1 | au BufRead,BufNewFile *.lmb set ft=lmb 2 | -------------------------------------------------------------------------------- /test/pat-tests/arith2.pat: -------------------------------------------------------------------------------- 1 | (1 + 2 * 3) == 7 && (1 + 2 * 3) == 9 2 | -------------------------------------------------------------------------------- /lib/util/dune: -------------------------------------------------------------------------------- 1 | (library (name util) 2 | (public_name mbcheck.util) 3 | ) 4 | -------------------------------------------------------------------------------- /lib/typecheck/solver_result.ml: -------------------------------------------------------------------------------- 1 | type t = | Satisfiable | Unsatisfiable | Unknown 2 | -------------------------------------------------------------------------------- /test/examples/pair-ir-shadowing.pat: -------------------------------------------------------------------------------- 1 | let x = 5 in 2 | (let x = true in x, x) 3 | -------------------------------------------------------------------------------- /test/pat-tests/atoms.pat: -------------------------------------------------------------------------------- 1 | def foo(): Atom { 2 | :hello 3 | } 4 | 5 | foo() 6 | -------------------------------------------------------------------------------- /lib/frontend/sugar_to_ir.mli: -------------------------------------------------------------------------------- 1 | val transform : Common.Sugar_ast.program -> Common.Ir.program 2 | -------------------------------------------------------------------------------- /test/examples/pair_unr_1.pat: -------------------------------------------------------------------------------- 1 | def synth_bad(): Unit { 2 | let (x, y) = ((), ()) in 3 | x 4 | } 5 | -------------------------------------------------------------------------------- /lib/typecheck/pretypecheck.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | val check : Ir.program -> Ir.program * Pretype.t option 3 | -------------------------------------------------------------------------------- /test/pat-tests/let-annot-1.pat: -------------------------------------------------------------------------------- 1 | def main(): Int { 2 | let x: Int = 5 in x + x 3 | } 4 | 5 | main() 6 | -------------------------------------------------------------------------------- /lib/frontend/insert_pattern_variables.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | val annotate : Sugar_ast.program -> Sugar_ast.program 3 | -------------------------------------------------------------------------------- /test/pat-tests/let-annot-2.pat: -------------------------------------------------------------------------------- 1 | def main(): Int { 2 | let x: Int = 5 + 5 in 3 | x 4 | } 5 | 6 | main() 7 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mbcheck) 3 | (public_name mbcheck) 4 | (libraries common frontend typecheck util) 5 | ) 6 | -------------------------------------------------------------------------------- /lib/mbcheck.ml: -------------------------------------------------------------------------------- 1 | module Common = Common 2 | module Frontend = Frontend 3 | module Typecheck = Typecheck 4 | module Util = Util 5 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name mbcheck) 3 | (name main) 4 | (modes byte exe) 5 | (libraries common frontend cmdliner)) 6 | -------------------------------------------------------------------------------- /test/pat-tests/let-annot-3.pat: -------------------------------------------------------------------------------- 1 | def main(): Int { 2 | let x: Int = 3 | let y = 5 in y 4 | in x + x 5 | } 6 | 7 | main() 8 | -------------------------------------------------------------------------------- /test/pat-tests/n-tuples.pat: -------------------------------------------------------------------------------- 1 | def main(): (Bool * Int * String) { 2 | let (x, y, z) = (1, "hello", true) in 3 | (z, x, y) 4 | } 5 | main() 6 | -------------------------------------------------------------------------------- /test/examples/pair_unr_2.pat: -------------------------------------------------------------------------------- 1 | interface MyMailbox1 { } 2 | 3 | def synth_bad2(z: MyMailbox1![R]): Unit { 4 | let (x, y) = ((), z) in 5 | x 6 | } 7 | -------------------------------------------------------------------------------- /test/pat-tests/n-tuples-bad-1.pat: -------------------------------------------------------------------------------- 1 | def main(): (Bool * Int * String) { 2 | let (x, y) = (1, "hello", true) in 3 | (true, x, y) 4 | } 5 | main() 6 | -------------------------------------------------------------------------------- /test/pat-tests/n-tuples-bad-2.pat: -------------------------------------------------------------------------------- 1 | def main(): (Bool * Int * String) { 2 | let (x, y, z) = (1, "hello", true) in 3 | (x, y, z) 4 | } 5 | main() 6 | -------------------------------------------------------------------------------- /test/pat-tests/linfun-bad-2.pat: -------------------------------------------------------------------------------- 1 | interface Dummy { } 2 | def main(): Unit { 3 | let mb = new[Dummy] in 4 | let f = fun(): Unit { free(mb) } in 5 | () 6 | } 7 | -------------------------------------------------------------------------------- /test/pat-tests/linfun-bad-3.pat: -------------------------------------------------------------------------------- 1 | interface Dummy { } 2 | def main(): Unit { 3 | let mb = new[Dummy] in 4 | let f = linfun(): Unit { free(mb) } in 5 | () 6 | } 7 | -------------------------------------------------------------------------------- /test/pat-tests/linfun-bad-1.pat: -------------------------------------------------------------------------------- 1 | interface Dummy { } 2 | def main(): Unit { 3 | let mb = new[Dummy] in 4 | let f = linfun(x: Dummy?): Unit { free(x) } in 5 | () 6 | } 7 | -------------------------------------------------------------------------------- /test/pat-tests/mb-function-return.pat: -------------------------------------------------------------------------------- 1 | interface Test { } 2 | 3 | def main(): Unit { 4 | let f = fun(x: Test?): Test? { x } in 5 | free(f(new[Test])) 6 | } 7 | 8 | main() 9 | -------------------------------------------------------------------------------- /test/pat-tests/n-tuples-2.pat: -------------------------------------------------------------------------------- 1 | def main(): ((Bool * Int) * String) { 2 | let (x, z) = ((1, "hello"), true) in 3 | let (x1, x2) = x in 4 | ((z, x1), x2) 5 | } 6 | main() 7 | -------------------------------------------------------------------------------- /test/pat-tests/linfun-good.pat: -------------------------------------------------------------------------------- 1 | interface Dummy { } 2 | def main(): Unit { 3 | let mb = new[Dummy] in 4 | let f = linfun(): Unit { free(mb) } in 5 | f() 6 | } 7 | main() 8 | -------------------------------------------------------------------------------- /vim/indent/lmb.vim: -------------------------------------------------------------------------------- 1 | if exists("b:did_indent") 2 | finish 3 | endif 4 | let b:did_indent = 1 5 | 6 | setlocal indentexpr= 7 | 8 | setlocal cindent 9 | setlocal cinkeys-=0# 10 | -------------------------------------------------------------------------------- /test/errors/unbound.pat: -------------------------------------------------------------------------------- 1 | interface Dummy { Message(Int) } 2 | 3 | def future(self: Dummy?): Unit { 4 | guard self : Message { 5 | receive Put(x) from self -> xfdjosijf + 1 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /test/errors/pat_constr.pat: -------------------------------------------------------------------------------- 1 | interface Test { Foo(), Bar() } 2 | 3 | def foo(x: Test?): Unit { 4 | guard x : Foo { 5 | receive Foo() from x -> free(x); () 6 | receive Bar() from x -> free(x); () 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /test/pat-tests/sum-2.pat: -------------------------------------------------------------------------------- 1 | def main(): Unit { 2 | let x : (Int + Bool) = inl(5) in 3 | case x of { 4 | inl(x): Int -> print(intToString(x)) 5 | | inr(y): Bool -> print("right branch") 6 | } 7 | } 8 | 9 | main() 10 | -------------------------------------------------------------------------------- /lib/frontend/pipeline.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | open Typecheck 3 | 4 | val pipeline : Sugar_ast.program -> 5 | Sugar_ast.program * 6 | Pretype.t option * 7 | Ir.program * 8 | Type.t * 9 | Ty_env.t * 10 | Constraint_set.t 11 | -------------------------------------------------------------------------------- /test/pat-tests/sum-1.pat: -------------------------------------------------------------------------------- 1 | def main(): Unit { 2 | let x = (inl(5) : (Int + Bool)) in 3 | case x of { 4 | inl(x): Int -> print(intToString(x)) 5 | | inr(y): Bool -> print("right branch") 6 | } 7 | } 8 | 9 | main() 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | auto/ 2 | _build/ 3 | mbcheck 4 | */_build/ 5 | */mbcheck/_build/ 6 | *.aux 7 | *.bbl 8 | *.blg 9 | *.fdb_latexmk 10 | *.fls 11 | *.log 12 | *.out 13 | *.pag 14 | *.pdf 15 | *.cpt 16 | *.synctex.gz 17 | *.tmp 18 | *.DS_Store 19 | /.idea 20 | /.history 21 | -------------------------------------------------------------------------------- /test/errors/useafterfree.pat: -------------------------------------------------------------------------------- 1 | interface Test { M(Int), N(String) } 2 | 3 | def main(): Unit { 4 | let a = new[Test] in 5 | guard a : N { 6 | receive N(x) from a -> free(a) 7 | }; 8 | a ! N("Hello") 9 | } 10 | 11 | 12 | (main() : Unit) 13 | -------------------------------------------------------------------------------- /test/errors/pat_constr2.pat: -------------------------------------------------------------------------------- 1 | # Shows the necessity of the explicit check that an annotation is a subtype of 2 | # the inferred pattern in TC-Guard 3 | 4 | interface Test { Foo(), Bar() } 5 | 6 | def foo(x: Test?): Unit { 7 | guard x : Foo + Bar { 8 | receive Foo() from x -> free(x); () 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /test/errors/pat_constr4.pat: -------------------------------------------------------------------------------- 1 | # Shows the necessity of the explicit check that an annotation is a subtype of 2 | # the inferred pattern in TC-Guard 3 | 4 | interface Test { Foo(), Bar() } 5 | 6 | def foo(x: Test?): Unit { 7 | guard x : Foo { 8 | free -> () 9 | receive Foo() from x -> free(x) 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /lib/typecheck/dune: -------------------------------------------------------------------------------- 1 | (library (name typecheck) 2 | (public_name mbcheck.typecheck) 3 | (preprocess ( pps visitors.ppx ppx_deriving.show)) 4 | (libraries common util bag z3) 5 | (modules :standard) 6 | ;(rule 7 | ;(targets parser.mli parser.ml) 8 | ; (deps parser.mly) 9 | ; (action (ignore-stderr (run menhir --external-tokens Json --explain ${<})))) 10 | ) 11 | -------------------------------------------------------------------------------- /test/errors/uaf1.pat: -------------------------------------------------------------------------------- 1 | interface UAF { Message(Unit) } 2 | 3 | def go(x : UAF?) : Unit { 4 | guard x : Message* { 5 | free -> x ! Message(()) 6 | receive Message(z) from y -> 7 | go(y) 8 | } 9 | } 10 | 11 | 12 | def main(): Unit { 13 | let x = new[UAF] in 14 | spawn { x ! Message(())}; 15 | go(x) 16 | } 17 | 18 | (main() : Unit) 19 | -------------------------------------------------------------------------------- /lib/typecheck/interface_env.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | open Common.Source_code 3 | type t 4 | 5 | val lookup : Common_types.interface_name -> t -> Position.t list -> Interface.t WithPos.t 6 | val bind : Common_types.interface_name -> Interface.t WithPos.t -> t -> t 7 | val bind_many : (Common_types.interface_name * Interface.t WithPos.t) list -> t -> t 8 | val from_list : (Interface.t WithPos.t) list -> t 9 | -------------------------------------------------------------------------------- /lib/common/dune: -------------------------------------------------------------------------------- 1 | (library (name common) 2 | (public_name mbcheck.common) 3 | (libraries util) 4 | (preprocess ( staged_pps ppx_import visitors.ppx ppx_deriving.show)) 5 | ; w17: Virtual method unimplemented, incompatible with fold visitor 6 | ; w34: Unused type declarations (visitors) 7 | (flags (:standard -w -7 -w -17 -w -34)) 8 | ; Don't want to bother with IR just yet 9 | (modules :standard) 10 | ) 11 | -------------------------------------------------------------------------------- /test/errors/uaf2.pat: -------------------------------------------------------------------------------- 1 | interface UAF { Message(Unit) } 2 | 3 | def go(x : UAF?) : Unit { 4 | let a = x in 5 | guard x : (1 + Message*) { 6 | free -> a ! Message(()) 7 | receive Message(z) from y -> 8 | a ! Message(()); 9 | go(y) 10 | } 11 | } 12 | 13 | 14 | def main(): Unit { 15 | let x = new[UAF] in 16 | x ! Message(()); 17 | go(x) 18 | } 19 | 20 | (main() : Unit) 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | @if dune build; then\ 3 | ln -sf _build/default/bin/main.exe mbcheck;\ 4 | fi 5 | 6 | .PHONY: test 7 | test: 8 | cd test && python3 run-tests.py 9 | 10 | .PHONY: pin 11 | pin: 12 | opam pin add . --kind=path -y 13 | 14 | .PHONY: install 15 | install: 16 | opam reinstall mbcheck 17 | 18 | .PHONY: uninstall 19 | uninstall: 20 | opam remove mbcheck 21 | 22 | .PHONY: clean 23 | clean: 24 | dune clean 25 | rm -f mbcheck 26 | -------------------------------------------------------------------------------- /test/errors/pat_constr3.pat: -------------------------------------------------------------------------------- 1 | # Shows the necessity of the explicit check that an annotation is a subtype of 2 | # the inferred pattern in TC-Guard 3 | 4 | interface Test { Foo(), Bar(), Baz() } 5 | 6 | def foo(x: Test?): Unit { 7 | guard x : Foo { 8 | receive Foo() from x -> free(x); () 9 | receive Bar() from x -> 10 | guard x : Baz { 11 | receive Baz() from x -> free(x) 12 | } 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/errors/uaf3.pat: -------------------------------------------------------------------------------- 1 | interface UAF { Message(Unit) } 2 | 3 | def go(x : UAF?) : Unit { 4 | let a : Unit = 5 | guard x : Message* { 6 | free -> x ! Message(()) 7 | receive Message(z) from y -> 8 | y ! Message(()); 9 | go(y) 10 | } 11 | in 12 | x ! Message(()) 13 | } 14 | 15 | 16 | def main(): Unit { 17 | let x = new[UAF] in 18 | go(x) 19 | } 20 | 21 | (main() : Unit) 22 | -------------------------------------------------------------------------------- /test/examples/pat_constr.pat: -------------------------------------------------------------------------------- 1 | # Shows the necessity of the explicit check that an annotation is a subtype of 2 | # the inferred pattern in TC-Guard 3 | 4 | interface Test { Foo(), Bar() } 5 | 6 | def foo(x: Test?): Unit { 7 | guard x : Foo { 8 | receive Foo() from x -> free(x); () 9 | receive Bar() from x -> free(x); () 10 | } 11 | } 12 | 13 | def main(): Unit { 14 | let mb = new[Test] in 15 | spawn { foo(mb) }; 16 | mb ! Foo() 17 | } 18 | 19 | main() 20 | -------------------------------------------------------------------------------- /test/mklist.py: -------------------------------------------------------------------------------- 1 | import json 2 | 3 | xs = [ 4 | "future.lmb", 5 | "lock.lmb", 6 | "pat_constr.lmb", 7 | "pat_constr2.lmb", 8 | "pat_constr3.lmb", 9 | "pat_constr4.lmb", 10 | "unbound.lmb", 11 | "useafterfree.lmb", 12 | "weird.lmb", 13 | "weird2.lmb", 14 | "weird3.lmb", 15 | "weird4.lmb", 16 | ] 17 | 18 | def entry(x): 19 | return json.dumps({"name": "", "filename": x, "exit_code": 1}) 20 | 21 | print("\n".join([entry(x) for x in xs])) 22 | 23 | -------------------------------------------------------------------------------- /lib/typecheck/nullable_env.mli: -------------------------------------------------------------------------------- 1 | (* Operations on nullable type environments. 2 | A small wrapper over type environments. 3 | We only need to support intersection between two nullable environments, 4 | and disjoint combination with a defined environment. 5 | *) 6 | open Common.Source_code 7 | 8 | type t 9 | val intersect : t -> t -> Position.t -> (t * Constraint_set.t) 10 | val combine : Interface_env.t -> Ty_env.t -> t -> Position.t -> (Ty_env.t * Constraint_set.t) 11 | val of_env : Ty_env.t -> t 12 | val null : t 13 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name mbcheck) 3 | (using menhir 2.1) 4 | 5 | (generate_opam_files true) 6 | (authors "Simon Fowler") 7 | (maintainers "will add later") 8 | (homepage "will add later") 9 | (bug_reports "will add later") 10 | 11 | (package 12 | (name mbcheck) 13 | (synopsis "Implementation of a typechecker for a programming language based on the mailbox calculus") 14 | (depends 15 | (dune (>= 2.8)) 16 | (ocaml (>= 4.14.0)) 17 | cmdliner 18 | visitors 19 | ppx_import 20 | z3 21 | menhir 22 | bag 23 | )) 24 | -------------------------------------------------------------------------------- /lib/frontend/dune: -------------------------------------------------------------------------------- 1 | (ocamllex 2 | (modules lexer)) 3 | (menhir 4 | (modules parser) 5 | (flags "--table") ;; slower parser, but compilation *much* faster 6 | ) 7 | (library (name frontend) 8 | (public_name mbcheck.frontend) 9 | (preprocess ( staged_pps ppx_import visitors.ppx ppx_deriving.show)) 10 | (libraries common util typecheck menhirLib) 11 | (modules :standard) 12 | ;(rule 13 | ;(targets parser.mli parser.ml) 14 | ; (deps parser.mly) 15 | ; (action (ignore-stderr (run menhir --external-tokens Json --explain ${<})))) 16 | ) 17 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | ; w7: Overridden method (can't see how to do 'ancestors' in visitors without this off) 2 | ; w17: Virtual method unimplemented, incompatible with fold visitor 3 | ; w21: non-returning statement 4 | ; w33: Unused open -- silly during dev 5 | ; w34: Unused type 6 | ; w39: Unused rec vlag 7 | ; w26, w27, w32: Unused variable name -- will want eventually but not yet 8 | (env 9 | (dev 10 | ; (flags (:standard -w -7-17-32-33-27-26-34-39)) 11 | ; (flags (:standard -g -w -7-17-21-33-34-39)) 12 | (flags (:standard -g -w -7-17)) 13 | ) 14 | ) 15 | -------------------------------------------------------------------------------- /lib/common/settings.mli: -------------------------------------------------------------------------------- 1 | type 'a setting 2 | 3 | 4 | module ReceiveTypingStrategy : sig 5 | type t = Strict | Interface | Nothing 6 | val enum : (string * t) list 7 | end 8 | 9 | val verbose : bool setting 10 | val debug : bool setting 11 | val benchmark : int setting 12 | val receive_typing_strategy : ReceiveTypingStrategy.t setting 13 | val disable_quasilinearity : bool setting 14 | val join_not_combine : bool setting 15 | 16 | val set : 'a setting -> 'a -> unit 17 | val get : 'a setting -> 'a 18 | 19 | val if_verbose : (unit -> unit) -> unit 20 | val if_debug : (unit -> unit) -> unit 21 | -------------------------------------------------------------------------------- /test/errors/simple_alias_comm.pat: -------------------------------------------------------------------------------- 1 | interface Self { Msg(Other!) } 2 | interface Other { Reply() } 3 | 4 | def interprocess(self: Self?, other1: Other!): Unit { 5 | guard self : Msg { 6 | receive Msg(other2) from self -> 7 | other1 ! Reply(); 8 | free(self) 9 | } 10 | } 11 | 12 | def main(): Unit { 13 | let self = new[Self] in 14 | let other = new[Other] in 15 | spawn { interprocess(self, other) }; 16 | self ! Msg(other); 17 | guard other : Reply { 18 | receive Reply() from other -> 19 | free(other) 20 | } 21 | } 22 | 23 | main() 24 | -------------------------------------------------------------------------------- /lib/typecheck/interface_env.ml: -------------------------------------------------------------------------------- 1 | open Util.Utility 2 | open Common 3 | open Common.Source_code 4 | 5 | type t = (Interface.t WithPos.t) StringMap.t 6 | 7 | let lookup x (env: t) pos_list = 8 | match StringMap.find_opt x env with 9 | | Some x -> x 10 | | None -> raise (Errors.type_error ("No such interface " ^ x) pos_list) 11 | 12 | let bind = StringMap.add 13 | 14 | let bind_many = 15 | List.fold_right (fun (v, prety) acc -> 16 | StringMap.add v prety acc) 17 | 18 | let from_list (xs : (Interface.t WithPos.t) list) : t = 19 | let xs = List.map (fun x -> (Interface.name (WithPos.node x), x)) xs in 20 | bind_many xs StringMap.empty 21 | -------------------------------------------------------------------------------- /lib/typecheck/constraint.ml: -------------------------------------------------------------------------------- 1 | (* A constraint is a language inclusion relation between two patterns. *) 2 | open Common 3 | open Type 4 | 5 | type t = (Pattern.t * Pattern.t) 6 | 7 | exception Trap of string 8 | 9 | let make p1 p2 = p1, p2 10 | 11 | let lhs = fst 12 | let rhs = snd 13 | 14 | let is_upper_bound = 15 | let open Pattern in 16 | function 17 | | (_, PatVar _) -> true 18 | | _ -> false 19 | 20 | let is_lower_bound (_, p2) = Pattern.defined p2 21 | 22 | (* Use default comparison function to allow set equality *) 23 | let compare = compare 24 | 25 | let pp ppf (p1, p2) = 26 | Format.(fprintf ppf "%a ⊑ %a" 27 | Pattern.pp p1 28 | Pattern.pp p2) 29 | -------------------------------------------------------------------------------- /lib/frontend/benchmark.ml: -------------------------------------------------------------------------------- 1 | (* Utility functions used for benchmarking. *) 2 | 3 | let time f = 4 | let start = Unix.gettimeofday () in 5 | let fxy = f () in 6 | let ms = (Unix.gettimeofday () -. start) *. 1000.0 in 7 | (ms, fxy) 8 | 9 | let rec repeat n acc_ms f = 10 | if n <= 0 then ( 11 | acc_ms 12 | ) 13 | else ( 14 | let (ms, _) = time f in 15 | (* Print.printf "Run #%d complete in %.2fms.\n" n ms; *) 16 | (* flush stdout; *) 17 | repeat (n - 1) (acc_ms +. ms) f 18 | ) 19 | 20 | let benchmark n f = 21 | (* Printf.printf "Starting benchmark with %d run(s)..\n" n; *) 22 | flush stdout; 23 | let total_ms = repeat n 0.0 f in 24 | Printf.printf "%.2f" (total_ms /. (float_of_int n)) 25 | -------------------------------------------------------------------------------- /mbcheck.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "Implementation of a typechecker for a programming language based on the mailbox calculus" 5 | maintainer: ["will add later"] 6 | authors: ["Simon Fowler"] 7 | homepage: "will add later" 8 | bug-reports: "will add later" 9 | depends: [ 10 | "dune" {>= "2.8" & >= "2.8"} 11 | "ocaml" {>= "4.14.0"} 12 | "cmdliner" 13 | "visitors" 14 | "ppx_import" 15 | "z3" 16 | "menhir" 17 | "bag" 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | -------------------------------------------------------------------------------- /lib/common/settings.ml: -------------------------------------------------------------------------------- 1 | type 'a setting = 'a ref 2 | 3 | module ReceiveTypingStrategy = struct 4 | type t = Strict | Interface | Nothing 5 | 6 | let enum = [("strict", Strict); 7 | ("interface", Interface); 8 | ("none", Nothing)] 9 | end 10 | 11 | let verbose = ref false 12 | let debug = ref false 13 | let benchmark = ref (-1) 14 | let receive_typing_strategy = ref ReceiveTypingStrategy.Interface 15 | let disable_quasilinearity = ref false 16 | let join_not_combine = ref false 17 | 18 | let set : 'a setting -> 'a -> unit = fun setting value -> 19 | setting := value 20 | 21 | let get : 'a setting -> 'a = fun setting -> !setting 22 | 23 | let if_verbose f = 24 | if get verbose then f () else () 25 | 26 | let if_debug f = 27 | if get debug then f () else () 28 | -------------------------------------------------------------------------------- /lib/typecheck/constraint.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | type t 4 | 5 | exception Trap of string 6 | 7 | (** Constructs a constraint from two patterns *) 8 | val make : Type.Pattern.t -> Type.Pattern.t -> t 9 | 10 | (** Gets left-hand-side of the constraint *) 11 | val lhs : t -> Type.Pattern.t 12 | 13 | (** Gets right-hand-side of the constraint *) 14 | val rhs : t -> Type.Pattern.t 15 | 16 | (** Returns 'true' if the constraint is an upper bound 17 | (i.e., is of the form `pat1 <= pat2` where pat2 contains no pattern variables) *) 18 | val is_upper_bound : t -> bool 19 | 20 | (** Returns 'true' if the constraint is a lower bound 21 | (i.e., is of the form `pat1 <= pvar`) *) 22 | val is_lower_bound : t -> bool 23 | 24 | (** Compares two constraints *) 25 | val compare : t -> t -> int 26 | 27 | (** Pretty-print *) 28 | val pp : Format.formatter -> t -> unit 29 | -------------------------------------------------------------------------------- /lib/typecheck/nullable_env.ml: -------------------------------------------------------------------------------- 1 | (* Operations on nullable type environments. 2 | A small wrapper over type environments. 3 | We only need to support intersection between two nullable environments, 4 | and disjoint combination with a defined environment. 5 | *) 6 | type t = Ty_env.t option 7 | 8 | let intersect nenv1 nenv2 pos = 9 | match nenv1, nenv2 with 10 | | None, None -> None, Constraint_set.empty 11 | | Some env, None | None, Some env -> Some env, Constraint_set.empty 12 | | Some env1, Some env2 -> 13 | let env, constrs = Ty_env.intersect env1 env2 pos in 14 | Some env, constrs 15 | 16 | let combine ienv env1 nenv pos = 17 | match nenv with 18 | | Some env2 -> Ty_env.combine ienv env1 env2 pos 19 | | _ -> env1, Constraint_set.empty 20 | 21 | let of_env env = Some env 22 | let null = None 23 | -------------------------------------------------------------------------------- /test/examples/products.pat: -------------------------------------------------------------------------------- 1 | interface Test { Arg(Int) } 2 | 3 | def nested(mb: Test?): Unit { 4 | guard mb : Arg . Arg { 5 | receive Arg(x) from mb1 -> 6 | guard mb1 : Arg { 7 | receive Arg(y) from mb2 -> 8 | free(mb2); print(intToString(x + y)) 9 | } 10 | } 11 | } 12 | 13 | def pairs(mb: Test?): Unit { 14 | let (x, mb1) = 15 | guard mb : Arg . Arg { 16 | receive Arg(x) from mb1 -> (x, mb1) 17 | } 18 | in 19 | guard mb1 : Arg { 20 | receive Arg(y) from mb2 -> 21 | free(mb2); print(intToString(x + y)) 22 | } 23 | } 24 | 25 | def main(): Unit { 26 | let mb1 = new[Test] in 27 | mb1 ! Arg(1); 28 | mb1 ! Arg(2); 29 | spawn { nested(mb1) }; 30 | 31 | let mb2 = new[Test] in 32 | mb2 ! Arg(1); 33 | mb2 ! Arg(2); 34 | spawn { pairs(mb2) } 35 | } 36 | main() 37 | -------------------------------------------------------------------------------- /test/examples/interfaces.pat: -------------------------------------------------------------------------------- 1 | interface Reply1 { Go() } 2 | interface Reply2 { Go() } 3 | interface Receiver { Ready1(Reply1!), Ready2(Reply2!) } 4 | 5 | def go(self: Receiver?): Unit { 6 | guard self : Ready1 . Ready2 { 7 | receive Ready1(reply1) from mb -> 8 | guard mb : Ready2 { 9 | receive Ready2(reply2) from mb -> 10 | reply1 ! Go(); 11 | reply2 ! Go(); 12 | free(mb) 13 | } 14 | } 15 | } 16 | 17 | def main(): Unit { 18 | let mb = new[Receiver] in 19 | spawn { go(mb) }; 20 | let client1 = new[Reply1] in 21 | let client2 = new[Reply2] in 22 | mb ! Ready1(client1); 23 | mb ! Ready2(client2); 24 | guard client1 : Go { 25 | receive Go() from client1 -> free(client1) 26 | }; 27 | guard client2 : Go { 28 | receive Go() from client2 -> free(client2) 29 | } 30 | } 31 | 32 | main() 33 | -------------------------------------------------------------------------------- /lib/typecheck/gen_constraints.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | (* May be convenient to expose expression-level functions. *) 4 | 5 | (* Synthesises a type for a given expression and interface environment, also 6 | returning an environment and constraint set. *) 7 | val synthesise_comp : 8 | Interface_env.t -> 9 | Ty_env.t -> (* Declaration environment *) 10 | Ir.comp -> 11 | Type.t * Ty_env.t * Constraint_set.t 12 | 13 | (* Checks an expression against a type, returning an environment and constraint set.*) 14 | val check_comp : 15 | Interface_env.t -> 16 | Ty_env.t -> 17 | Ir.comp -> 18 | Type.t -> 19 | Ty_env.t * Constraint_set.t 20 | 21 | (* Check top-level program against a type *) 22 | val synthesise_program : Ir.program -> Type.t * Ty_env.t * Constraint_set.t 23 | 24 | (* Check top-level program against a type. Currently unused. *) 25 | val check_program : Ir.program -> Type.t -> Ty_env.t * Constraint_set.t 26 | 27 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/future.pat: -------------------------------------------------------------------------------- 1 | interface Future { Put(Int), Get(User!) } 2 | interface User { Reply(Int) } 3 | 4 | def future(self: Future?): Unit { 5 | guard self : Put.Get* { 6 | receive Put(x) from self -> resolvedFuture(self, x) 7 | } 8 | } 9 | 10 | def resolvedFuture(self: Future?, value: Int): Unit { 11 | guard self : Get* { 12 | free -> () 13 | receive Get(user) from self -> 14 | user ! Reply(value); 15 | resolvedFuture(self, value) 16 | } 17 | } 18 | 19 | def user(future: Future!): Int { 20 | let self = new[User] in 21 | future ! Get(self); 22 | guard self : Reply { 23 | receive Reply(x) from self -> 24 | free(self); 25 | x 26 | } 27 | } 28 | 29 | def main(): Unit { 30 | # Test comment 31 | let future_mb = new[Future] in 32 | spawn { future(future_mb) }; 33 | future_mb ! Put(5); 34 | print(intToString(user(future_mb))); 35 | print(intToString(user(future_mb))) 36 | } 37 | 38 | main() 39 | -------------------------------------------------------------------------------- /test/errors/lock.pat: -------------------------------------------------------------------------------- 1 | interface Lock { Acquire(User!), Release(Unit) } 2 | interface User { Reply(Lock!) } 3 | 4 | def freeLock(self: Lock?): Unit { 5 | guard (self) : Acquire* { 6 | free -> () 7 | receive Acquire(owner) from self -> 8 | busyLock(self, owner) 9 | receive Release(x) from self -> 10 | fail(self)[Unit] 11 | } 12 | } 13 | 14 | def busyLock(self: Lock?, owner: User!): Unit { 15 | owner ! Reply(self); 16 | guard (self) : Acquire*.Release { 17 | receive Release(x) from self -> 18 | freeLock(self) 19 | } 20 | } 21 | 22 | def user(num: Int, lock: Lock!): Unit { 23 | let self = new[User] in 24 | guard(self) : Reply { 25 | receive Reply(lock) from self -> 26 | print(intToString(num)); 27 | lock ! Release(()); 28 | free(self) 29 | } 30 | } 31 | 32 | 33 | def main(): Unit { 34 | let lock = new[Lock] in 35 | spawn { freeLock(lock) }; 36 | spawn { user(1, lock) }; 37 | spawn { user(2, lock) } 38 | } 39 | 40 | 41 | main() 42 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/futurefail.pat: -------------------------------------------------------------------------------- 1 | interface Future { Put(Int), Get(User!) } 2 | interface User { Reply(Int) } 3 | 4 | def future(self: Future?): Unit { 5 | guard self : Put.Get* { 6 | receive Put(x) from self -> resolvedFuture(self, x) 7 | } 8 | } 9 | 10 | def resolvedFuture(self: Future?, value: Int): Unit { 11 | guard self : Get* { 12 | free -> () 13 | receive Get(user) from self -> 14 | user ! Reply(value); 15 | resolvedFuture(self, value) 16 | receive Put(x) from self -> fail(self)[Unit] 17 | } 18 | } 19 | 20 | def user(future: Future!): Int { 21 | let self = new[User] in 22 | future ! Get(self); 23 | guard self : Reply { 24 | receive Reply(x) from self -> 25 | free(self); 26 | x 27 | } 28 | } 29 | 30 | def main(): Unit { 31 | # Test comment 32 | let future_mb = new[Future] in 33 | spawn { future(future_mb) }; 34 | future_mb ! Put(5); 35 | print(intToString(user(future_mb))); 36 | print(intToString(user(future_mb))) 37 | } 38 | 39 | main() 40 | -------------------------------------------------------------------------------- /lib/frontend/pipeline.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let desugar p = 4 | p 5 | |> Desugar_let_annotations.desugar 6 | |> Desugar_sugared_guards.desugar 7 | |> Insert_pattern_variables.annotate 8 | 9 | let typecheck p ir = 10 | (* 11 | Format.printf 12 | "=== Intermediate Representation: ===\n%a\n\n" 13 | (Ir.pp_program) ir; 14 | *) 15 | let ir, prety_opt = Typecheck.Pretypecheck.check ir in 16 | let (ty, env, constrs) = Typecheck.Gen_constraints.synthesise_program ir in 17 | let solution = Typecheck.Solve_constraints.solve_constraints constrs in 18 | let p = Sugar_ast.substitute_solution solution p in 19 | let ir = Ir.substitute_solution solution ir in 20 | (p, prety_opt, ir, ty, env, constrs) 21 | 22 | (* Frontend pipeline *) 23 | let pipeline p = 24 | let p = desugar p in 25 | let ir = Sugar_to_ir.transform p in 26 | let benchmark_count = Settings.(get benchmark) in 27 | let () = 28 | if benchmark_count >= 0 then 29 | Benchmark.benchmark benchmark_count (fun () -> typecheck p ir) 30 | in 31 | typecheck p ir 32 | -------------------------------------------------------------------------------- /test/errors/future.pat: -------------------------------------------------------------------------------- 1 | interface Future { Put(Int), Get(User!) } 2 | interface User { Reply(Int) } 3 | 4 | def future(self: Future?): Unit { 5 | guard self : Put.Get* { 6 | receive Put(x) from self -> resolvedFuture(self, x) 7 | } 8 | } 9 | 10 | def resolvedFuture(self: Future?, value: Int): Unit { 11 | guard self : Get* { 12 | free -> () 13 | receive Put(x) from self -> 14 | fail(self)[Unit] 15 | receive Get(user) from self -> 16 | user ! Reply(value); 17 | resolvedFuture(self, value) 18 | } 19 | } 20 | 21 | def user(future: Future!): Int { 22 | let self = new[User] in 23 | future ! Get(self); 24 | guard self : Reply { 25 | receive Reply(x) from self -> 26 | free(self); 27 | x 28 | } 29 | } 30 | 31 | def main(): Unit { 32 | # Test comment 33 | let future_mb = new[Future] in 34 | spawn { future(future_mb) }; 35 | future_mb ! Put(5); 36 | future_mb ! Put(5); 37 | print(intToString(user(future_mb))); 38 | print(intToString(user(future_mb))) 39 | } 40 | 41 | (main() : Unit) 42 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/future_state_passing.pat: -------------------------------------------------------------------------------- 1 | interface Future { Put(Int), Get(User!) } 2 | interface User { Reply(Int) } 3 | 4 | def future(self: Future?): (Unit * Future?1) { 5 | guard self : Put.Get* { 6 | receive Put(x) from self -> resolvedFuture(self, x) 7 | } 8 | } 9 | 10 | def resolvedFuture(self: Future?, value: Int): (Unit * Future?1) { 11 | guard self : Get* { 12 | empty(x) -> ((), x) 13 | receive Get(user) from self -> 14 | user ! Reply(value); 15 | resolvedFuture(self, value) 16 | } 17 | } 18 | 19 | def user(future: Future!): Int { 20 | let self = new[User] in 21 | future ! Get(self); 22 | guard self : Reply { 23 | receive Reply(x) from self -> 24 | free(self); 25 | x 26 | } 27 | } 28 | 29 | def main(): Unit { 30 | # Test comment 31 | let future_mb = new[Future] in 32 | spawn { let (x, mb) : (Unit * Future?1) = future(future_mb) in free(mb) }; 33 | future_mb ! Put(5); 34 | print(intToString(user(future_mb))); 35 | print(intToString(user(future_mb))) 36 | } 37 | 38 | main() 39 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/lock.pat: -------------------------------------------------------------------------------- 1 | interface Lock { Acquire(User!), Release(Unit) } 2 | interface User { Reply(Lock!) } 3 | 4 | def freeLock(self: Lock?): Unit { 5 | guard (self) : Acquire* { 6 | free -> () 7 | receive Acquire(owner) from self -> 8 | busyLock(self, owner) 9 | receive Release(x) from self -> 10 | fail(self)[Unit] 11 | } 12 | } 13 | 14 | def busyLock(self: Lock?, owner: User!): Unit { 15 | owner ! Reply(self); 16 | guard (self) : Acquire*.Release { 17 | receive Release(x) from self -> 18 | freeLock(self) 19 | } 20 | } 21 | 22 | def user(num: Int, lock: Lock!): Unit { 23 | let self = new[User] in 24 | lock ! Acquire(self); 25 | guard(self) : Reply { 26 | receive Reply(lock) from self -> 27 | print(intToString(num)); 28 | lock ! Release(()); 29 | free(self) 30 | } 31 | } 32 | 33 | 34 | def main(): Unit { 35 | let lock = new[Lock] in 36 | spawn { freeLock(lock) }; 37 | spawn { user(1, lock) }; 38 | spawn { user(2, lock) } 39 | } 40 | 41 | 42 | main() 43 | -------------------------------------------------------------------------------- /lib/common/interface.ml: -------------------------------------------------------------------------------- 1 | open Common_types 2 | open Util.Utility 3 | 4 | type t = { name: string; env: (string * (Type.t[@name "ty"]) list) list } 5 | [@@name "interface"] 6 | [@@deriving visitors { 7 | variety = "map"; 8 | ancestors = ["Type.map"]; 9 | data = false }] 10 | 11 | let lookup ?(pos_list=[]) (x: tag) (iface: t) = 12 | match List.assoc_opt x iface.env with 13 | | Some tys -> tys 14 | | None -> 15 | let msg = 16 | Printf.sprintf 17 | "Message tag %s not supported by interface %s." 18 | x iface.name 19 | in 20 | raise (Errors.Type_error (msg, pos_list)) 21 | 22 | let make name env = 23 | { name; env } 24 | 25 | let name x = x.name 26 | 27 | let bindings x = x.env 28 | 29 | let pp ppf x = 30 | let open Format in 31 | let pp_message ppf (name, tys) = 32 | fprintf ppf "%a(%a)" 33 | pp_print_string name 34 | (pp_print_comma_list Type.pp) tys 35 | in 36 | fprintf ppf "interface %a { %a }" 37 | pp_print_string x.name 38 | (pp_print_comma_list pp_message) 39 | x.env 40 | -------------------------------------------------------------------------------- /.github/workflows/default.yml: -------------------------------------------------------------------------------- 1 | name: MBCheck main workflow 2 | 3 | on: 4 | pull_request: 5 | branches: main 6 | push: 7 | branches: [main] 8 | schedule: 9 | # Prime the caches every Monday 10 | - cron: 0 1 * * MON 11 | 12 | jobs: 13 | interpreter: 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | os: 18 | - ubuntu-20.04 19 | ocaml-compiler: 20 | - 5.0.0 21 | 22 | runs-on: ${{ matrix.os }} 23 | 24 | steps: 25 | - name: Checkout code 26 | uses: actions/checkout@v2 27 | 28 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 29 | uses: ocaml/setup-ocaml@v2 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 32 | 33 | - name: Install system dependencies 34 | run: sudo apt install z3 35 | 36 | - name: Install mbcheck dependencies 37 | run: >- 38 | opam install 39 | ./mbcheck.opam 40 | --deps-only 41 | 42 | - name: Build mbcheck from source 43 | run: | 44 | eval $(opam env) 45 | make 46 | shell: bash 47 | 48 | - name: Run testsuite 49 | run: | 50 | eval $(opam env) 51 | make test 52 | shell: bash 53 | -------------------------------------------------------------------------------- /lib/common/lib_types.ml: -------------------------------------------------------------------------------- 1 | (* Type signatures for primitive functions. 2 | * Just a stub for now; will fill it in later. 3 | *) 4 | open Common_types 5 | 6 | let signatures = 7 | let open Type in 8 | let open Base in 9 | let int_op_type = function_type false [Base Int; Base Int] (Base Int) in 10 | let int_rel_op_type = function_type false [Base Int; Base Int] (Base Bool) in 11 | let bool_rel_op_type = function_type false [Base Bool; Base Bool] (Base Bool) in 12 | let int_ops = 13 | List.map (fun x -> (x, int_op_type)) ["+"; "-"; "/"; "*"] 14 | in 15 | let int_rel_ops = 16 | List.map (fun x -> (x, int_rel_op_type)) ["<"; "<="; ">"; ">="; "!="; "=="] 17 | in 18 | let bool_rel_ops = 19 | List.map (fun x -> (x, bool_rel_op_type)) ["&&"; "||"] 20 | in 21 | int_ops @ int_rel_ops @ bool_rel_ops @ 22 | [ 23 | ("print", function_type false [Base Base.String] Type.unit_type); 24 | ("concat", function_type false [Base Base.String; Base Base.String] Type.string_type); 25 | ("rand", function_type false [Base Base.Int] (Base Base.Int)); 26 | ("sleep", function_type false [Base Base.Int] Type.unit_type); 27 | ("intToString", function_type false [Base Base.Int] (Base Base.String)) 28 | ] 29 | -------------------------------------------------------------------------------- /lib/typecheck/constraint_set.ml: -------------------------------------------------------------------------------- 1 | (* Set of constraints, allowing n-ary unions *) 2 | include Set.Make(Constraint) 3 | open Common.Type 4 | open Util.Utility 5 | 6 | let union_many = List.fold_left (union) empty 7 | 8 | let single_constraint p1 p2 = 9 | if p1 = p2 then empty else 10 | Constraint.make p1 p2 |> singleton 11 | 12 | let equivalence_constraint p1 p2 = 13 | if p1 = p2 then empty else 14 | of_list [Constraint.make p1 p2; Constraint.make p2 p1] 15 | 16 | let pp ppf x = 17 | Format.fprintf ppf "%a" 18 | (pp_print_newline_list Constraint.pp) 19 | (elements x) 20 | 21 | (* Simplifies all patterns in constraints, then removes duplicates *) 22 | let simplify = 23 | filter_map (fun c -> 24 | let (p1, p2) = 25 | Constraint.((lhs c |> Pattern.simplify, 26 | rhs c |> Pattern.simplify)) 27 | in 28 | if p1 = p2 then None else Some (Constraint.make p1 p2)) 29 | 30 | (* Returns a set of pattern variables contained within the constraint set. *) 31 | let pattern_variables cset = 32 | fold (fun x acc -> 33 | let pvs1 = Pattern.variables (Constraint.lhs x) in 34 | let pvs2 = Pattern.variables (Constraint.rhs x) in 35 | StringSet.union acc (StringSet.union pvs1 pvs2) 36 | ) cset StringSet.empty 37 | -------------------------------------------------------------------------------- /test/errors/alias_comm2.pat: -------------------------------------------------------------------------------- 1 | interface Carrier { CarrierMessage(Payload!) } 2 | interface Payload { PayloadMessage(Unit) } 3 | 4 | def freePayload(mb: Payload?): Unit { 5 | guard mb: (PayloadMessage.PayloadMessage) { 6 | receive PayloadMessage(x) from mb -> 7 | guard mb : (PayloadMessage) { 8 | receive PayloadMessage(y) from mb -> 9 | free(mb) 10 | } 11 | } 12 | } 13 | 14 | # Another trick to introduce aliasing. 15 | # What happens is we create a carrier and payload, 16 | # and send the payload along the carrier. 17 | # 18 | # We then receive from the carrier, free the carrier, 19 | # return the received endpoint, and let-bind it. 20 | # 21 | # By returning a send endpoint, we can alias it. The 22 | # usual trick of requiring disjoint environments in 23 | # a `let` doesn't work because the name is not contained 24 | # in the `guard` environment; rather, it is introduced 25 | # by the `receive` expression. 26 | def main(): Unit { 27 | let carrier = new[Carrier] in 28 | let payload = new[Payload] in 29 | 30 | 31 | spawn { carrier ! CarrierMessage(payload) }; 32 | spawn { freePayload(payload) }; 33 | 34 | let x = guard carrier : CarrierMessage { 35 | receive CarrierMessage(x) from carrier -> 36 | free(carrier); x 37 | } in 38 | 39 | x ! PayloadMessage(()); 40 | payload ! PayloadMessage(()) 41 | } 42 | 43 | (main() : Unit) 44 | -------------------------------------------------------------------------------- /lib/frontend/desugar_let_annotations.ml: -------------------------------------------------------------------------------- 1 | (* 2 | let x: A = M in N --> let x = (M : (returnable(A))) in N 3 | *) 4 | open Common 5 | 6 | let visitor = 7 | object(self) 8 | inherit [_] Sugar_ast.map as super 9 | 10 | method! visit_expr env expr_with_pos = 11 | let open Sugar_ast in 12 | let open Source_code in 13 | let expr_node = WithPos.node expr_with_pos in 14 | match expr_node with 15 | | Let { binder; annot = Some annot'; term; body } -> 16 | let inner_term = self#visit_expr env term in 17 | let body = self#visit_expr env body in 18 | let term = { expr_with_pos with node = Annotate (inner_term, Type.make_returnable annot') } in 19 | { expr_with_pos with node = Let { binder; annot = None; term; body } } 20 | | LetTuple { binders; annot = Some tys; term; cont } -> 21 | let cont = self#visit_expr env cont in 22 | let term = 23 | { expr_with_pos with node = 24 | Annotate (term, Type.make_returnable (Type.make_tuple_type tys)) } 25 | in 26 | { expr_with_pos with node = LetTuple { binders; annot = None; term; cont } } 27 | | _ -> super#visit_expr env expr_with_pos 28 | end 29 | 30 | let desugar = 31 | visitor#visit_program () 32 | -------------------------------------------------------------------------------- /test/examples/savina/kfork.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/fjthrput. 2 | ### 3 | ### Models the creation of n actors that are given a number of messages, for 4 | ### each of which, a computation is performed. The benchmark is parameterized by 5 | ### the number of actor processes. Since the array type is not available in 6 | ### Pat, we fix the number of actor processes to 3. 7 | 8 | interface ActorMb { 9 | Packet() 10 | } 11 | 12 | ## Actor processes handling the packet requests. 13 | def actor(self: ActorMb?): Unit { 14 | guard self: Packet* { 15 | free -> 16 | () 17 | receive Packet() from self -> 18 | let dummy = fact(rand(100000)) in 19 | actor(self) 20 | } 21 | } 22 | 23 | ## Computes the factorial of n. 24 | def fact(n: Int): Int { 25 | if (n <= 0) { 26 | 1 27 | } 28 | else { 29 | n * (fact(n - 1)) 30 | } 31 | } 32 | 33 | ## Sends the given number of messages to the specified actor mailbox. 34 | def flood(numMessages: Int, actorMb: ActorMb!): Unit { 35 | if (numMessages <= 0) { 36 | () 37 | } 38 | else { 39 | actorMb ! Packet(); 40 | flood(numMessages - 1, actorMb) 41 | } 42 | } 43 | 44 | ## Launcher. 45 | def main(): Unit { 46 | 47 | let actorMb1 = new [ActorMb] in 48 | spawn { actor(actorMb1) }; 49 | 50 | let actorMb2 = new [ActorMb] in 51 | spawn { actor(actorMb2) }; 52 | 53 | let actorMb3 = new [ActorMb] in 54 | spawn { actor(actorMb3) }; 55 | 56 | flood(100, actorMb1); 57 | flood(1000, actorMb1); 58 | flood(10000, actorMb1) 59 | } 60 | 61 | main() 62 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/account.pat: -------------------------------------------------------------------------------- 1 | interface Barrier { Reply() } 2 | 3 | interface Account { 4 | Debit(Int, Barrier!), 5 | Credit(Int, Account!, Barrier!), 6 | Stop() 7 | } 8 | 9 | def notify(barrier: Barrier!): Unit { 10 | barrier ! Reply() 11 | } 12 | 13 | def await(barrier: Barrier?): Unit { 14 | guard barrier : Reply { 15 | receive Reply() from barrier -> 16 | free(barrier) 17 | } 18 | } 19 | 20 | def account(self: Account?, balance: Int): Unit { 21 | guard self : (Debit* . Credit*) { 22 | # receive Stop() from self -> free(self) 23 | free -> () 24 | 25 | receive Debit(amount, ack) from self -> 26 | notify(ack); 27 | account(self, balance - amount) 28 | 29 | receive Credit(amount, payer, ack) from self -> 30 | # Create new barrier for this transaction 31 | let barrier = new[Barrier] in 32 | # Debit the payer 33 | payer ! Debit(amount, barrier); 34 | # Wait for confirmation 35 | await(barrier); 36 | # Notify initiator of this transaction 37 | notify(ack); 38 | account(self, balance + amount) 39 | } 40 | } 41 | 42 | def main(): Unit { 43 | # Alice 44 | let alice = new[Account] in 45 | spawn { account(alice, 10) }; 46 | # Bob 47 | let bob = new[Account] in 48 | spawn { account(bob, 15) }; 49 | ### Ack 50 | let barrier = new[Barrier] in 51 | #### 52 | alice ! Credit(10, bob, barrier); 53 | await(barrier) 54 | } 55 | -------------------------------------------------------------------------------- /test/errors/alias_comm1.pat: -------------------------------------------------------------------------------- 1 | # MBC programs are not allowed to send their own name to themselves. 2 | # (i.e., a ! m[a] is disallowed). 3 | # This program demonstrates unsoundness caused by using messages to 4 | # introduce aliasing in guard blocks. 5 | 6 | # In the original MB calculus, this can be ruled out using dependency 7 | # graphs: introduce a dependency between the mailbox handle and its 8 | # payload, and introduce a dependency between the guarded MB and its 9 | # continuations. 10 | 11 | interface Carrier { CarrierMessage(Payload!) } 12 | interface Payload { PayloadMessage(Payload!) } 13 | 14 | # Receives a PayloadMessage from the mailbox, forward the name to the 15 | # mailbox. At runtime, x and mb will be the same. 16 | def recvAndFree(mb: Payload?) : Unit { 17 | guard mb : (PayloadMessage . PayloadMessage*) { 18 | receive PayloadMessage(x) from mb -> 19 | mb ! PayloadMessage(x); 20 | recvAndFree(mb) 21 | } 22 | } 23 | 24 | # Receives a name from the carrier, sends it along the payload handle. 25 | # Note that at runtime, payload and payload2 will be the same. 26 | def go(carrier: Carrier?, payload: Payload!) : Unit { 27 | guard carrier : (CarrierMessage) { 28 | receive CarrierMessage(payload2) from y -> 29 | payload ! PayloadMessage(payload2); 30 | free(y) 31 | } 32 | } 33 | 34 | # Sets everything in motion. 35 | def main(): Unit { 36 | let carrier = new[Carrier] in 37 | let payload = new[Payload] in 38 | carrier ! CarrierMessage(payload); 39 | spawn { go(carrier, payload) }; 40 | recvAndFree(payload) 41 | } 42 | 43 | (main() : Unit) 44 | -------------------------------------------------------------------------------- /test/examples/savina/fib.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/fib 2 | ### 3 | ### Server that calculates the Fibonacci number sent in client requests. 4 | 5 | interface FibMb { 6 | Req(FibMb!, Int), 7 | Resp(Int) 8 | } 9 | 10 | ## Fibonacci process computing the (n - 1)st and (n - 2)nd terms. 11 | def fib(self: FibMb?): Unit { 12 | guard self: Req { 13 | receive Req(replyTo, n) from self -> 14 | let term = 15 | if (n <= 2) { 16 | 17 | # Base case. 18 | free(self); 19 | 1 20 | } 21 | else { 22 | 23 | # Inductive case (n - 1) and (n - 2). Delegate computation of (n - 1)st 24 | # and (n - 2)nd term to fib process replicas. 25 | let fib1Mb = new [FibMb] in 26 | spawn { fib(fib1Mb) }; 27 | 28 | let fib2Mb = new [FibMb] in 29 | spawn { fib(fib2Mb) }; 30 | 31 | fib1Mb ! Req(self, n - 1); 32 | fib2Mb ! Req(self, n - 2); 33 | 34 | # Combine results computed for the (n - 1)st and (n - 2)nd terms. 35 | guard self: Resp . Resp { 36 | receive Resp(f1) from self -> 37 | guard self: Resp { 38 | receive Resp(f2) from self -> 39 | free(self); 40 | f1 + f2 41 | } 42 | } 43 | } in 44 | 45 | replyTo ! Resp(term) 46 | } 47 | } 48 | 49 | ## Launcher. 50 | def main(): Unit { 51 | 52 | let fibMb = new [FibMb] in 53 | spawn { fib(fibMb) }; 54 | 55 | let self = new [FibMb] in 56 | fibMb ! Req(self, 5); 57 | guard self: Resp { 58 | receive Resp(f) from self -> 59 | free(self); 60 | print(concat("Result: ", intToString(f))) 61 | } 62 | } 63 | 64 | main() 65 | -------------------------------------------------------------------------------- /vim/syntax/lmb.vim: -------------------------------------------------------------------------------- 1 | syn keyword lmbTodo contained TODO FIXME XXX NOTE 2 | syn match lmbComment "#.*$" contains=lmbTodo 3 | 4 | "---------------------------------------------------------------- 5 | " lmb files (based off http://vim.wikia.com/wiki/Creating_your_own_syntax_files) 6 | " Also some regexes pinched from the Idris vim mode. 7 | "---------------------------------------------------------------- 8 | 9 | " Regular int like number with - + or nothing in front 10 | syn match lmbNumber '\d\+' display 11 | syn match lmbNumber '[-+]\d\+' display 12 | 13 | " Floating point number with decimal no E or e (+,-) 14 | syn match lmbNumber '\d\+\.\d*' display 15 | syn match lmbNumber '[-+]\d\+\.\d*' display 16 | 17 | " Types and identifiers 18 | syn match lmbType '[A-Z][A-Za-z0-9_]*' display 19 | syn match lmbIdentifier "[a-z][a-zA-z0-9_]*\('\)*" 20 | syn match lmbComment "?" contains=lmbSymbol 21 | syn match lmbComment "!" contains=lmbSymbol 22 | syn region lmbString start='"' end='"' 23 | 24 | " Keywords 25 | syn keyword lmbKeywords def free fail receive from let in spawn 26 | syn keyword lmbKeywords guard new interface fun linfun 27 | 28 | " Library functions 29 | syn keyword linksLibWord print intToString 30 | 31 | " Conditionals 32 | syn keyword lmbConditional if else true false 33 | 34 | highlight def link lmbComment Comment 35 | highlight def link lmbNumber Number 36 | highlight def link lmbString String 37 | highlight def link lmbConditional Conditional 38 | highlight def link lmbTodo Todo 39 | highlight def link lmbKeywords Keyword 40 | highlight def link lmbIdentifier Normal 41 | highlight def link linksLibWord Identifier 42 | highlight def link lmbType Type 43 | highlight def link lmbSymbol SpecialChar 44 | -------------------------------------------------------------------------------- /lib/frontend/parse.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | open Lexer 3 | open Lexing 4 | open Source_code 5 | 6 | let pos lexbuf = Position.make 7 | ~start: 8 | { lexbuf.lex_start_p with 9 | Lexing.pos_lnum = 10 | if lexbuf.lex_start_p.pos_lnum > 1 then 11 | lexbuf.lex_start_p.pos_lnum - 2 12 | else 13 | lexbuf.lex_start_p.pos_lnum 14 | } 15 | ~finish:lexbuf.lex_curr_p 16 | ~code:(SourceCodeManager.get_instance ()) 17 | 18 | let parse_with_error lexbuf = 19 | try Parser.program Lexer.read lexbuf with 20 | | SyntaxError msg -> 21 | let msg = Format.asprintf "%s" msg in 22 | raise (Errors.parse_error msg [pos lexbuf]) 23 | | Parser.Error -> 24 | let msg = Format.asprintf "syntax error" in 25 | raise (Errors.parse_error msg [pos lexbuf]) 26 | 27 | let parse_and_print lexbuf = 28 | let (program, _) = parse_with_error lexbuf in 29 | Settings.if_verbose (fun () -> 30 | Format.printf "=== Parsed Program ===\n%a\n\n" Sugar_ast.pp_program program); 31 | program 32 | 33 | let parse_file filename () = 34 | let inx = In_channel.open_text filename in 35 | let lexbuf = Lexing.from_channel inx in 36 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 37 | let expr = parse_and_print lexbuf in 38 | In_channel.close inx; 39 | expr 40 | 41 | let parse_string x () = 42 | let lexbuf = Lexing.from_string x in 43 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = "" }; 44 | let expr = parse_and_print lexbuf in 45 | expr 46 | -------------------------------------------------------------------------------- /test/examples/savina/fib_pairs.pat: -------------------------------------------------------------------------------- 1 | interface FibActor { Request(Int, FibActor!), Response(Int) } 2 | 3 | def fibActor(self: FibActor?): Unit { 4 | # Fib actor will always get a request 5 | guard self : Request { 6 | receive Request(n, parent) from self -> 7 | # Base case: Send 1 to parent 8 | if (n <= 2) { 9 | parent ! Response(1); 10 | free(self) 11 | # Otherwise: spawn new actors and send requests 12 | } else { 13 | let childMB1 = new[FibActor] in 14 | spawn { fibActor(childMB1) }; 15 | childMB1 ! Request(n - 1, self); 16 | 17 | let childMB2 = new[FibActor] in 18 | spawn { fibActor(childMB2) }; 19 | childMB2 ! Request(n - 2, self); 20 | let (x1, self) = 21 | guard self : Response.Response { 22 | receive Response(x1) from self -> (x1, self) 23 | } 24 | in 25 | let (x2, self) = 26 | guard self : Response { 27 | receive Response(x2) from self -> (x2, self) 28 | } 29 | in 30 | free(self); 31 | parent ! Response(x1 + x2) 32 | } 33 | } 34 | } 35 | 36 | def mainFibActor(n: Int): Int { 37 | let root = new[FibActor] in 38 | let firstActor = new[FibActor] in 39 | spawn { fibActor(firstActor) }; 40 | firstActor ! Request(n, root); 41 | guard root : Response { 42 | receive Response(x) from root -> 43 | free(root); 44 | x 45 | } 46 | } 47 | mainFibActor(5) 48 | -------------------------------------------------------------------------------- /lib/common/common_types.ml: -------------------------------------------------------------------------------- 1 | (* Common types used over multiple files *) 2 | 3 | module Base = struct 4 | type t = 5 | | Atom 6 | | Int 7 | | Bool 8 | | String 9 | [@@deriving show] 10 | 11 | let pp ppf = 12 | let ps = Format.pp_print_string ppf in 13 | function 14 | | Atom -> ps "Atom" 15 | | Int -> ps "Int" 16 | | Bool -> ps "Bool" 17 | | String -> ps "String" 18 | end 19 | 20 | type interface_name = string 21 | [@@name "string"] 22 | [@@deriving show] 23 | 24 | type tag = string 25 | [@@name "string"] 26 | [@@deriving show] 27 | 28 | (* Boxed constants *) 29 | module Constant = struct 30 | type t = 31 | | Int of int 32 | | String of string 33 | | Bool of bool 34 | 35 | let type_of = function 36 | | Int _ -> Base.Int 37 | | Bool _ -> Base.Bool 38 | | String _ -> Base.String 39 | 40 | let pp ppf = function 41 | | Int i -> Format.pp_print_int ppf i 42 | | String s -> Format.fprintf ppf "\"%s\"" s 43 | | Bool b -> Format.pp_print_bool ppf b 44 | 45 | let wrap_int i = Int i 46 | let wrap_string s = String s 47 | let wrap_bool b = Bool b 48 | 49 | let unwrap_int pos_list = function 50 | | Int i -> i 51 | | _ -> raise (Errors.type_error "unwrap_int on non-int" pos_list) 52 | 53 | let unwrap_string pos_list = function 54 | | String s -> s 55 | | _ -> raise (Errors.type_error "unwrap_string on non-string" pos_list) 56 | 57 | let unwrap_bool pos_list = function 58 | | Bool b -> b 59 | | _ -> raise (Errors.type_error "unwrap_bool on non-bool" pos_list) 60 | end 61 | -------------------------------------------------------------------------------- /lib/frontend/desugar_sugared_guards.ml: -------------------------------------------------------------------------------- 1 | (* 2 | fail(M)[A] ---> guard e : 0 { fail[A] } 3 | *) 4 | open Common 5 | 6 | let visitor = 7 | object(self) 8 | inherit [_] Sugar_ast.map as super 9 | 10 | method! visit_guard env guard_with_pos = 11 | let open Sugar_ast in 12 | let open Source_code in 13 | let guard_node = WithPos.node guard_with_pos in 14 | match guard_node with 15 | | GFree e -> 16 | let var = "_gf" in 17 | let e = self#visit_expr env e in 18 | let new_guard_node = Empty (var, (WithPos.make (Seq (WithPos.make (Free (WithPos.make (Var var))), e)))) in 19 | { guard_with_pos with node = new_guard_node } 20 | | _ -> super#visit_guard env guard_with_pos 21 | 22 | method! visit_expr env expr_with_pos = 23 | let open Sugar_ast in 24 | let open Source_code in 25 | let expr_node = WithPos.node expr_with_pos in 26 | match expr_node with 27 | | SugarFail (e, ty) -> 28 | let new_target = self#visit_expr env e in 29 | let new_guard = Guard { 30 | target = new_target; 31 | pattern = Type.Pattern.Zero; 32 | guards = [WithPos.make ~pos:(WithPos.pos new_target) (Fail ty)]; 33 | iname = None 34 | } in 35 | let new_expr_node = Annotate (WithPos.make ~pos:(WithPos.pos new_target) new_guard, ty) in 36 | { expr_with_pos with node = new_expr_node } 37 | | _ -> super#visit_expr env expr_with_pos 38 | end 39 | 40 | let desugar = 41 | visitor#visit_program () 42 | -------------------------------------------------------------------------------- /test/examples/savina/ping_pong_strict.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/pingpong 2 | ### 3 | ### Two actors that repeatedly send and reply a Ping message back and forth. 4 | ### A ping count is maintained, which, once exhausted, induces the system to 5 | ### terminate. 6 | 7 | interface PingMb { 8 | Start(PongMb!), 9 | Pong(PongMb!) 10 | } 11 | 12 | interface PongMb { 13 | Ping(PingMb!), 14 | Stop() 15 | } 16 | 17 | ## Ping process handling launching of main loop. 18 | def ping(self: PingMb?, pingsLeft: Int): Unit { 19 | 20 | guard self: Start { 21 | receive Start(pongMb) from self -> 22 | send_ping(self, pongMb, pingsLeft) 23 | } 24 | } 25 | 26 | ## Issues a ping to the ponger process and loops or exits if no pings left. 27 | def send_ping(self: PingMb?, pongMb: PongMb!, pingsLeft: Int): Unit { 28 | if (pingsLeft > 0) { 29 | pongMb ! Ping(self); 30 | ping_loop(self, pingsLeft - 1) 31 | } 32 | else { 33 | pongMb ! Stop(); 34 | free(self) 35 | } 36 | } 37 | 38 | ## Ping process main loop issuing ping requests. 39 | def ping_loop(self: PingMb?, pingsLeft: Int): Unit { 40 | 41 | guard self: Pong { 42 | receive Pong(pongMb) from self -> 43 | send_ping(self, pongMb, pingsLeft) 44 | } 45 | } 46 | 47 | ## Pong process loop issuing pong replies. 48 | def pong(self: PongMb?): Unit { 49 | 50 | # guard self: *(Ping + Stop) { 51 | guard self: Ping + Stop { 52 | # free -> () 53 | receive Ping(pingMb) from self -> 54 | pingMb ! Pong(self); 55 | pong(self) 56 | receive Stop() from self -> 57 | free(self) 58 | } 59 | } 60 | 61 | ## Launcher. 62 | def main(): Unit { 63 | 64 | let pongMb = new [PongMb] in 65 | spawn { pong(pongMb) }; 66 | 67 | let pingMb = new [PingMb] in 68 | spawn { ping(pingMb, 5) }; 69 | 70 | pingMb ! Start(pongMb) 71 | } 72 | 73 | main() 74 | -------------------------------------------------------------------------------- /test/run-tests.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | import sys 3 | import json 4 | import subprocess 5 | 6 | # Assumes the file is run from the tests directory, and that the executable 7 | # is located at "../mbcheck" 8 | 9 | def error(msg): 10 | print(msg, file=sys.stderr) 11 | sys.exit(-1) 12 | 13 | def run_tests(testsuite): 14 | overall_result = True 15 | executable = "../mbcheck" 16 | # Runs a test group, checking the exit code 17 | # Later, we may wish to also check stdout and stderr 18 | def run_group(group): 19 | print("===", "Group:", group["group"], "===") 20 | for test in group["tests"]: 21 | process_result = \ 22 | subprocess.run([executable, test["filename"]], \ 23 | stdout=subprocess.DEVNULL, \ 24 | stderr=subprocess.DEVNULL) 25 | result = True 26 | if "exit_code" in test: 27 | result = (result and process_result.returncode == test["exit_code"]) 28 | result_str = "PASS" if result else "FAIL" 29 | print(f"{test['name']}: ({result_str})") 30 | if not result: 31 | overall_result = False 32 | 33 | if "groups" in testsuite: 34 | for group in testsuite["groups"]: 35 | run_group(group) 36 | else: 37 | error("Malformed testsuite: expected 'groups'") 38 | 39 | 40 | def main(): 41 | # Default test suite is tests.json 42 | test_suite = "tests.json" 43 | # Can optionally be given as a command-line argument 44 | if len(sys.argv) > 1: 45 | test_suite = sys.argv[1] 46 | 47 | # Open and parse test suite, then run 48 | with open(test_suite, 'r') as testsuite: 49 | parsed = json.loads(testsuite.read()) 50 | run_tests(parsed) 51 | 52 | if __name__ == "__main__": 53 | main() 54 | -------------------------------------------------------------------------------- /lib/typecheck/ty_env.mli: -------------------------------------------------------------------------------- 1 | (* Typing environments, used as an output of the typing algorithm. *) 2 | open Common 3 | open Common.Source_code 4 | 5 | type t 6 | 7 | (** Empty type environment *) 8 | val empty : t 9 | 10 | val bind : Ir.Var.t -> Type.t -> t -> t 11 | val lookup : Ir.Var.t -> t -> Type.t 12 | val lookup_opt : Ir.Var.t -> t -> Type.t option 13 | val delete : Ir.Var.t -> t -> t 14 | val delete_many : Ir.Var.t list -> t -> t 15 | val delete_binder : Ir.Binder.t -> t -> t 16 | val singleton : Ir.Var.t -> Type.t -> t 17 | val bindings : t -> (Ir.Var.t * Type.t) list 18 | val from_list : (Ir.Var.t * Type.t) list -> t 19 | val iter : (Ir.Var.t -> Type.t -> unit) -> t -> unit 20 | 21 | (** Disjoint connection of environments (i.e., the + operator on environments) *) 22 | val combine : Interface_env.t -> t -> t -> Position.t -> t * Constraint_set.t 23 | 24 | (** Disjoint connection of many environments *) 25 | val combine_many : Interface_env.t -> t list -> Position.t -> t * Constraint_set.t 26 | 27 | (** Joins two sequential / concurrent environments *) 28 | val join : Interface_env.t -> t -> t -> Position.t -> t * Constraint_set.t 29 | 30 | (** Merges two branching environments (e.g., if-then-else, cases) *) 31 | val intersect : t -> t -> Position.t -> t * Constraint_set.t 32 | 33 | (** Prints environment to standard output *) 34 | val dump : t -> unit 35 | 36 | (** Sets all mailbox types to be usable *) 37 | val make_usable : t -> t 38 | 39 | (** Sets all mailbox types to be returnable *) 40 | val make_returnable : t -> t 41 | 42 | (** Makes all types in the environment unrestricted *) 43 | val make_unrestricted : t -> Position.t -> Constraint_set.t 44 | 45 | (** Checks to see whether environment contains a variable: if so, 46 | checks whether that the given type is a subtype of the type in 47 | the environment. 48 | *) 49 | val check_type : Interface_env.t -> Ir.Var.t -> Type.t -> t -> Position.t -> Constraint_set.t 50 | -------------------------------------------------------------------------------- /test/examples/savina/ping_pong.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/pingpong 2 | ### 3 | ### Two actors that repeatedly send and reply a Ping message back and forth. 4 | ### A ping count is maintained, which, once exhausted, induces the system to 5 | ### terminate. 6 | 7 | interface PingMb { 8 | Start(), 9 | Pong() 10 | } 11 | 12 | interface PongMb { 13 | Ping(PingMb!), 14 | Stop() 15 | } 16 | 17 | ## Ping process handling the launching of main loop. 18 | def ping(self: PingMb?, pongMb: PongMb!, pingsLeft: Int): Unit { 19 | 20 | guard self: Start { 21 | receive Start() from self -> 22 | ping_loop(self, pongMb, pingsLeft) 23 | } 24 | } 25 | 26 | ## Ping process main loop issuing ping requests. 27 | def ping_loop(self: PingMb?, pongMb: PongMb!, pingsLeft: Int): Unit { 28 | 29 | if (pingsLeft > 0) { 30 | 31 | # Issue ping and await reply. Reply 32 | pongMb ! Ping(self); 33 | guard self: Pong + 1 { 34 | free -> 35 | () 36 | receive Pong() from self -> 37 | ping_loop(self, pongMb, pingsLeft - 1) 38 | } 39 | } 40 | else { 41 | 42 | # No more pings to issue: notify ponger to stop. 43 | pongMb ! Stop(); 44 | free(self) 45 | } 46 | } 47 | 48 | ## Pong process loop issuing pong replies. 49 | def pong(self: PongMb?): Unit { 50 | 51 | guard self: (Ping + Stop)* { 52 | free -> () 53 | receive Ping(pingMb) from self -> 54 | pingMb ! Pong(); 55 | pong(self) 56 | receive Stop() from self -> 57 | pong_exit(self) 58 | } 59 | } 60 | 61 | ## Pong process exit procedure that flushes potential residual messages. 62 | def pong_exit(self: PongMb?): Unit { 63 | guard self: (Ping + Stop)* { 64 | free -> () 65 | receive Ping(pingMb) from self -> 66 | pong_exit(self) 67 | receive Stop() from self -> 68 | pong_exit(self) 69 | } 70 | } 71 | 72 | ## Launcher. 73 | def main(): Unit { 74 | 75 | let pongMb = new [PongMb] in 76 | spawn { pong(pongMb) }; 77 | 78 | let pingMb = new [PingMb] in 79 | spawn { ping(pingMb, pongMb, 5) }; 80 | 81 | pingMb ! Start() 82 | } 83 | 84 | main() 85 | -------------------------------------------------------------------------------- /generate-table.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | import os 3 | import subprocess 4 | from tabulate import tabulate 5 | 6 | REPETITIONS = 100 7 | 8 | BENCHMARKS =\ 9 | [ 10 | ("Lock", os.path.join("test", "examples", "de_liguoro_padovani", "lock.pat")), 11 | ("Future", os.path.join("test", "examples", "de_liguoro_padovani", "future.pat")), 12 | ("Account", os.path.join("test", "examples", "de_liguoro_padovani", "account.pat")), 13 | ("AccountF", os.path.join("test", "examples", "de_liguoro_padovani", "account_future.pat")), 14 | ("Master-Worker", os.path.join("test", "examples", "de_liguoro_padovani", "master_worker.pat")), 15 | ("Session Types", os.path.join("test", "examples", "de_liguoro_padovani", "sessions.pat")), 16 | ("Ping Pong", os.path.join("test", "examples", "savina", "ping_pong_strict.pat")), 17 | ("Thread Ring", os.path.join("test", "examples", "savina", "thread_ring.pat")), 18 | ("Counter", os.path.join("test", "examples", "savina", "count.pat")), 19 | ("K-Fork", os.path.join("test", "examples", "savina", "kfork.pat")), 20 | ("Fibonacci", os.path.join("test", "examples", "savina", "fib.pat")), 21 | ("Big", os.path.join("test", "examples", "savina", "big.pat")), 22 | ("Philosopher", os.path.join("test", "examples", "savina", "philosopher.pat")), 23 | ("Smokers", os.path.join("test", "examples", "savina", "cig_smok.pat")), 24 | ("Log Map", os.path.join("test", "examples", "savina", "log_map.pat")), 25 | ("Transaction", os.path.join("test", "examples", "savina", "banking.pat")) 26 | ] 27 | 28 | # Tries to run in strict mode -- returns True if it works, False otherwise 29 | def try_strict(path): 30 | return subprocess.run(["./mbcheck", "--mode=strict", path],\ 31 | capture_output=True).returncode == 0 32 | 33 | def run_benchmark(name, path): 34 | print("Running example " + name) 35 | is_strict = try_strict(path) 36 | time = str(subprocess.run(["./mbcheck", "-b", str(REPETITIONS), path],\ 37 | capture_output=True, text=True).stdout) 38 | return (name, is_strict, time) 39 | 40 | def main(): 41 | print("Generating table -- this may take some time.") 42 | results = [run_benchmark(name, path) for (name, path) in BENCHMARKS] 43 | print(tabulate(results, headers=["Name", "Strict", "Time (ms)"], tablefmt='grid')) 44 | 45 | if __name__ == "__main__": 46 | main() 47 | -------------------------------------------------------------------------------- /lib/typecheck/presburger.ml: -------------------------------------------------------------------------------- 1 | (* Presburger Formulae *) 2 | type var = string 3 | 4 | type relation = EQ | LE | LT 5 | 6 | type expr = 7 | | Var of var 8 | | Int of int 9 | | Add of (expr * expr) 10 | | Mul of (int * expr) 11 | 12 | type t = 13 | | False 14 | | True 15 | | Rel of (relation * expr * expr) 16 | | And of (t * t) 17 | | Or of (t * t) 18 | | Not of t 19 | | Forall of (var * t) 20 | | Exists of (var * t) 21 | 22 | 23 | (* Goal: Want to check whether lhs implies rhs, given the tags *) 24 | type goal = { tags: string list; lhs: t; rhs: t } 25 | 26 | let make_goal tags lhs rhs = { tags; lhs; rhs } 27 | 28 | (* Optimising constructors for And and Or *) 29 | let conj p1 p2 = 30 | match p1, p2 with 31 | | _, False | False, _ -> False 32 | | p, True | True, p -> p 33 | | p1, p2 -> And (p1, p2) 34 | 35 | let disj p1 p2 = 36 | match p1, p2 with 37 | | p, False | False, p -> p 38 | | _, True | True, _ -> True 39 | | p1, p2 -> Or (p1, p2) 40 | 41 | let tag_eq_lit tag n = Rel (EQ, Var tag, Int n) 42 | let tag_eq tag expr = Rel (EQ, Var tag, expr) 43 | let tt = True 44 | let ff = False 45 | let plus e1 e2 = 46 | match e1, e2 with 47 | | e, Int 0 | Int 0, e -> e 48 | | _, _ -> Add (e1, e2) 49 | 50 | 51 | let rec pp_expr ppf = 52 | let open Format in 53 | function 54 | | Var var -> pp_print_string ppf var 55 | | Int i -> pp_print_int ppf i 56 | | Add (e1, e2) -> 57 | Format.fprintf ppf "%a + %a" pp_expr e1 pp_expr e2 58 | | Mul (n, e) -> 59 | Format.fprintf ppf "%d * %a" n pp_expr e 60 | 61 | let pp_rel ppf = 62 | let open Format in 63 | function 64 | | EQ -> pp_print_string ppf "=" 65 | | LE -> pp_print_string ppf "≤" 66 | | LT -> pp_print_string ppf "<" 67 | 68 | let rec pp ppf = 69 | let open Format in 70 | function 71 | | False -> pp_print_string ppf "⊥" 72 | | True -> pp_print_string ppf "⊤" 73 | | Rel (rel, e1, e2) -> 74 | fprintf ppf "%a %a %a" pp_expr e1 pp_rel rel pp_expr e2 75 | | And (x1, x2) -> 76 | fprintf ppf "(%a ∧ %a)" pp x1 pp x2 77 | | Or (x1, x2) -> 78 | fprintf ppf "(%a ∨ %a)" pp x1 pp x2 79 | | Not x -> fprintf ppf "¬%a" pp x 80 | | Forall (var, x) -> fprintf ppf "∀%s. %a" var pp x 81 | | Exists (var, x) -> fprintf ppf "∃%s. %a" var pp x 82 | 83 | 84 | let pp_goal ppf { tags; lhs; rhs } = 85 | let open Format in 86 | fprintf ppf "[%a] %a ⟶ %a" 87 | (Util.Utility.pp_print_comma_list pp_print_string) tags 88 | pp lhs 89 | pp rhs 90 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let print_result (prog, prety, _ir, ty, _env, _constrs) = 4 | let open Format in 5 | Settings.if_verbose (fun () -> 6 | (* Print Program *) 7 | Format.printf 8 | "=== Resolved Program: ===\n%a\n\n" 9 | (Sugar_ast.pp_program) prog; 10 | (* Print pretype *) 11 | Option.iter 12 | (fprintf std_formatter "Pretype: %a\n" Pretype.pp) prety; 13 | (* Print type *) 14 | fprintf std_formatter "Type: %a\n" Type.pp ty 15 | ) 16 | 17 | (* for IR translation testing *) 18 | let print_ir (prog, _prety, ir, _ty, _env, _constrs) = 19 | Format.printf 20 | "=== Resolved Program: ===\n%a\n\n" 21 | (Sugar_ast.pp_program) prog; 22 | Format.printf 23 | "=== Intermediate Representation: ===\n%a\n\n" 24 | (Ir.pp_program) ir 25 | 26 | let process filename is_verbose is_debug is_ir mode benchmark_count disable_ql use_join () = 27 | Settings.(set verbose is_verbose); 28 | Settings.(set debug is_debug); 29 | Settings.(set receive_typing_strategy mode); 30 | Settings.(set benchmark benchmark_count); 31 | Settings.(set disable_quasilinearity disable_ql); 32 | Settings.(set join_not_combine use_join); 33 | try 34 | Frontend.Parse.parse_file filename () 35 | |> Frontend.Pipeline.pipeline 36 | |> (if is_ir then print_ir else print_result) 37 | with 38 | | e -> 39 | Errors.format_error e; 40 | Settings.if_debug (fun () -> Printexc.print_backtrace stderr); 41 | (exit (1)) 42 | 43 | let () = 44 | let open Cmdliner in 45 | let mbcheck_t = Term.(const process 46 | $ Arg.(required & pos 0 (some string) None & info [] ~docv:"FILENAME") 47 | $ Arg.(value & flag & info ["v"; "verbose"] ~doc:"verbose typechecking information") 48 | $ Arg.(value & flag & info ["d"; "debug"] ~doc:"print debug information") 49 | $ Arg.(value & flag & info ["ir"] ~doc:"print the parsed program and its IR translation") 50 | $ Arg.(value & opt (enum Settings.ReceiveTypingStrategy.enum) Settings.ReceiveTypingStrategy.Interface & info ["mode"] 51 | ~docv:"MODE" ~doc:"typechecking mode for receive blocks (allowed: strict, interface, none)") 52 | $ Arg.(value & opt int (-1) & info ["b"; "benchmark"] 53 | ~docv:"BENCHMARK" ~doc:"number of repetitions for benchmark; -1 (default) for no benchmarking") 54 | $ Arg.(value & flag & info ["q"; "disable-quasilinearity"] ~doc:"disable quasilinearity checking") 55 | $ Arg.(value & flag & info ["j"; "join-not-combine"] ~doc:"use sequential join for value subterms, rather than requiring disjointness") 56 | $ const ()) in 57 | let info = Cmd.info "mbcheck" ~doc:"Typechecker for mailbox calculus" in 58 | Cmd.v info mbcheck_t 59 | |> Cmd.eval 60 | |> exit 61 | -------------------------------------------------------------------------------- /lib/util/utility.ml: -------------------------------------------------------------------------------- 1 | (* Random stuff that's useful everywhere *) 2 | 3 | (* Maps *) 4 | 5 | module type STRINGMAP = (Map.S with type key = string) 6 | module StringMap = Map.Make(String) 7 | type 'a stringmap = 'a StringMap.t 8 | 9 | module type STRINGSET = (Set.S with type elt = string) 10 | module StringSet = Set.Make(String) 11 | type stringset = StringSet.t 12 | 13 | (* Pipelining and composition *) 14 | 15 | (* Reverse function application (nicer and more uniform than `@@`) *) 16 | let (<|) f x = f x 17 | 18 | (* Function composition (left) *) 19 | let (<<) f g x = f(g(x)) 20 | 21 | (* Function composition (right) *) 22 | let (>>) f g x = g(f(x)) 23 | 24 | let flip f = fun x y -> f y x 25 | 26 | (* Chars *) 27 | 28 | let is_uppercase c = 29 | let code = Char.code c in 30 | code >= Char.code 'A' && code <= Char.code 'Z' 31 | 32 | (* Lists *) 33 | 34 | module ListUtils = struct 35 | 36 | let rec split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list = function 37 | | [] -> ([], [], []) 38 | | (x, y, z) :: rest -> 39 | let (xs, ys, zs) = split3 rest in 40 | x :: xs, y :: ys, z :: zs 41 | 42 | let rec combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list = 43 | fun xs ys zs -> 44 | match (xs, ys, zs) with 45 | | ([], [], []) -> [] 46 | | (x :: xs, y :: ys, z :: zs) -> 47 | let rest = combine3 xs ys zs in 48 | (x, y, z) :: rest 49 | | _, _, _ -> 50 | raise (Invalid_argument "mismatching lengths to combine3") 51 | end 52 | 53 | let find_char (s : bytes) (c : char) : int list = 54 | let rec aux offset occurrences = 55 | try let index = Bytes.index_from s offset c in 56 | aux (index + 1) (index :: occurrences) 57 | with Not_found -> occurrences 58 | in List.rev (aux 0 []) 59 | 60 | (* Pretty-printing *) 61 | open Format 62 | let pp_comma ppf () = 63 | pp_print_string ppf ", " 64 | 65 | let pp_print_comma_list ppf = 66 | pp_print_list ~pp_sep:(pp_comma) ppf 67 | 68 | let pp_print_newline_list ppf = 69 | pp_print_list ~pp_sep:(pp_force_newline) ppf 70 | 71 | let pp_double_newline ppf () = 72 | pp_force_newline ppf (); 73 | pp_force_newline ppf () 74 | 75 | let pp_print_double_newline_list ppf = 76 | pp_print_list ~pp_sep:(pp_double_newline) ppf 77 | 78 | (* Prints an error *) 79 | let print_error ?(note="ERROR") err = 80 | Format.fprintf err_formatter "[\027[31m%s\027[0m] %s\n" note err 81 | 82 | let print_debug err = 83 | Format.fprintf std_formatter "[\027[34mDEBUG\027[0m] %s\n" err 84 | 85 | 86 | (* f: a, b -> c ==> f: (a, b) -> c *) 87 | let curry f a b = f (a, b) 88 | let uncurry f (a, b) = f a b 89 | 90 | let rec split3 = function 91 | | [] -> ([], [], []) 92 | | (x, y, z) :: rest -> 93 | let (xs, ys, zs) = split3 rest in 94 | (x :: xs, y :: ys, z :: zs) 95 | -------------------------------------------------------------------------------- /lib/common/pretype.ml: -------------------------------------------------------------------------------- 1 | (* Pre-types: purely statically-determinable types which do not require 2 | behavioural typing or any non-trivial inference. Pre-types are either base 3 | types or interface annotations. Note that they do *not* include any message 4 | sequencing information. 5 | 6 | Basically lambda-act with first-class mailboxes. 7 | *) 8 | open Util.Utility 9 | 10 | type t = 11 | | PBase of base 12 | | PFun of { linear: bool; args: (Type.t[@name "ty"]) list; result: (Type.t[@name "ty"]) } 13 | | PInterface of string 14 | | PSum of (t * t) 15 | | PTuple of t list 16 | [@@name "pretype"] 17 | [@@deriving visitors { variety = "map" }] 18 | and base = [%import: Common_types.Base.t] 19 | 20 | let unit = PTuple [] 21 | 22 | let rec pp ppf = 23 | let open Format in 24 | let ps = pp_print_string ppf in 25 | function 26 | | PBase b -> Common_types.Base.pp ppf b 27 | | PFun { linear; args; result } -> 28 | let arrow = if linear then "-o" else "->" in 29 | fprintf ppf "(%a) %s %a" 30 | (pp_print_comma_list Type.pp) args 31 | arrow 32 | Type.pp result 33 | | PTuple ts -> 34 | let pp_star ppf () = pp_print_string ppf " * " in 35 | fprintf ppf "(%a)" 36 | (pp_print_list ~pp_sep:(pp_star) pp) ts 37 | | PSum (t1, t2) -> 38 | fprintf ppf "(%a + %a)" 39 | pp t1 40 | pp t2 41 | | PInterface name -> ps name 42 | 43 | let show t = 44 | let open Format in 45 | pp str_formatter t; 46 | flush_str_formatter () 47 | 48 | let rec of_type = function 49 | | Type.Base b -> PBase b 50 | | Type.Fun { linear; args; result } -> 51 | PFun { linear; args; result = result } 52 | | Type.Tuple ts -> PTuple (List.map of_type ts) 53 | | Type.Sum (t1, t2) -> PSum (of_type t1, of_type t2) 54 | | Type.Mailbox { interface; _ } -> PInterface interface 55 | 56 | (* As long as a pretype isn't a mailbox type, and isn't a function 57 | returning a mailbox type, we can upgrade it to a type. 58 | This reduces the number of places we need annotations (for example, 59 | when trying to type an application in synthesis mode). *) 60 | let rec to_type = function 61 | | PBase b -> Some (Type.Base b) 62 | | PFun { linear; args; result } -> 63 | Some (Type.Fun { linear; args; result }) 64 | | PTuple ts -> 65 | let rec go acc = 66 | function 67 | | [] -> Some (List.rev acc) 68 | | x :: xs -> 69 | Option.bind (to_type x) (fun t -> go (t :: acc) xs) 70 | in 71 | Option.bind (go [] ts) (fun ts -> Some (Type.Tuple ts)) 72 | | PSum (t1, t2) -> 73 | begin 74 | match to_type t1, to_type t2 with 75 | | Some ty1, Some ty2 -> Some (Type.Sum (ty1, ty2)) 76 | | _, _ -> None 77 | end 78 | | PInterface _ -> None 79 | -------------------------------------------------------------------------------- /run-paper-examples.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | import os 3 | import subprocess 4 | 5 | EXAMPLES =\ 6 | [ 7 | # Paper examples 8 | ("Future", os.path.join("test", "examples", "de_liguoro_padovani", "future.pat")), 9 | ("Use-after-free 1 (should fail)", os.path.join("test", "errors", "uaf1.pat")), 10 | ("Use-after-free 2 (should fail)", os.path.join("test", "errors", "uaf2.pat")), 11 | ("Use-after-free 3 (should fail)", os.path.join("test", "errors", "uaf3.pat")), 12 | ("Aliasing via communication 1 (should fail)", os.path.join("test",\ 13 | "errors",\ 14 | "alias_comm1.pat")), 15 | ("Aliasing via communication 2 (should fail)", os.path.join("test",\ 16 | "errors",\ 17 | "alias_comm2.pat")), 18 | ("Products", os.path.join("test", "examples", "products.pat")), 19 | ("Interfaces", os.path.join("test", "examples", "interfaces.pat")), 20 | ("Robots", os.path.join("test", "examples", "robotsn.pat")), 21 | # Benchmarks 22 | ("Lock", os.path.join("test", "examples", "de_liguoro_padovani", "lock.pat")), 23 | ("Account", os.path.join("test", "examples", "de_liguoro_padovani", "account.pat")), 24 | ("AccountF", os.path.join("test", "examples", "de_liguoro_padovani", "account_future.pat")), 25 | ("Master-Worker", os.path.join("test", "examples", "de_liguoro_padovani", "master_worker.pat")), 26 | ("Session Types", os.path.join("test", "examples", "de_liguoro_padovani", "sessions.pat")), 27 | ("Ping Pong", os.path.join("test", "examples", "savina", "ping_pong_strict.pat")), 28 | ("Thread Ring", os.path.join("test", "examples", "savina", "thread_ring.pat")), 29 | ("Counter", os.path.join("test", "examples", "savina", "count.pat")), 30 | ("K-Fork", os.path.join("test", "examples", "savina", "kfork.pat")), 31 | ("Fibonacci", os.path.join("test", "examples", "savina", "fib.pat")), 32 | ("Big", os.path.join("test", "examples", "savina", "big.pat")), 33 | ("Philosopher", os.path.join("test", "examples", "savina", "philosopher.pat")), 34 | ("Smokers", os.path.join("test", "examples", "savina", "cig_smok.pat")), 35 | ("Log Map", os.path.join("test", "examples", "savina", "log_map.pat")), 36 | ("Transaction", os.path.join("test", "examples", "savina", "banking.pat")) 37 | ] 38 | 39 | def run_example(name, path): 40 | print("Checking " + name) 41 | subprocess.run(["./mbcheck " + path], shell=True) 42 | print() 43 | 44 | def run_examples(): 45 | for (name, path) in EXAMPLES: 46 | run_example(name, path) 47 | 48 | if __name__ == "__main__": 49 | run_examples() 50 | -------------------------------------------------------------------------------- /test/examples/savina/count.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/count 2 | ### 3 | ### A generator actor sends messages to a receiving actor who increments a 4 | ### counter upon receiving a message. The generator actor retrieves the total. 5 | 6 | interface ProducerMb { 7 | Inc(), 8 | Total(Int) 9 | } 10 | 11 | interface CounterMb { 12 | Inc(), 13 | Get(ProducerMb!) 14 | } 15 | 16 | ## Producer process handling the launching of main loop. 17 | def producer(self: ProducerMb?, counterMb: CounterMb!, numMessages: Int): Unit { 18 | guard self: Inc { 19 | receive Inc() from self -> 20 | producer_loop(self, counterMb, numMessages) 21 | } 22 | } 23 | 24 | ## Producer process main loop issuing increment requests. 25 | def producer_loop(self: ProducerMb?, counterMb: CounterMb!, numMessages: Int): Unit { 26 | if (numMessages <= 0) { 27 | counterMb ! Get(self); 28 | producer_exit(self, numMessages) 29 | } 30 | else { 31 | counterMb ! Inc(); 32 | producer_loop(self, counterMb, numMessages - 1) 33 | } 34 | } 35 | 36 | ## Producer process exit procedure handling the final Total message. 37 | def producer_exit(self: ProducerMb?, numMessages: Int): Unit { 38 | 39 | guard self: Total { 40 | receive Total(total) from self -> 41 | print(concat("Total: ", intToString(total))); 42 | free(self) 43 | } 44 | } 45 | 46 | ## Counter process main loop handling increment requests. 47 | def counter(self: CounterMb?, total: Int): Unit { 48 | guard self: Inc* . Get { 49 | free -> () 50 | receive Inc() from self -> 51 | counter(self, total + 1) 52 | receive Get(producerMb) from self -> 53 | producerMb ! Total(total); 54 | 55 | # Function counter_exit/1 is required here, rather than the BIF free/1. 56 | # This is because, in principle, additional Inc messages may be still 57 | # be enqueued in the mailbox. Remember that commutative regular 58 | # expressions specify that (at the same moment), the mailbox contains any 59 | # number of Inc messages and exactly one Get message, without imposing 60 | # any order in which these are consumed. Even though it is clear from 61 | # the logic of the branching statement in the function producer_loop/3, 62 | # the type checker has no way of determining this. It is an approximative 63 | # analysis, after all (in particular, it does not evaluate the expression 64 | # in the if condition). At any rate, the best that can be done in this 65 | # case is for the counter to flush from the mailbox potential residual Inc 66 | # messages, once the Get message is processed. 67 | counter_exit(self) 68 | } 69 | } 70 | 71 | ## Counter process exit procedure that flushes potential residual messages. 72 | def counter_exit(self: CounterMb?): Unit { 73 | guard self: Inc* { 74 | free -> () 75 | receive Inc() from self -> 76 | counter_exit(self) 77 | } 78 | } 79 | 80 | ## Launcher. 81 | def main(): Unit { 82 | 83 | let counterMb = new [CounterMb] in 84 | spawn { counter(counterMb, 0) }; 85 | 86 | let producerMb = new [ProducerMb] in 87 | spawn { producer(producerMb, counterMb, 5) }; 88 | 89 | producerMb ! Inc() 90 | } 91 | 92 | main() 93 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/sessions.pat: -------------------------------------------------------------------------------- 1 | # Sessions example from "Mailbox Types for Unordered Interactions" 2 | interface Alice { 3 | AReply1(Arbiter!), 4 | AReply2(Arbiter!), 5 | AReply3(Int) 6 | } 7 | 8 | interface Carol { 9 | CReply1(Int, Arbiter!), 10 | CReply2(Int, Arbiter!), 11 | CReply3() 12 | } 13 | 14 | interface Arbiter { 15 | ASend1(Int, Alice!), 16 | ASend2(Int, Alice!), 17 | AReceive(Alice!), 18 | CReceive1(Carol!), 19 | CReceive2(Carol!), 20 | CSend(Int, Carol!) 21 | } 22 | 23 | 24 | def alice(self: Alice?, arb: Arbiter!): Unit { 25 | arb ! ASend1(4, self); 26 | let self = 27 | guard self : AReply1 { 28 | receive AReply1(arb) from self -> 29 | arb ! ASend2(2, self); 30 | guard self : AReply2 { 31 | receive AReply2(arb) from self -> 32 | arb ! AReceive(self); 33 | self 34 | } 35 | } 36 | in 37 | guard self : AReply3 { 38 | receive AReply3(res) from self -> 39 | print(intToString(res)); 40 | free(self) 41 | } 42 | } 43 | 44 | def carol(self: Carol?, arb: Arbiter!): Unit { 45 | arb ! CReceive1(self); 46 | let self = 47 | guard self : CReply1 { 48 | receive CReply1(x, arb) from self -> 49 | arb ! CReceive2(self); 50 | guard self : CReply2 { 51 | receive CReply2(y, arb) from self -> 52 | arb ! CSend(x + y, self); 53 | self 54 | } 55 | } 56 | in 57 | guard self : CReply3 { 58 | receive CReply3() from self -> free(self) 59 | } 60 | } 61 | 62 | def arbiter(self: Arbiter?): Unit { 63 | let self = 64 | guard self : ASend1 . CReceive1 { 65 | receive ASend1(x, aliceMB) from self -> 66 | guard self : CReceive1 { 67 | receive CReceive1(carolMB) from self -> 68 | aliceMB ! AReply1(self); 69 | carolMB ! CReply1(x, self); 70 | self 71 | } 72 | } 73 | in 74 | let self = 75 | guard self : ASend2 . CReceive2 { 76 | receive ASend2(y, aliceMB) from self -> 77 | guard self : CReceive2 { 78 | receive CReceive2(carolMB) from self -> 79 | aliceMB ! AReply2(self); 80 | carolMB ! CReply2(y, self); 81 | self 82 | } 83 | } 84 | in 85 | guard self : CSend . AReceive { 86 | receive CSend(res, carolMB) from self -> 87 | guard self : AReceive { 88 | receive AReceive(aliceMB) from self -> 89 | aliceMB ! AReply3(res); 90 | carolMB ! CReply3(); 91 | free(self) 92 | } 93 | } 94 | } 95 | 96 | def main(): Unit { 97 | let aliceMB = new[Alice] in 98 | let carolMB = new[Carol] in 99 | let arbiterMB = new[Arbiter] in 100 | spawn { alice(aliceMB, arbiterMB) }; 101 | spawn { carol(carolMB, arbiterMB) }; 102 | arbiter(arbiterMB) 103 | } 104 | 105 | main() 106 | 107 | -------------------------------------------------------------------------------- /test/examples/savina/thread_ring.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/threadring 2 | ### 3 | ### A ring of actors modelling a cyclic workflow with a chain of tasks, where 4 | ### each actor decrements a token and forwards it until the token value reaches 5 | ### zero. 6 | 7 | interface ActorMb { 8 | Data(ActorMb!), 9 | Ping(Int), 10 | Exit(Int) 11 | } 12 | 13 | ## Actor process handling the launching of main loop. 14 | ## numActors: Number of actors in ring 15 | def actor(self: ActorMb?, numActors: Int): Unit { 16 | guard self: Data . Ping* . Exit* { 17 | receive Data(neighborMb) from self -> 18 | actor_loop(self, numActors, neighborMb) 19 | } 20 | } 21 | 22 | ## Ping process main loop issuing pings and exits. 23 | def actor_loop(self: ActorMb?, numActors: Int, neighborMb: ActorMb!): Unit { 24 | 25 | guard self: Ping* . Exit* { 26 | # Required because of the if condition in the receive statement for Ping 27 | # where the type checker does not have enough info to determine whether 28 | # the if part is ever taken (i.e., it does not evaluate the condition). 29 | free -> () 30 | receive Ping(pingsLeft) from self -> 31 | 32 | if (pingsLeft <= 0) { 33 | neighborMb ! Exit(numActors); 34 | actor_exit(self) 35 | 36 | } 37 | else { 38 | neighborMb ! Ping(pingsLeft - 1); 39 | actor_loop(self, numActors, neighborMb) 40 | } 41 | receive Exit(exitsLeft) from self -> 42 | if (exitsLeft <= 0) { 43 | () 44 | } 45 | else{ 46 | neighborMb ! Ping(exitsLeft - 1) 47 | }; 48 | actor_exit(self) 49 | } 50 | } 51 | 52 | ## Actor process exit procedure that flushes potential residual messages. 53 | def actor_exit(self: ActorMb?): Unit { 54 | guard self: Ping* . Exit* { 55 | free -> () 56 | receive Ping(pingsLeft) from self -> 57 | actor_exit(self) 58 | receive Exit(exitsLeft) from self -> 59 | actor_exit(self) 60 | } 61 | } 62 | 63 | ## Initializes ring of actors. The number of participants in the ring is 64 | ## parametrized by 'numActors'. 65 | def init_ring(numActors: Int, mainMb: ActorMb!): Unit { 66 | 67 | if (numActors < 2) { 68 | # Cannot have a ring with less than two actors. 69 | () 70 | } 71 | else { 72 | 73 | # Create first mailbox and spawn corresponding actor.. 74 | let firstActorMb = new [ActorMb] in 75 | spawn { actor(firstActorMb, numActors) }; 76 | 77 | # Create list of actors and close loop. 78 | let tailActorMb = create_actors(numActors - 2, numActors, firstActorMb) in 79 | tailActorMb ! Data(firstActorMb); 80 | 81 | # Notify main process of first actor mailbox. 82 | mainMb ! Data(firstActorMb) 83 | } 84 | } 85 | 86 | ## Creates a series of actors, linking each actor to the one preceding it by 87 | ## sending the address of its mailbox to the previous actor. 88 | def create_actors(count: Int, numActors: Int, prevActorMb: ActorMb!): ActorMb![R] { 89 | 90 | let actorMb = new [ActorMb] in 91 | spawn { actor(actorMb, numActors) }; 92 | 93 | # Link current actor to previous one. 94 | prevActorMb ! Data(actorMb); 95 | 96 | # Create next actor. 97 | if (count < 0) { 98 | 99 | # All actors created. 100 | actorMb 101 | } 102 | else { 103 | create_actors(count - 1, numActors, actorMb) 104 | } 105 | } 106 | 107 | ## Launcher. 108 | ## numActors : num actors 109 | ## numRounds: rounds (i.e. number of messages). 110 | def main(numActors: Int, numRounds: Int): Unit { 111 | 112 | let mainMb = new [ActorMb] in 113 | init_ring(numActors, mainMb); 114 | 115 | guard mainMb: Data + 1 { 116 | free -> () 117 | receive Data(firstActorMb) from mainMb -> 118 | firstActorMb ! Ping(numRounds); 119 | free(mainMb) 120 | } 121 | } 122 | 123 | main(5, 1000) 124 | -------------------------------------------------------------------------------- /test/examples/robotsn.pat: -------------------------------------------------------------------------------- 1 | interface Door { 2 | Want(Int, Robot!), 3 | Inside(Robot!), 4 | Prepared(Warehouse!), 5 | WantLeave(Robot!), 6 | Outside(), 7 | TableIdle(Warehouse!) 8 | } 9 | 10 | interface Robot { 11 | GoIn(Door!), 12 | GoOut(Door!), 13 | Busy(), 14 | Delivered(Warehouse!, Door!) 15 | } 16 | 17 | interface Warehouse { 18 | Prepare(Int, Door!), 19 | Deliver(Robot!, Door!), 20 | PartTaken() 21 | } 22 | 23 | # Door 24 | def freeDoor(self: Door?, warehouse: Warehouse!): Unit { 25 | guard self : Want* { 26 | free -> () 27 | receive Want(part, robot) from self -> 28 | robot ! GoIn(self); 29 | warehouse ! Prepare(part, self); 30 | busyDoor(self) 31 | } 32 | } 33 | 34 | def busyDoor(self: Door?): Unit { 35 | guard self : Inside . Prepared . Want* { 36 | receive Want(partNum, robot) from self -> 37 | robot ! Busy(); 38 | busyDoor(self) 39 | receive Inside(robot) from self -> 40 | guard self : Prepared . Want* { 41 | receive Prepared(warehouse) from self -> 42 | warehouse ! Deliver(robot, self); 43 | guard self : WantLeave . TableIdle . Want* { 44 | receive WantLeave(robot) from self -> 45 | robot ! GoOut(self); 46 | finaliseDoor(self, warehouse) 47 | } 48 | } 49 | } 50 | } 51 | 52 | def finaliseDoor(self: Door?, warehouse: Warehouse!): Unit { 53 | guard self : Outside . TableIdle . Want* { 54 | receive Outside() from self -> 55 | guard self : TableIdle . Want* { 56 | receive TableIdle(warehouse) from self -> 57 | freeDoor(self, warehouse) 58 | } 59 | receive TableIdle(warehouse) from self -> 60 | guard self : Outside . Want* { 61 | receive Outside() from self -> 62 | freeDoor(self, warehouse) 63 | } 64 | } 65 | } 66 | 67 | # Robot 68 | def idleRobot(self: Robot?, door: Door!): Unit { 69 | door ! Want(0, self); 70 | guard self : (Busy + GoIn) { 71 | receive Busy() from self -> free(self) 72 | receive GoIn(door) from self -> 73 | door ! Inside(self); 74 | insideRobot(self) 75 | } 76 | } 77 | 78 | def insideRobot(self: Robot?): Unit { 79 | let self = 80 | guard self : Delivered { 81 | receive Delivered(warehouse, door) from self -> 82 | warehouse ! PartTaken(); 83 | door ! WantLeave(self); 84 | self 85 | } 86 | in 87 | guard self : GoOut { 88 | receive GoOut(door) from self -> 89 | door ! Outside(); 90 | free(self) 91 | } 92 | } 93 | 94 | # Warehouse 95 | def freeWarehouse(self: Warehouse?): Unit { 96 | guard self : Prepare + 1 { 97 | free -> () 98 | receive Prepare(partNum, door) from self -> 99 | door ! Prepared(self); 100 | preparedWarehouse(self) 101 | } 102 | } 103 | 104 | def preparedWarehouse(self: Warehouse?): Unit { 105 | guard self : Deliver { 106 | receive Deliver(robot, door) from self -> 107 | robot ! Delivered(self, door); 108 | handlePartTaken(self, door) 109 | } 110 | } 111 | 112 | def handlePartTaken(self: Warehouse?, door: Door!): Unit { 113 | guard self : PartTaken { 114 | receive PartTaken() from self -> 115 | door ! TableIdle(self); 116 | freeWarehouse(self) 117 | } 118 | } 119 | 120 | 121 | def main(): Unit { 122 | let robot1 = new[Robot] in 123 | let robot2 = new[Robot] in 124 | let robot3 = new[Robot] in 125 | let door = new[Door] in 126 | let warehouse = new[Warehouse] in 127 | spawn { freeDoor(door, warehouse) }; 128 | spawn { idleRobot(robot1, door) }; 129 | spawn { idleRobot(robot2, door) }; 130 | spawn { idleRobot(robot3, door) }; 131 | spawn { freeWarehouse(warehouse) } 132 | } 133 | 134 | main() 135 | -------------------------------------------------------------------------------- /lib/common/errors.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Source_code 3 | 4 | (* Auxiliary definitions / types *) 5 | type subsystem = 6 | | GenSubtype 7 | | GenIntersect 8 | | GenJoin 9 | | GenCombine 10 | | GenSynth 11 | | GenCheck 12 | | GenCheckGuard 13 | | GenCheckDecls 14 | 15 | let show_subsystem = function 16 | | GenSubtype -> "Subtype" 17 | | GenJoin -> "Join" 18 | | GenCombine -> "Combine" 19 | | GenIntersect -> "Intersect" 20 | | GenSynth -> "Synth" 21 | | GenCheck -> "Check" 22 | | GenCheckGuard -> "Check guard" 23 | | GenCheckDecls -> "Check declarations" 24 | 25 | (* Exceptions *) 26 | exception Parse_error of string * Position.t list 27 | exception Pretype_error of string * Position.t list 28 | exception Type_error of string * Position.t list (* Used for errors common to both pretyping and constraint generation *) 29 | exception Constraint_gen_error of { subsystem: subsystem option; message: string; pos_list: Position.t list } 30 | (* It would be a bit nicer to have the constraints on the LHS and RHS here, 31 | but it would introduce a cyclic library dependency. *) 32 | exception Constraint_solver_error of { lhs: string; rhs: string } 33 | exception Constraint_solver_zero_error of string 34 | exception Internal_error of { filename: string; message: string } 35 | exception Bad_receive_typing_argument of string 36 | exception Transform_error of string * Position.t list 37 | 38 | 39 | let internal_error filename message = Internal_error { filename; message } 40 | let parse_error msg pos_list = Parse_error (msg, pos_list) 41 | let type_error message pos_list = Type_error (message, pos_list) 42 | let constraint_solver_error lhs rhs = Constraint_solver_error { lhs; rhs } 43 | let constraint_solver_zero_error var = Constraint_solver_zero_error var 44 | let bad_receive_typing_argument bad = Bad_receive_typing_argument bad 45 | let transform_error err pos_list = Transform_error (err, pos_list) 46 | 47 | (* Will likely be more interesting when we have positional information *) 48 | let format_error = function 49 | | Internal_error { filename; message } -> 50 | let note = Printf.sprintf "INTERNAL (%s)" filename in 51 | Utility.print_error ~note message 52 | | Parse_error (s, pos_list) -> 53 | let pos_info = Position.format_pos pos_list in 54 | Utility.print_error ~note:"PARSE" (s ^ " \n " ^ pos_info) 55 | | Pretype_error (s, pos_list) -> 56 | let pos_info = Position.format_pos pos_list in 57 | Utility.print_error ~note:"PRETYPE" (s ^ " \n " ^ pos_info) 58 | | Transform_error (s, pos_list) -> 59 | let pos_info = Position.format_pos pos_list in 60 | Utility.print_error ~note:"TRANSFORM" (s ^ " \n " ^ pos_info) 61 | | Type_error (s, pos_list) -> 62 | let pos_info = Position.format_pos pos_list in 63 | Utility.print_error ~note:"TYPE" (s ^ " \n " ^ pos_info) 64 | | Constraint_gen_error { subsystem; message; pos_list } -> 65 | let note = 66 | match subsystem with 67 | | Some subsystem -> 68 | Printf.sprintf 69 | "CONSTRAINT GENERATION (%s)" 70 | (show_subsystem subsystem) 71 | | None -> "CONSTRAINT GENERATION" 72 | in 73 | let pos_info = Position.format_pos pos_list in 74 | Utility.print_error ~note (message ^ " \n " ^ pos_info) 75 | | Constraint_solver_error { lhs; rhs } -> 76 | let msg = 77 | Printf.sprintf 78 | "%s is not included in %s" 79 | lhs rhs 80 | in 81 | Utility.print_error ~note:"CONSTRAINT SOLVING" (msg ^ " \n ") 82 | | Constraint_solver_zero_error var -> 83 | let msg = 84 | Printf.sprintf 85 | "Pattern variable %s was solved as pattern 0. This can happen when only part of a program is written. Consider finishing the program or adding a type annotation." 86 | var 87 | in 88 | Utility.print_error ~note:"CONSTRAINT SOLVING" msg 89 | | Bad_receive_typing_argument bad -> 90 | Printf.sprintf 91 | "%s is not a valid receive typing strategy (allowed: strict, interface, none)" 92 | bad 93 | |> Utility.print_error 94 | | e -> 95 | Utility.print_error (Printexc.to_string e) 96 | 97 | -------------------------------------------------------------------------------- /test/examples/savina/philosopher.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/philosopher 2 | ### 3 | ### Dining philosophers problem. 4 | 5 | interface PhilosopherMb { 6 | Start(), 7 | Denied(), 8 | Eat() 9 | } 10 | 11 | interface ArbiterMb { 12 | Hungry(PhilosopherMb!, Int), 13 | Done(Int), 14 | Exit() 15 | } 16 | 17 | ## Philosopher process handling the launching of main loop. 18 | def philosopher(self: PhilosopherMb?, id: Int, numRounds: Int, arbiterMb: ArbiterMb!): Unit { 19 | guard self: Start { 20 | receive Start() from self -> 21 | philosopher_loop(self, id, numRounds, arbiterMb) 22 | } 23 | } 24 | 25 | ## Philosopher process main loop issuing hunger requests. 26 | def philosopher_loop(self: PhilosopherMb?, id: Int, numRounds: Int, arbiterMb: ArbiterMb!): Unit { 27 | 28 | arbiterMb ! Hungry(self, id); 29 | 30 | guard self: Denied + Eat + 1 { 31 | free -> () 32 | receive Denied() from self -> 33 | philosopher_loop(self, id, numRounds, arbiterMb) 34 | receive Eat() from self -> 35 | arbiterMb ! Done(id); 36 | 37 | if (numRounds <= 0) { 38 | arbiterMb ! Exit(); 39 | free(self) 40 | } 41 | else { 42 | philosopher_loop(self, id, numRounds - 1, arbiterMb) 43 | } 44 | } 45 | } 46 | 47 | ## Arbiter process managing the allocation and deallocation of forks to 48 | ## philosopher processes, as well as coordinating their termination. 49 | def arbiter(self: ArbiterMb?, numExitedPhilosophers: Int, fork1: Bool, fork2: Bool): Unit { 50 | guard self: (Hungry + Done + Exit)* { 51 | free -> 52 | () 53 | receive Hungry(philosopherMb, philosopherId) from self -> 54 | 55 | if (forks_available(philosopherId, fork1, fork2)) { 56 | 57 | # Notify philosopher and update fork allocation for specified 58 | # philosopher ID. 59 | philosopherMb ! Eat(); 60 | allocate_forks(philosopherId, fork1, fork2); 61 | arbiter(self, numExitedPhilosophers, fork1, fork2) 62 | } 63 | else { 64 | 65 | # One or both forks occupied. 66 | philosopherMb ! Denied(); 67 | arbiter(self, numExitedPhilosophers, fork1, fork2) 68 | } 69 | 70 | receive Done(philosopherId) from self -> 71 | 72 | # Reset fork allocation. 73 | deallocate_forks(philosopherId, fork1, fork2); 74 | arbiter(self, numExitedPhilosophers, fork1, fork2) 75 | 76 | receive Exit() from self -> 77 | 78 | if (numExitedPhilosophers <= 0) { 79 | arbiter_exit(self) 80 | } 81 | else { 82 | arbiter(self, numExitedPhilosophers - 1, fork1, fork2) 83 | } 84 | } 85 | } 86 | 87 | ## Stub. Checks whether the forks for the specified philosopher ID are 88 | ## available. 89 | def forks_available(id: Int, fork1: Bool, fork2: Bool): Bool { 90 | true 91 | } 92 | 93 | ## Stub. Toggles the Boolean values of the fork variables to indicate that they 94 | ## are in use by the philosopher with the specified ID. 95 | def allocate_forks(id: Int, fork1: Bool, fork2: Bool): Unit { 96 | () 97 | } 98 | 99 | ## Stub. Toggles the Boolean values of the fork variables to indicate that they 100 | ## are relinquished by the philosopher with the specified ID. 101 | def deallocate_forks(id: Int, fork1: Bool, fork2: Bool): Unit { 102 | () 103 | } 104 | 105 | ## Arbiter process exit procedure flushing potential residual messages. 106 | def arbiter_exit(self: ArbiterMb?): Unit { 107 | guard self: (Hungry + Done + Exit)* { 108 | free -> () 109 | receive Hungry(philosopherMb, philosopherId) from self -> 110 | arbiter_exit(self) 111 | receive Done(id) from self -> 112 | arbiter_exit(self) 113 | receive Exit() from self -> 114 | arbiter_exit(self) 115 | } 116 | } 117 | 118 | ## Launcher. 119 | def main(numRounds: Int): Unit { 120 | 121 | let arbiterMb = new [ArbiterMb] in 122 | spawn { arbiter(arbiterMb, 2, false, false) }; 123 | 124 | let philosopherMb1 = new [PhilosopherMb] in 125 | spawn { philosopher(philosopherMb1, 0, numRounds, arbiterMb) }; 126 | philosopherMb1 ! Start(); 127 | 128 | let philosopherMb2 = new [PhilosopherMb] in 129 | spawn { philosopher(philosopherMb2, 0, numRounds, arbiterMb) }; 130 | philosopherMb2 ! Start() 131 | } 132 | 133 | main(5) 134 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/account_future.pat: -------------------------------------------------------------------------------- 1 | 2 | # Mailbox message interfaces. 3 | interface AccountMb { 4 | Debit(Int, FutureMb!), 5 | Credit(Int, AccountMb!, FutureMb!), 6 | Stop() 7 | } 8 | 9 | interface FutureMb { 10 | Reply() 11 | } 12 | 13 | # Issues a debit request to the recipient account with the specified amount. 14 | # 15 | # amount: Amount to debit. 16 | # recipient: Mailbox where the debit request is deposited. 17 | # 18 | # Returns: Mailbox handle. 19 | def await(amount: Int, recipient: AccountMb!): FutureMb? { 20 | let future = new [FutureMb] in 21 | spawn { recipient ! Debit(amount, future) }; 22 | future 23 | } 24 | 25 | # Blocks until an acknowledgement is deposited in the specified mailbox. 26 | # 27 | # future: Mailbox where the acknowledgement from the recipient account is 28 | # deposited. 29 | # 30 | # An account can be terminated at any moment by other processes. In such cases, 31 | # it is possible for pending debit requests not to be acknowledged. The function 32 | # caters for this possibility and outputs a warning, but does not block the 33 | # caller. 34 | # 35 | # Returns: Unit value. 36 | def resume(future: FutureMb?): Unit { 37 | # Reply + 1 handles the case when the Debit request issued by the function 38 | # await/2 remains without a Reply when another account issues a Stop request 39 | # to the same account the Debit was directed, and the account shuts down, 40 | # leaving the Debit request unacknowledged. 41 | guard future: Reply + 1 { 42 | free -> 43 | print("WARN: Did not receive Reply ack from account!") 44 | receive Reply() from future -> 45 | free(future) 46 | } 47 | } 48 | 49 | # Empties the specified account mailbox of stale messages. 50 | # 51 | # account: Account mailbox to flush. 52 | # stale: Count of stale messages flushed. 53 | # 54 | # Returns: Count of stale messages. 55 | def flush(account: AccountMb?, stale: Int): Int { 56 | guard account: Debit* . Credit* { 57 | free -> stale 58 | receive Debit(amount, sender) from account -> 59 | flush(account, stale + 1) 60 | receive Credit(amount, recipient, sender) from account -> 61 | flush(account, stale + 1) 62 | } 63 | } 64 | 65 | # Account server loop handling incoming instructions. 66 | # 67 | # self: Mailbox where account instructions are deposited. 68 | # balance: Account balance. Permitted to be +ve or -ve. 69 | # 70 | # Returns: Unit value. 71 | def account(self: AccountMb?, balance: Int): Unit { 72 | guard self: (Debit* . Credit*) . Stop { 73 | receive Debit(amount, sender) from self -> 74 | sender ! Reply(); 75 | account(self, balance + amount) 76 | receive Credit(amount, recipient, sender) from self -> 77 | 78 | # Issue blocking Debit request and wait for reply. 79 | let future = await(amount, recipient) in 80 | resume(future); 81 | 82 | # Communicate to sender that Credit instruction was successful and 83 | # update account accordingly. 84 | sender ! Reply(); 85 | account(self, balance - amount) 86 | receive Stop() from self -> 87 | print("INFO: Terminating account."); 88 | 89 | # Terminating the server potentially leaves queued Debit and Credit 90 | # instructions in mailbox. Flush empty mailbox and print count of 91 | # stale messages, if any. 92 | let stale = flush(self, 0) in 93 | if (stale > 0) { 94 | print("WARN: Flushed "); 95 | print(intToString(stale)); 96 | print(" message(s)!") 97 | } 98 | else { 99 | () 100 | } 101 | } 102 | } 103 | 104 | # Launcher. 105 | def main(): Unit { 106 | 107 | # Create Alice's and Bob's accounts. 108 | let alice = new [AccountMb] in 109 | spawn { account(alice, 5) }; 110 | 111 | let bob = new [AccountMb] in 112 | spawn { account(bob, 20) }; 113 | 114 | # Instruct Bob to credit alice. 115 | let self = new [FutureMb] in 116 | bob ! Credit(20, alice, self); 117 | 118 | # Receive acknowledgement (if any, see resume/1 for details) for Credit 119 | # transaction. 120 | resume(self); 121 | 122 | # Stop Alice's and Bob's accounts. 123 | alice ! Stop(); 124 | bob ! Stop() 125 | } 126 | 127 | main() 128 | -------------------------------------------------------------------------------- /test/examples/savina/cig_smok.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/cigsmok. 2 | ### 3 | ### A benchmark modelling n smokers and one arbiter that decides which smoker to 4 | ### allow to smoke. The benchmark is parameterized by the number of smoker 5 | ### processes. Since the array type is not available in Pat, we fix the number 6 | ### of account processes to 3. 7 | 8 | interface ArbiterMb { 9 | Start(), 10 | StartedSmoking() 11 | } 12 | 13 | interface SmokerMb { 14 | StartSmoking(Int), 15 | Exit() 16 | } 17 | 18 | ## Arbiter process handling the creation of smokers and launching of main loop. 19 | def arbiter(self: ArbiterMb?, numRounds: Int): Unit { 20 | 21 | let smokerMb1 = new [SmokerMb] in 22 | spawn { smoker(smokerMb1, self) }; 23 | 24 | let smokerMb2 = new [SmokerMb] in 25 | spawn { smoker(smokerMb2, self) }; 26 | 27 | let smokerMb3 = new [SmokerMb] in 28 | spawn { smoker(smokerMb3, self) }; 29 | 30 | guard self: Start . StartedSmoking* { 31 | receive Start() from self -> 32 | 33 | notify_smoker(smokerMb1, smokerMb2, smokerMb3); 34 | arbiter_loop(self, numRounds, smokerMb1, smokerMb2, smokerMb3) 35 | } 36 | } 37 | 38 | ## Randomly chooses the smoker and requests it to smoke. 39 | def notify_smoker(smokerMb1: SmokerMb!, smokerMb2: SmokerMb!, smokerMb3: SmokerMb!): Unit { 40 | 41 | let smokerId = rand(2) in 42 | let sleepTimeMs = 1000 in 43 | 44 | if (smokerId == 0) { 45 | smokerMb1 ! StartSmoking(rand(sleepTimeMs)) 46 | } 47 | else { 48 | if (smokerId == 1) { 49 | smokerMb2 ! StartSmoking(rand(sleepTimeMs)) 50 | } 51 | else { 52 | smokerMb3 ! StartSmoking(rand(sleepTimeMs)) 53 | } 54 | } 55 | } 56 | 57 | ## Notifies all smokers to terminate. 58 | def notify_smoker_exit(smokerMb1: SmokerMb!, smokerMb2: SmokerMb!, smokerMb3: SmokerMb!): Unit { 59 | smokerMb1 ! Exit(); 60 | smokerMb2 ! Exit(); 61 | smokerMb3 ! Exit() 62 | } 63 | 64 | ## Arbiter process main loop issuing start smoking requests and handling started 65 | ## smoking replies. 66 | def arbiter_loop(self: ArbiterMb?, numRounds: Int, smokerMb1: SmokerMb!, smokerMb2: SmokerMb!, smokerMb3: SmokerMb!): Unit { 67 | guard self: StartedSmoking* { 68 | free -> 69 | () 70 | receive StartedSmoking() from self -> 71 | 72 | # The if here introduces the internal choice, which means that on the 73 | # receiver side I might or might not receive the message. In this case, 74 | # the smoker might or might nor receive the Exit message, and must either 75 | # use (Exit + 1) or (Exit*) in its pattern. 76 | 77 | if (numRounds <= 0) { 78 | notify_smoker_exit(smokerMb1, smokerMb2, smokerMb3) 79 | } 80 | else { 81 | notify_smoker(smokerMb1, smokerMb2, smokerMb3) 82 | }; 83 | 84 | # Arbiter needs to service all requests before, even if it has sent the 85 | # Exit messages to smokers. Remember that smokers may still be processing 86 | # StartSmoking messages, but the arbiter has already issued Exit messages 87 | # and it still needs to await all the StartedSmoking replies before 88 | # terminating. This is why we do not have an exit_arbiter flush function. 89 | arbiter_loop(self, numRounds - 1, smokerMb1, smokerMb2, smokerMb3) 90 | } 91 | } 92 | 93 | ## Smoker process main loop handling start smoking requests and issuing started 94 | ## smoking replies to/from the arbiter. 95 | def smoker(self: SmokerMb?, arbiterMb: ArbiterMb!): Unit { 96 | # Smoker may be asked to smoke more than once, or none. This is why the *. 97 | guard self: StartSmoking* . Exit* { 98 | free -> 99 | () # Since the smoker might not even receive an Exit/StartSmoking message due to the if condition above. 100 | receive StartSmoking(ms) from self -> 101 | arbiterMb ! StartedSmoking(); 102 | sleep(ms); 103 | smoker(self, arbiterMb) 104 | receive Exit() from self -> 105 | smoker_exit(self) 106 | } 107 | } 108 | 109 | ## Smoker process exit procedure that flushes potential residual messages. 110 | def smoker_exit(self: SmokerMb?): Unit { 111 | guard self: StartSmoking* . Exit* { 112 | free -> () # In case I have one or more Exit/StartSmoking messages due to the if condition above. 113 | receive StartSmoking(ms) from self -> 114 | smoker_exit(self) 115 | receive Exit() from self -> 116 | smoker_exit(self) 117 | } 118 | } 119 | 120 | ## Launcher. 121 | def main(): Unit { 122 | 123 | let arbiterMb = new [ArbiterMb] in 124 | spawn { arbiter(arbiterMb, 10) }; 125 | 126 | arbiterMb ! Start() 127 | } 128 | 129 | main() 130 | -------------------------------------------------------------------------------- /lib/frontend/insert_pattern_variables.ml: -------------------------------------------------------------------------------- 1 | (* Annotation *) 2 | (* Annotation takes partially-defined mailbox types (i.e., MB types with 3 | * interface information but no pattern annotations) and annotates them with 4 | * fresh pattern variables so that we can generate constraints. 5 | * This is done for all types that are in binding position. *) 6 | (* Additionally, for interfaces, sets the quasilinearity to Usable. *) 7 | open Common 8 | open Sugar_ast 9 | open Source_code 10 | 11 | let rec annotate_type = 12 | let open Type in 13 | function 14 | | Base t -> Base t 15 | | Fun { linear; args; result } -> 16 | Fun { 17 | linear; 18 | args = List.map annotate_type args; 19 | result = annotate_type result 20 | } 21 | | Tuple ts -> 22 | Tuple (List.map annotate_type ts) 23 | | Sum (t1, t2) -> 24 | Sum (annotate_type t1, annotate_type t2) 25 | | Mailbox { pattern = Some _; _ } as mb -> mb 26 | | Mailbox { capability; interface; pattern = None; quasilinearity } -> 27 | Mailbox { 28 | capability; 29 | interface; 30 | pattern = Some (Pattern.fresh ()); 31 | quasilinearity 32 | } 33 | 34 | let annotate_interface_type = 35 | let open Type in 36 | function 37 | (* Outermost MB types (i.e., payloads) are treated as usable. *) 38 | | Mailbox { pattern = Some _; _ } as mb -> mb 39 | | Mailbox { capability; interface; pattern = None; _ } -> 40 | Mailbox { 41 | capability; 42 | interface; 43 | pattern = Some (Pattern.fresh ()); 44 | quasilinearity = Quasilinearity.Usable 45 | } 46 | | t -> annotate_type t 47 | 48 | (* Annotates all types in an interface *) 49 | let annotate_interface iface = 50 | Interface.bindings iface 51 | |> List.map (fun (tag, tys) -> (tag, List.map annotate_interface_type tys)) 52 | |> Interface.(make (name iface)) 53 | 54 | (* The visitor traverses the AST to annotate parameters of higher-order 55 | functions. *) 56 | let visitor = 57 | object(self) 58 | inherit [_] Sugar_ast.map as super 59 | 60 | method! visit_decl env decl = 61 | { decl with 62 | decl_parameters = 63 | List.map (fun (x, t) -> (x, annotate_type t)) 64 | decl.decl_parameters; 65 | decl_return_type = annotate_type decl.decl_return_type; 66 | decl_body = self#visit_expr env decl.decl_body } 67 | 68 | method! visit_expr env expr_with_pos = 69 | let open Sugar_ast in 70 | let expr = WithPos.node expr_with_pos in 71 | match expr with 72 | | Annotate (e, ty) -> 73 | let new_e = self#visit_expr env e in 74 | let new_annotate = Annotate (new_e, annotate_type ty) in 75 | { expr_with_pos with node = new_annotate } 76 | | Lam { linear; parameters; result_type; body } -> 77 | let parameters = 78 | List.map (fun (x, y) -> (x, annotate_type y)) parameters in 79 | let result_type = annotate_type result_type in 80 | let new_body = self#visit_expr env body in 81 | let new_lam = Lam { linear; parameters; result_type; body = new_body } in 82 | { expr_with_pos with node = new_lam } 83 | | _ -> super#visit_expr env expr_with_pos 84 | 85 | method! visit_program env p = 86 | let prog_interfaces = 87 | List.map annotate_interface (WithPos.extract_list_node p.prog_interfaces) in 88 | let prog_interfaces_with_pos = 89 | List.map2 (fun iface pos -> WithPos.make ~pos iface) prog_interfaces (List.map WithPos.pos p.prog_interfaces) in 90 | let prog_decls = 91 | let (poses, nodes) = WithPos.split_with_pos_list p.prog_decls in 92 | let visited_nodes = self#visit_list (self#visit_decl) env nodes in 93 | WithPos.combine_with_pos_list poses visited_nodes in 94 | let prog_body = 95 | self#visit_option (self#visit_expr) env p.prog_body in 96 | { prog_interfaces = prog_interfaces_with_pos; prog_decls; prog_body } 97 | 98 | end 99 | 100 | let annotate prog = 101 | let prog = visitor#visit_program () prog in 102 | Settings.if_verbose (fun () -> 103 | Format.(fprintf std_formatter "=== Annotated Program ===\n%a\n\n" 104 | Sugar_ast.pp_program prog)); 105 | prog 106 | 107 | -------------------------------------------------------------------------------- /test/examples/de_liguoro_padovani/master_worker.pat: -------------------------------------------------------------------------------- 1 | 2 | # In Pat, mailbox interfaces are defined from the point of view of the 3 | # receiving end of the mailbox. 4 | 5 | 6 | # Mailbox message interfaces. 7 | interface MasterMb { 8 | Task(ClientMb!, Int) 9 | } 10 | 11 | interface PoolMb { 12 | Result(Int) 13 | } 14 | 15 | interface WorkerMb { 16 | Work(PoolMb!, Int) 17 | } 18 | 19 | interface ClientMb { 20 | Result(Int) 21 | } 22 | 23 | # Master server loop handling incoming client tasks. 24 | # 25 | # self: Master mailbox where client tasks are deposited. 26 | # 27 | # Returns: Unit value. 28 | def master(self: MasterMb?): Unit { 29 | guard self: Task* { 30 | free -> () # No more tasks to handle. 31 | receive Task(replyTo, n) from self -> 32 | 33 | # Create a local throwaway mailbox used by the master to farm tasks 34 | # and collect results. 35 | let pool = new[PoolMb] in 36 | 37 | # Farm the number of tasks 'n'. 38 | farm(0, n, pool); 39 | 40 | # Block until all the results are computed by each worker and 41 | # communicate result to client. 42 | let result = harvest(0, pool) in 43 | replyTo ! Result(result); 44 | 45 | # Service next task in mailbox. 46 | master(self) 47 | } 48 | } 49 | 50 | # Worker computing assigned task by master. 51 | # 52 | # self: Worker mailbox where task is deposited. 53 | # 54 | # Returns: Unit value. 55 | def worker(self: WorkerMb?): Unit { 56 | guard self: Work { 57 | receive Work(replyTo, n) from self -> 58 | replyTo ! Result(compute(n)); 59 | free(self) 60 | } 61 | } 62 | 63 | # Distributes tasks between worker processes. 64 | # 65 | # count: Current task index/value. 66 | # chunks: Number of segments the client task consists of. 67 | # pool: Mailbox to which results from workers are to be communicated. 68 | # 69 | # Returns: Unit value. 70 | def farm(count: Int, chunks: Int, pool: PoolMb!): Unit { 71 | if (count == chunks) { 72 | # chunks 73 | () 74 | } 75 | else { 76 | 77 | # Fabricate simple work task chunk to assign to worker. 78 | let task = count + 1 in 79 | 80 | # Create worker and assign chunk. 81 | let workerMb = new[WorkerMb] in 82 | spawn { worker(workerMb) }; 83 | workerMb ! Work(pool, task); 84 | 85 | farm(task, chunks, pool) 86 | } 87 | } 88 | 89 | # Collects and sums the individual results of the tasks assigned to workers. 90 | # 91 | # count: Current task index. 92 | # chunks: Number of work result chunks to expect. Dead parameter for not (see 93 | # question below). 94 | # acc: Accumulator holding the intermediate summation of results from workers. 95 | # pool: Mailbox where the worker results are deposited. 96 | # 97 | # Returns: Accumulated total. 98 | def harvest(acc: Int, pool: PoolMb?): Int { 99 | guard pool: Result* { 100 | free -> 101 | # We do not keep track of the expected number of chunks since this 102 | # is something that is done automatically by the runtime. The fact 103 | # that we create a local mailbox pool enables the runtime to track 104 | # the number of times the mailbox has been shared with processes. 105 | # By reference counting, the runtime is able to assert that when the 106 | # free branch becomes available, there are no more results in the 107 | # pool mailbox, which implies that all the work chunk replies have 108 | # been accounted for, and none where lost or duplicated. The 109 | # commented code shown below re-performs this check, and is 110 | # redundant. 111 | acc 112 | 113 | receive Result(n) from pool -> 114 | harvest(acc + n, pool) 115 | } 116 | } 117 | 118 | # What if I want to exactly count the number of replies I expect. This is more 119 | # stringent than merely using *. Can I do this? Or rather, am I prevented from 120 | # doing so? 121 | 122 | # Models a complex computation that a worker performs. 123 | # 124 | # n: Some task. 125 | # 126 | # Returns: Result. 127 | def compute(n: Int): Int { 128 | n * n 129 | } 130 | 131 | # Client issuing one (numerical) task to the master. 132 | # 133 | # n: Some task. 134 | # self: Mailbox where the result from the master is deposited. 135 | # masterMb: Master mailbox to where the request is directed. 136 | # 137 | # Returns: Unit value. 138 | def client(n: Int, self: ClientMb?, masterMb: MasterMb!): Unit { 139 | masterMb ! Task(self, n); 140 | guard self: Result { 141 | receive Result(result) from self -> 142 | free(self); 143 | print(intToString(result)) 144 | } 145 | } 146 | 147 | # Launcher. 148 | def main(): Unit { 149 | 150 | let masterMb = new[MasterMb] in 151 | spawn { master(masterMb) }; 152 | 153 | let client1 = new[ClientMb] in 154 | spawn { client(5, client1, masterMb) }; 155 | 156 | let client2 = new[ClientMb] in 157 | spawn { client(10, client2, masterMb) } 158 | } 159 | 160 | main() 161 | -------------------------------------------------------------------------------- /lib/typecheck/z3_solver.ml: -------------------------------------------------------------------------------- 1 | (* Translates a Presburger formula into a Z3 expression, and checks its satisfiability. *) 2 | open Z3 3 | open Util.Utility 4 | 5 | (* Timeout used for Z3: 10 seconds *) 6 | let z3_timeout = 10000 7 | 8 | (* The Z3 quantifier API is so horrible that we need some helpers... *) 9 | (* Translates an existential quantifier, adding defaults for the unneeded arguments. *) 10 | let mk_quantifier_simple mk_fn ctx sorts symbs body = 11 | mk_fn ctx sorts symbs body (Some 1) [] [] None None 12 | |> Quantifier.expr_of_quantifier 13 | 14 | (* Translates an existential quantifier for the simple case that we have a single 15 | integer variable.*) 16 | let mk_quantifier_int mk_fn ctx symb body = 17 | mk_quantifier_simple 18 | mk_fn 19 | ctx 20 | [Arithmetic.Integer.mk_sort ctx] 21 | [Symbol.mk_string ctx symb] 22 | body 23 | 24 | let mk_exists_int = mk_quantifier_int Quantifier.mk_exists 25 | 26 | let mk_forall_int = mk_quantifier_int Quantifier.mk_forall 27 | 28 | (* Note that this is explicitly ANF'ed. I don't think it's entirely necessary, 29 | but since the operations are side-effecting, it's potentially worth it. *) 30 | let z3_of_presburger ctx = 31 | let open Presburger in 32 | let int_sort () = Arithmetic.Integer.mk_sort ctx in 33 | let mk_int = Arithmetic.Integer.mk_numeral_i ctx in 34 | 35 | (* Translation requires an explicit translation environment for bound names, 36 | and we also need to shift all existing variables under every forall binder. *) 37 | let rec translate_expr env = 38 | function 39 | | Var v -> 40 | let sort = int_sort () in 41 | Quantifier.mk_bound ctx (StringMap.find v env) sort 42 | | Int i -> mk_int i 43 | | Add (e1, e2) -> 44 | let e1 = translate_expr env e1 in 45 | let e2 = translate_expr env e2 in 46 | Arithmetic.mk_add ctx [e1; e2] 47 | | Mul (n, e) -> 48 | let e = translate_expr env e in 49 | Arithmetic.mk_mul ctx [mk_int n; e] 50 | in 51 | let rel_fn = function 52 | | EQ -> Boolean.mk_eq 53 | | LE -> Arithmetic.mk_le 54 | | LT -> Arithmetic.mk_lt 55 | in 56 | let shift_env env = StringMap.map (fun x -> x + 1) env in 57 | let rec translate env = function 58 | | True -> Boolean.mk_true ctx 59 | | False -> Boolean.mk_false ctx 60 | | Rel (rel, x1, x2) -> 61 | let x1 = translate_expr env x1 in 62 | let x2 = translate_expr env x2 in 63 | (rel_fn rel) ctx x1 x2 64 | | And (x1, x2) -> 65 | let x1 = translate env x1 in 66 | let x2 = translate env x2 in 67 | Boolean.mk_and ctx [x1; x2] 68 | | Or (x1, x2) -> 69 | let x1 = translate env x1 in 70 | let x2 = translate env x2 in 71 | Boolean.mk_or ctx [x1; x2] 72 | | Not x -> 73 | let x = translate env x in 74 | Boolean.mk_not ctx x 75 | | Forall (v, x) -> 76 | let env = StringMap.add v 0 (shift_env env) in 77 | let x = translate env x in 78 | mk_forall_int ctx v x 79 | | Exists (v, x) -> 80 | let env = StringMap.add v 0 (shift_env env) in 81 | let x = translate env x in 82 | mk_exists_int ctx v x 83 | in 84 | translate (StringMap.empty) 85 | 86 | let result_of_z3_result : Solver.status -> Solver_result.t = 87 | let open Solver_result in 88 | function 89 | | SATISFIABLE -> Satisfiable 90 | | UNSATISFIABLE -> Unsatisfiable 91 | | UNKNOWN -> Unknown 92 | 93 | let solve : Presburger.goal -> Solver_result.t = fun { tags; lhs; rhs } -> 94 | let ctx = mk_context 95 | [("model", "false"); ("proof", "false"); ("timeout", string_of_int z3_timeout)] 96 | in 97 | let expr = 98 | let open Presburger in 99 | List.fold_right 100 | (fun x acc -> Forall (x, acc)) 101 | tags 102 | (* Translate equivalent formulation of implication, so that the 103 | environment is correctly set *) 104 | (Or (Not lhs, rhs)) 105 | in 106 | let z3_expr = z3_of_presburger ctx expr in 107 | Common.Settings.if_debug (fun () -> 108 | Printf.printf "DEBUG -- Z3 PRESBURGER: %s\n" (Expr.to_string z3_expr) 109 | ); 110 | let params = Z3.Params.mk_params ctx in 111 | Z3.Params.add_int params (Z3.Symbol.mk_string ctx "timeout") 500; 112 | (* For some reason, we need to explicitly tell OCaml's Z3 which tactics 113 | to use (in our case, quantifier elimination followed by the quantifier-free 114 | linear integer arithmetic solver. 115 | 116 | I don't know why this is, and it took me 2 days to figure this out, but 117 | there you go. 118 | *) 119 | let tac1 = Tactic.mk_tactic ctx "qe" in 120 | let tac2 = Tactic.mk_tactic ctx "qflia" in 121 | let tac = Tactic.par_and_then ctx tac1 tac2 in 122 | let solver = Solver.mk_solver_t ctx tac in 123 | Z3.Solver.set_parameters solver params; 124 | Solver.check solver [z3_expr] 125 | |> result_of_z3_result 126 | 127 | -------------------------------------------------------------------------------- /test/examples/savina/big.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/big. 2 | ### 3 | ### A benchmark that implements a many-to-many message passing scenario. Several 4 | ### processes are spawned, each of which sends a ping message to the others, and 5 | ### responds with a pong message to any ping message it receives. The benchmark 6 | ### is parameterized by the number of processes. Since the array type is not 7 | ### available in Pat, we fix the number of processes to 3. 8 | 9 | interface ActorMb { 10 | Ping(Int), 11 | Pong(Int), 12 | Neighbors(ActorMb!, ActorMb!) 13 | } 14 | 15 | interface ExitMb { 16 | Exit() 17 | } 18 | 19 | interface SinkMb { 20 | Done(), 21 | Actors(ExitMb!, ExitMb!, ExitMb!) 22 | } 23 | 24 | ## Actor process handling the launching of main loop. 25 | def actor(self: ActorMb?, exitMb : ExitMb?, id: Int, sinkMb: SinkMb!): Unit { 26 | guard self: Neighbors . (Pong + Ping)* { 27 | receive Neighbors(actorMb1, actorMb2) from self -> 28 | actor_loop(self, exitMb, id, sinkMb, 100, actorMb1, actorMb2) 29 | } 30 | } 31 | 32 | ## Blocks actor process and awaits termination message. 33 | def await_exit(exitMb: ExitMb?): Unit { 34 | guard exitMb : Exit { 35 | receive Exit() from exitMb -> 36 | free(exitMb) 37 | } 38 | } 39 | 40 | ## Actor process main loop issuing ping requests and handling pong replies. 41 | def actor_loop(self: ActorMb?, exitMb: ExitMb?, 42 | id: Int, sinkMb: SinkMb!, numPings: Int, 43 | actorMb1: ActorMb!, actorMb2: ActorMb!): Unit { 44 | guard self : (Ping + Pong)* { 45 | free -> 46 | await_exit(exitMb) 47 | receive Ping(pingerId) from self -> 48 | 49 | # Reply to ping. 50 | send_pong(id, pingerId, actorMb1, actorMb2); 51 | actor_loop(self, exitMb, id, sinkMb, numPings, actorMb1, actorMb2) 52 | 53 | receive Pong(pongerId) from self -> 54 | 55 | if (numPings <= 0) { 56 | 57 | # No more pongs to issue. 58 | sinkMb ! Done(); 59 | actor_exit(self); 60 | await_exit(exitMb) 61 | } 62 | else { 63 | 64 | # Issue ping to random participant. 65 | send_ping(id, actorMb1, actorMb2); 66 | actor_loop(self, exitMb, id, sinkMb, numPings - 1, actorMb1, actorMb2) 67 | } 68 | } 69 | } 70 | 71 | ## Actor process exit procedure that flushes potential residual messages. 72 | def actor_exit(self: ActorMb?): Unit { 73 | guard self: Ping* . Pong* { 74 | free -> () 75 | receive Ping(pingerId) from self -> 76 | actor_exit(self) 77 | receive Pong(pongerId) from self -> 78 | actor_exit(self) 79 | } 80 | } 81 | 82 | ## Replies to ping messages via a pong issued to the specified actor ID. 83 | def send_pong(id: Int, pingerId: Int, actorMb1: ActorMb!, actorMb2: ActorMb!): Unit { 84 | 85 | # We are not synchronising here, but using IDs, which loses information. This 86 | # makes the type checker think that it might not receive the pong reply. Thus, 87 | # the type of the mailbox would be ?(Pong + 1). 88 | if (pingerId == 1) { 89 | actorMb1 ! Pong(id) 90 | } 91 | else { 92 | actorMb2 ! Pong(id) 93 | } 94 | } 95 | 96 | ## Randomly issues a ping message to one of the participating actors. 97 | def send_ping(id: Int, actorMb1: ActorMb!, actorMb2: ActorMb!): Unit { 98 | 99 | let pongerId = rand(2) in 100 | 101 | if (pongerId == 1) { 102 | actorMb1 ! Ping(id) 103 | } 104 | else { 105 | actorMb2 ! Ping(id) 106 | } 107 | } 108 | 109 | ## Sink process that coordinates actor termination. 110 | def sink(self: SinkMb?): Unit { 111 | guard self: Actors . Done* { 112 | receive Actors(exitMb1, exitMb2, exitMb3) from self -> 113 | sink_loop(self, exitMb1, exitMb2, exitMb3) 114 | } 115 | } 116 | 117 | ## Sink process main loop issuing termination messages. 118 | def sink_loop(self: SinkMb?, exitMb1: ExitMb!, exitMb2: ExitMb!, exitMb3: ExitMb!): Unit { 119 | guard self: Done* { 120 | free -> 121 | # Notify all actors. Placing the sends in this clause ensures that 122 | # each actor is notified once. 123 | exitMb1 ! Exit(); 124 | exitMb2 ! Exit(); 125 | exitMb3 ! Exit() 126 | receive Done() from self -> 127 | sink_loop(self, exitMb1, exitMb2, exitMb3) 128 | } 129 | } 130 | 131 | 132 | ## Launcher. 133 | def main(): Unit { 134 | 135 | let sinkMb = new [SinkMb] in 136 | spawn { sink(sinkMb) }; 137 | 138 | let actorMb1 = new [ActorMb] in # actorMb1: ?1 139 | let actorMb2 = new [ActorMb] in # actorMb2: ?1 140 | let actorMb3 = new [ActorMb] in # actorMb3: ?1 141 | let exitMb1 = new [ExitMb] in # exitMb1: ?1 142 | let exitMb2 = new [ExitMb] in # exitMb2: ?1 143 | let exitMb3 = new [ExitMb] in # exitMb3: ?1 144 | 145 | spawn { actor(actorMb1, exitMb1, 1, sinkMb) }; 146 | spawn { actor(actorMb2, exitMb2, 2, sinkMb) }; 147 | spawn { actor(actorMb3, exitMb3, 3, sinkMb) }; 148 | 149 | sinkMb ! Actors(exitMb1, exitMb2, exitMb3); 150 | 151 | actorMb1 ! Neighbors(actorMb2, actorMb3); # actorMb1: ?Neighbors 152 | actorMb2 ! Neighbors(actorMb1, actorMb3); # actorMb2: ?Neighbors 153 | actorMb3 ! Neighbors(actorMb1, actorMb2); # actorMb3: ?Neighbors 154 | 155 | actorMb1 ! Pong(0); # actorMb1: ?Neighbors . Pong 156 | actorMb2 ! Pong(0); # actorMb2: ?Neighbors . Pong 157 | actorMb3 ! Pong(0) # actorMb2: ?Neighbors . Pong 158 | } 159 | 160 | main() 161 | -------------------------------------------------------------------------------- /test/examples/savina/log_map.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/logmap 2 | ### 3 | ### Calculates the recurrence relation x_{n + 1} = r * x_n * (1 - x_n), where 4 | ### x is the term and r is the rate. 5 | 6 | interface MasterMb { 7 | Start(), 8 | Result(Int) 9 | } 10 | 11 | interface WorkerMb { 12 | NextTerm(), 13 | GetTerm(), 14 | ResultWorker(Int), 15 | Stop() 16 | } 17 | 18 | interface TermMb { 19 | Done(Int) 20 | } 21 | 22 | interface ComputerMb { 23 | Compute(TermMb!, Int), 24 | StopCompute() 25 | } 26 | 27 | ## Master process handling the creation of the worker and computer processes, 28 | ## in addition to launching the main loop. 29 | def master(self: MasterMb?, startRate: Int, increment: Int): Unit { 30 | 31 | let computerMb1 = new [ComputerMb] in 32 | let rate1 = startRate + (1 * increment) in 33 | spawn { computer(computerMb1, rate1) }; 34 | 35 | let workerMb1 = new [WorkerMb] in 36 | let startTerm1 = 1 * increment in 37 | spawn { worker(workerMb1, 1, self, computerMb1, startTerm1) }; 38 | 39 | let computerMb2 = new [ComputerMb] in 40 | let rate2 = startRate + (2 * increment) in 41 | spawn { computer(computerMb2, rate2) }; 42 | 43 | let workerMb2 = new [WorkerMb] in 44 | let startTerm2 = 2 * increment in 45 | spawn { worker(workerMb2, 2, self, computerMb2, startTerm2) }; 46 | 47 | guard self: Start . Result* { 48 | receive Start() from self -> 49 | 50 | # We should have a loop around this line to send multiple NextTerm 51 | # messages, according to the number of terms we send to computer. For 52 | # now, let this be 2. Later we can refactor it. 53 | workerMb1 ! NextTerm(); 54 | workerMb1 ! NextTerm(); 55 | workerMb2 ! NextTerm(); 56 | workerMb2 ! NextTerm(); 57 | workerMb2 ! NextTerm(); 58 | 59 | # Get result from worker as soon as finished. We should have many workers. 60 | # The number of workers is numWorkers and to each one, we send just one 61 | # request. 62 | workerMb1 ! GetTerm(); 63 | workerMb2 ! GetTerm(); 64 | 65 | # Collect results. 66 | master_loop(self, 0, workerMb1, computerMb1, workerMb2, computerMb2) 67 | } 68 | } 69 | 70 | ## Master process main loop issuing term computation requests. 71 | def master_loop(self: MasterMb?, termSum: Int, workerMb1: WorkerMb!, computerMb1: ComputerMb!, workerMb2: WorkerMb!, computerMb2: ComputerMb!): Unit { 72 | guard self: Result* { 73 | free -> 74 | # We need not track whether the number of requests sent and replies 75 | # received tallies. This is done implicitly by the type checker. 76 | 77 | # Notify workers and computers. 78 | workerMb1 ! Stop(); 79 | workerMb2 ! Stop(); 80 | computerMb1 ! StopCompute(); 81 | computerMb2 ! StopCompute(); 82 | 83 | # Print result. 84 | print(concat("Result is: ", intToString(termSum))) 85 | receive Result(term) from self -> 86 | 87 | # Accumulate computed term. 88 | master_loop(self, termSum + term, workerMb1, computerMb1, workerMb2, computerMb2) 89 | } 90 | } 91 | 92 | ## Worker process handling term computation requests, delegating them to 93 | ## computer processes. 94 | def worker(self: WorkerMb?, id: Int, masterMb: MasterMb!, computerMb: ComputerMb!, currTerm: Int): Unit { 95 | guard self: NextTerm* . GetTerm . Stop { 96 | receive NextTerm() from self -> 97 | 98 | # Delegate computation of term to computer process via the local mailbox 99 | # termMb. 100 | let termMb = new [TermMb] in 101 | computerMb ! Compute(termMb, currTerm); 102 | guard termMb: Done { 103 | receive Done(term) from termMb -> 104 | free(termMb); 105 | worker(self, id, masterMb, computerMb, term) 106 | } 107 | 108 | 109 | receive GetTerm() from self -> 110 | masterMb ! Result(currTerm); 111 | guard self: NextTerm* . Stop { 112 | receive Stop() from self -> 113 | worker_exit(self) 114 | } 115 | } 116 | } 117 | 118 | ## Worker process exit procedure flushing potential residual messages. 119 | def worker_exit(self: WorkerMb?): Unit { 120 | guard self: NextTerm* { 121 | free -> () 122 | receive NextTerm() from self -> 123 | worker_exit(self) 124 | } 125 | } 126 | 127 | ## Computer process handling computation requests delegated by an associated 128 | ## worker process. 129 | def computer(self: ComputerMb?, rate: Int): Unit { 130 | guard self: Compute* . StopCompute { 131 | free -> () 132 | receive Compute(termMb, term) from self -> 133 | 134 | # Compute next term. 135 | termMb ! Done(rate * term * (1 - term)); 136 | computer(self, rate) 137 | receive StopCompute() from self -> 138 | computer_exit(self) 139 | } 140 | } 141 | 142 | ## Computer process exit procedure flushing potential residual messages. 143 | def computer_exit(self: ComputerMb?): Unit { 144 | guard self: Compute* { 145 | free -> () 146 | receive Compute(termMb, term) from self -> 147 | 148 | # Send back the same term value so that the final computation on the 149 | # worker is kept fixed. 150 | termMb ! Done(term); 151 | computer_exit(self) 152 | } 153 | } 154 | 155 | ## Launcher. 156 | def main(): Unit { 157 | 158 | let masterMb = new [MasterMb] in 159 | spawn { master(masterMb, 3, 1) }; 160 | 161 | masterMb ! Start() 162 | } 163 | 164 | main() 165 | -------------------------------------------------------------------------------- /test/examples/savina/banking.pat: -------------------------------------------------------------------------------- 1 | ### Adapted from Savina/banking. 2 | ### 3 | ### A benchmark that implements a request-reply chain passing scenario. Several 4 | ### account processes are spawned, each of which may be sent a credit request 5 | ### by the central teller process. The benchmark is parameterized by the number 6 | ### of account processes. Since the array type is not available in Pat, we fix 7 | ### the number of account processes to 3. 8 | 9 | interface TellerMb { 10 | Start(), 11 | Reply() 12 | } 13 | 14 | interface AccountMb { 15 | Debit(AccountMb!, Int), 16 | Credit(TellerMb!, Int, AccountMb!), 17 | Done(), 18 | Stop() 19 | } 20 | 21 | ## Teller process handling the creation of account processes and launching of 22 | ## main loop. 23 | def teller(self: TellerMb?, numAccounts: Int): Unit { 24 | 25 | # Create accounts. 26 | let accountMb1 = new [AccountMb] in 27 | spawn { account(accountMb1, 1, 200) }; 28 | 29 | let accountMb2 = new [AccountMb] in 30 | spawn { account(accountMb2, 2, 150) }; 31 | 32 | let accountMb3 = new [AccountMb] in 33 | spawn { account(accountMb3, 3, 50) }; 34 | 35 | guard self: Start { 36 | receive Start() from self -> 37 | 38 | # Note. Even if the randomization of message sending is performed in a 39 | # different processes, there is no risk of a race condition where the 40 | # messages are sent to a non-existing mailbox. This is because, as can be 41 | # gleaned above, mailboxes are created in sequential fashion within this 42 | # (i.e., the teller) process. 43 | spawn { generate_work(self, numAccounts, accountMb1, accountMb2, accountMb3) } ; 44 | teller_loop(self, accountMb1, accountMb2, accountMb3) 45 | } 46 | } 47 | 48 | ## Randomly chooses the source account. 49 | def generate_work(tellerMb: TellerMb!, numAccounts: Int, acc1: AccountMb![R], acc2: AccountMb![R], acc3 : AccountMb![R]): Unit { 50 | 51 | # Randomly choose source account from which the funds shall be taken. 52 | let sourceId = rand(numAccounts - 1) in # -1 because rand() is 0-indexed. 53 | if (sourceId == 0) { 54 | 55 | # First source account. 56 | choose_dst_acc(tellerMb, numAccounts, acc1, acc2, acc3) 57 | } 58 | else { 59 | if (sourceId == 1) { 60 | 61 | # Second source account. 62 | choose_dst_acc(tellerMb, numAccounts, acc2, acc1, acc3) 63 | } 64 | else { 65 | 66 | # Third source account. 67 | choose_dst_acc(tellerMb, numAccounts, acc3, acc1, acc2) 68 | } 69 | } 70 | } 71 | 72 | ## Randomly chooses the destination account and issues a credit request. The 73 | ## function ensures that the source and destination account are different. 74 | def choose_dst_acc(tellerMb: TellerMb!, numAccounts: Int, srcAccountMb: AccountMb![R], dstAccountMb1: AccountMb![R], dstAccountMb2 : AccountMb![R]): Unit { 75 | 76 | # Randomly choose destination account to which funds shall be deposited. -2 77 | # because rand() is 0-indexed, and because we do not include the source 78 | # account in the random choice (i.e., the source account is not permitted to 79 | # send funds to itself). 80 | let dstAccountId = rand(numAccounts - 2) in 81 | 82 | let dstAccount = 83 | if (dstAccountId == 0) { 84 | dstAccountMb1 85 | } else { 86 | dstAccountMb2 87 | } 88 | in 89 | 90 | let amount = rand(200) in 91 | dstAccount ! Credit(tellerMb, amount, srcAccountMb) 92 | } 93 | 94 | ## Teller process main loop handling replies from accounts. 95 | def teller_loop(self: TellerMb?, accountMb1: AccountMb!, accountMb2: AccountMb!, accountMb3: AccountMb!): Unit { 96 | guard self: Reply* { 97 | free -> 98 | 99 | # All credit requests serviced. Stop accounts. 100 | accountMb1 ! Stop(); 101 | accountMb2 ! Stop(); 102 | accountMb3 ! Stop() 103 | receive Reply() from self -> 104 | teller_loop(self, accountMb1, accountMb2, accountMb3) 105 | } 106 | } 107 | 108 | ## Account process handling credit requests issued by the teller, and debit 109 | ## requests issued by other accounts. 110 | def account(self: AccountMb?, id: Int, balance: Int): Unit { 111 | guard self: (Debit + Credit)* . Stop { 112 | free -> 113 | () 114 | receive Debit(accountMb, amount) from self -> 115 | 116 | accountMb ! Done(); 117 | account(self, id, balance + amount) 118 | receive Credit(tellerMb, amount, accountMb) from self -> 119 | 120 | # A more uglier implementation would have been to use the 'global mailbox 121 | # way' where all messages are collected in one mailbox. 122 | let transMb = new [AccountMb] in 123 | accountMb ! Debit(transMb, amount); 124 | 125 | guard transMb: Done + 1{ 126 | free -> 127 | account(self, id, balance) 128 | receive Done() from transMb -> 129 | free(transMb); 130 | tellerMb ! Reply(); 131 | account(self, id, balance - amount) 132 | } 133 | 134 | receive Stop() from self -> 135 | account_exit(self) 136 | } 137 | } 138 | 139 | ## Actor process exit procedure that flushes potential residual messages. 140 | def account_exit(self: AccountMb?): Unit { 141 | guard self: (Debit + Credit)* { 142 | free -> () 143 | receive Debit(accountMb, amount) from self -> 144 | account_exit(self) 145 | receive Credit(tellerMb, amount, accountMb) from self -> 146 | account_exit(self) 147 | } 148 | } 149 | 150 | ## Launcher. 151 | def main(): Unit { 152 | let tellerMb = new [TellerMb] in 153 | spawn { teller(tellerMb, 3) }; 154 | 155 | tellerMb ! Start() 156 | } 157 | 158 | main() 159 | -------------------------------------------------------------------------------- /lib/frontend/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | (* Preamble *) 3 | open Lexing 4 | open Parser 5 | open Util 6 | open Common.Source_code 7 | 8 | exception SyntaxError of string 9 | 10 | (* Increments internal lexer metadata *) 11 | let next_line lexbuf = 12 | let pos = lexbuf.lex_curr_p in 13 | lexbuf.lex_curr_p <- 14 | { pos with pos_bol = pos.Lexing.pos_cnum; 15 | pos_lnum = pos.pos_lnum + 1 16 | } 17 | (* Adds a lexeme along with its position to the source code memory, 18 | enabling accurate error reporting later. *) 19 | let add_to_source_code lexbuf = 20 | let lexeme = Lexing.lexeme lexbuf in 21 | let source_code = SourceCodeManager.get_instance () in 22 | let _ = source_code#parse_into (fun buffer _ -> 23 | let len = String.length lexeme in 24 | String.blit lexeme 0 buffer 0 len; 25 | len) (Bytes.of_string lexeme) (String.length lexeme) in 26 | () 27 | 28 | 29 | (* Keywords *) 30 | let keywords = [ 31 | "let", LET; 32 | "spawn", SPAWN; 33 | "new", NEW; 34 | "guard", GUARD; 35 | "receive", RECEIVE; 36 | "free", FREE; 37 | "empty", EMPTY; 38 | "fail", FAIL; 39 | "in", IN; 40 | "linfun", LINFUN; 41 | "fun", FUN; 42 | "from", FROM; 43 | "interface", INTERFACE; 44 | "def", DEF; 45 | "if", IF; 46 | "else", ELSE; 47 | "case", CASE; 48 | "of", OF; 49 | "inl", INL; 50 | "inr", INR 51 | ] 52 | } 53 | 54 | (* Regular expressions (mostly taken from Links) *) 55 | let def_id = (['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']*) 56 | let def_atom = (':' ['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']*) 57 | let def_white = [' ' '\t']+ 58 | let def_newline = '\r' | '\n' | "\r\n" 59 | let def_integer = (['1'-'9'] ['0'-'9']* | '0') 60 | let def_float = (def_integer '.' ['0'-'9']+ ('e' ('-')? def_integer)?) 61 | let op_char = [ '.' '!' '$' '&' '*' '+' '/' '<' '=' '>' '@' '\\' '^' '-' '|' ] 62 | 63 | (* Lexing rules *) 64 | 65 | rule read = 66 | parse 67 | | def_white { add_to_source_code lexbuf; read lexbuf } 68 | | def_newline { add_to_source_code lexbuf; next_line lexbuf; read lexbuf } 69 | | def_integer { add_to_source_code lexbuf; INT (int_of_string (Lexing.lexeme lexbuf)) } 70 | | '#' ([^ '\n'] *) { add_to_source_code lexbuf; read lexbuf } (* Comment *) 71 | (* | def_float { add_to_source_code lexbuf; FLOAT (float_of_string (Lexing.lexeme lexbuf)) } *) 72 | | "true" { add_to_source_code lexbuf; BOOL true } 73 | | "false" { add_to_source_code lexbuf; BOOL false } 74 | | def_id as var { add_to_source_code lexbuf; 75 | try List.assoc var keywords 76 | with Not_found -> 77 | if Utility.is_uppercase var.[0] then 78 | CONSTRUCTOR var 79 | else 80 | VARIABLE var } 81 | | def_atom as atom { add_to_source_code lexbuf; ATOM atom } 82 | | '"' { add_to_source_code lexbuf; read_string (Buffer.create 17) lexbuf } 83 | | '{' { add_to_source_code lexbuf; LEFT_BRACE } 84 | | '}' { add_to_source_code lexbuf; RIGHT_BRACE } 85 | | '[' { add_to_source_code lexbuf; LEFT_BRACK } 86 | | ']' { add_to_source_code lexbuf; RIGHT_BRACK } 87 | | '(' { add_to_source_code lexbuf; LEFT_PAREN } 88 | | ')' { add_to_source_code lexbuf; RIGHT_PAREN } 89 | | ';' { add_to_source_code lexbuf; SEMICOLON } 90 | | ':' { add_to_source_code lexbuf; COLON } 91 | | ',' { add_to_source_code lexbuf; COMMA } 92 | | '=' { add_to_source_code lexbuf; EQ } 93 | | '!' { add_to_source_code lexbuf; BANG } 94 | | '?' { add_to_source_code lexbuf; QUERY } 95 | | '.' { add_to_source_code lexbuf; DOT } 96 | | '*' { add_to_source_code lexbuf; STAR } 97 | | '/' { add_to_source_code lexbuf; DIV } 98 | | '+' { add_to_source_code lexbuf; PLUS } 99 | | '-' { add_to_source_code lexbuf; MINUS } 100 | | '|' { add_to_source_code lexbuf; PIPE } 101 | | "&&" { add_to_source_code lexbuf; AND } 102 | | "||" { add_to_source_code lexbuf; OR } 103 | | ">=" { add_to_source_code lexbuf; GEQ } 104 | | "<" { add_to_source_code lexbuf; LT } 105 | | ">" { add_to_source_code lexbuf; GT } 106 | | "<=" { add_to_source_code lexbuf; LEQ } 107 | | "==" { add_to_source_code lexbuf; EQQ } 108 | | "!=" { add_to_source_code lexbuf; NEQ } 109 | | "->" { add_to_source_code lexbuf; RIGHTARROW } 110 | | "-o" { add_to_source_code lexbuf; LOLLI } 111 | | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf)) } 112 | | eof { EOF } 113 | and read_string buf = 114 | parse 115 | | '"' { add_to_source_code lexbuf; STRING (Buffer.contents buf) } 116 | | '\\' '/' { add_to_source_code lexbuf; Buffer.add_char buf '/'; read_string buf lexbuf } 117 | | '\\' '\\' { add_to_source_code lexbuf; Buffer.add_char buf '\\'; read_string buf lexbuf } 118 | | '\\' 'b' { add_to_source_code lexbuf; Buffer.add_char buf '\b'; read_string buf lexbuf } 119 | | '\\' 'f' { add_to_source_code lexbuf; Buffer.add_char buf '\012'; read_string buf lexbuf } 120 | | '\\' 'n' { add_to_source_code lexbuf; Buffer.add_char buf '\n'; read_string buf lexbuf } 121 | | '\\' 'r' { add_to_source_code lexbuf; Buffer.add_char buf '\r'; read_string buf lexbuf } 122 | | '\\' 't' { add_to_source_code lexbuf; Buffer.add_char buf '\t'; read_string buf lexbuf } 123 | | [^ '"' '\\']+ 124 | { add_to_source_code lexbuf; Buffer.add_string buf (Lexing.lexeme lexbuf); 125 | read_string buf lexbuf 126 | } 127 | | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } 128 | | eof { raise (SyntaxError ("String is not terminated")) } 129 | -------------------------------------------------------------------------------- /lib/typecheck/type_utils.ml: -------------------------------------------------------------------------------- 1 | (* Various operations on types that only arise during typechecking. *) 2 | open Common 3 | open Common_types 4 | open Common.Source_code 5 | 6 | 7 | (* Tries to ensure that a type is treated as unrestricted. All base types are 8 | unrestricted. Input mailbox types cannot be made unrestricted. An output mailbox 9 | type !E can be treated as unrestricted if 1 is included in E (i.e., we could 10 | choose not to send). 11 | *) 12 | let make_unrestricted t pos = 13 | let open Type in 14 | match t with 15 | (* Trivially unrestricted *) 16 | | Base _ 17 | | Tuple [] 18 | | Fun { linear = false; _ } -> Constraint_set.empty 19 | (* Cannot be unrestricted *) 20 | | Fun { linear = true; _ } 21 | | Mailbox { capability = Capability.In; _ } -> 22 | Gripers.cannot_make_unrestricted t [pos] 23 | (* Generate a pattern constraint in order to ensure linearity *) 24 | | Mailbox { capability = Capability.Out; pattern = Some pat; _ } -> 25 | Constraint_set.of_list 26 | [Constraint.make (Pattern.One) pat] 27 | | _ -> assert false 28 | 29 | (* Auxiliary definitions*) 30 | 31 | (* Checks whether t1 is a subtype of t2, and produces the necessary constraints. 32 | We need to take a coinductive view of subtyping to avoid infinite loops, so 33 | we track the visited interface names. 34 | *) 35 | let rec subtype_type : 36 | (interface_name * interface_name) list -> 37 | Interface_env.t -> Type.t -> Type.t -> Position.t -> Constraint_set.t = 38 | fun visited ienv t1 t2 pos -> 39 | match t1, t2 with 40 | | Base b1, Base b2 when b1 = b2-> 41 | Constraint_set.empty 42 | 43 | (* Subtyping covariant for tuples and sums *) 44 | | Tuple tyas, Tuple tybs -> 45 | Constraint_set.union_many 46 | (List.map (fun (tya, tyb) -> subtype_type visited ienv tya tyb pos) 47 | (List.combine tyas tybs)) 48 | | Sum (tya1, tya2), Sum (tyb1, tyb2) -> 49 | Constraint_set.union 50 | (subtype_type visited ienv tya1 tyb1 pos) 51 | (subtype_type visited ienv tya2 tyb2 pos) 52 | | Mailbox { pattern = None; _ }, _ 53 | | _, Mailbox { pattern = None; _ } -> 54 | (* Should have been sorted by annotation pass *) 55 | assert false 56 | | Fun { linear = lin1; args = args1; 57 | result = body1 }, 58 | Fun { linear = lin2; args = args2; 59 | result = body2 } -> 60 | let () = 61 | if lin1 <> lin2 then 62 | Gripers.subtype_linearity_mismatch t1 t2 [pos] 63 | in 64 | (* Args contravariant; body covariant *) 65 | let args_constrs = 66 | List.map2 (fun a2 a1 -> subtype_type visited ienv a2 a1 pos) args2 args1 67 | |> Constraint_set.union_many in 68 | let body_constrs = subtype_type visited ienv body1 body2 pos in 69 | Constraint_set.union args_constrs body_constrs 70 | | Mailbox { 71 | capability = capability1; 72 | interface = iname1; 73 | pattern = Some pat1; 74 | quasilinearity = ql1 75 | }, 76 | Mailbox { 77 | capability = capability2; 78 | interface = iname2; 79 | pattern = Some pat2; 80 | quasilinearity = ql2 81 | } -> 82 | (* First, ensure interface subtyping *) 83 | let interface1 = WithPos.node (Interface_env.lookup iname1 ienv []) in 84 | let interface2 = WithPos.node (Interface_env.lookup iname2 ienv []) in 85 | let () = 86 | if not (Type.Quasilinearity.is_sub ql1 ql2) then 87 | Gripers.quasilinearity_mismatch t1 t2 [pos] 88 | in 89 | let iface_constraints = 90 | subtype_interface visited ienv interface1 interface2 pos in 91 | let pat_constraints = 92 | if capability1 = capability2 then 93 | match capability1 with 94 | | In -> 95 | (* Input types are covariant *) 96 | Constraint_set.single_constraint pat1 pat2 97 | | Out -> 98 | (* Output types are contravariant *) 99 | Constraint_set.single_constraint pat2 pat1 100 | else 101 | Gripers.subtype_cap_mismatch t1 t2 [pos] 102 | in 103 | Constraint_set.union iface_constraints pat_constraints 104 | | _, _ -> 105 | Gripers.subtype_mismatch t1 t2 [pos] 106 | 107 | and subtype_interface : 108 | (interface_name * interface_name) list -> 109 | Interface_env.t -> Interface.t -> Interface.t -> Position.t -> Constraint_set.t = 110 | fun visited ienv i1 i2 pos -> 111 | if List.mem (Interface.name i1, Interface.name i2) visited then 112 | Constraint_set.empty 113 | else 114 | (* Interface i1 is a subtype of interface i2 if i2 supports all 115 | messages that i1 supports, and the payloads of i1's messages 116 | are subtypes of those of i2. *) 117 | let visited = (Interface.name i1, Interface.name i2) :: visited in 118 | List.fold_left (fun acc (tag, payloads1) -> 119 | let payloads2 = Interface.lookup tag i2 in 120 | List.combine payloads1 payloads2 121 | |> List.map (fun (p1, p2) -> subtype_type visited ienv p1 p2 pos) 122 | |> Constraint_set.union_many 123 | |> Constraint_set.union acc 124 | ) Constraint_set.empty (Interface.bindings i1) 125 | 126 | (** subtype ienv t1 t2 checks whether t1 is a subtype of t2, and generates the 127 | relevant set of constraints. Wraps around subtype_type. *) 128 | let subtype = subtype_type [] 129 | -------------------------------------------------------------------------------- /lib/common/source_code.ml: -------------------------------------------------------------------------------- 1 | open Util.Utility 2 | (* Initial estimates for input size *) 3 | let default_lines = 100 4 | and default_chars = 8000 5 | 6 | let trim_initial_newline s = 7 | let len = String.length s in 8 | if len > 0 && s.[0] = '\n' then StringLabels.sub s ~pos:1 ~len:(len-1) 9 | else s 10 | 11 | class source_code = 12 | object (self) 13 | val lines = 14 | let tbl = Hashtbl.create default_lines in 15 | Hashtbl.add tbl 0 0; 16 | tbl 17 | val text = Buffer.create default_chars 18 | 19 | (* Return the portion of source code that falls between two positions *) 20 | method private extract_substring (start : Lexing.position) (finish : Lexing.position) = 21 | try 22 | Buffer.sub text start.Lexing.pos_cnum (finish.Lexing.pos_cnum - start.Lexing.pos_cnum) 23 | with Invalid_argument _ -> "*** DUMMY POSITION ****" 24 | 25 | (* Return some lines of the source code *) 26 | method extract_line_range (startline : int) (finishline : int) = 27 | try 28 | let start = Hashtbl.find lines startline 29 | and finish = (if finishline = Hashtbl.length lines 30 | (* handle the last line of input *) 31 | then Buffer.length text 32 | else Hashtbl.find lines finishline) 33 | in 34 | trim_initial_newline (Buffer.sub text (start) (finish - start)) 35 | with Not_found -> "" 36 | 37 | (* Return one line of the source code *) 38 | method extract_line (line : int) = 39 | self#extract_line_range (line - 1) line 40 | 41 | (* Given a function `infun' as required by Lexing.from_function, 42 | return another such function that stores the text read in `code'. 43 | *) 44 | method parse_into (infun : bytes -> int -> int) : bytes -> int -> int = 45 | fun buffer nchars -> 46 | let nchars = infun buffer nchars in 47 | List.iter (fun linepos -> 48 | Hashtbl.add lines 49 | (Hashtbl.length lines) 50 | (linepos + Buffer.length text)) 51 | (find_char (Bytes.sub buffer 0 nchars) '\n'); 52 | Buffer.add_subbytes text buffer 0 nchars; 53 | nchars 54 | 55 | (* Retrieve the last line of source code read. *) 56 | method find_line (pos : Lexing.position) : (string * int) = 57 | (self#extract_line pos.Lexing.pos_lnum, 58 | abs @@ pos.Lexing.pos_cnum - Hashtbl.find lines (pos.Lexing.pos_lnum -1) - 1) 59 | 60 | (* Create a `lookup function' that given start and finish positions 61 | returns a resolved position 62 | *) 63 | method lookup = 64 | fun (start, finish) -> 65 | (start, 66 | self#extract_line start.Lexing.pos_lnum, 67 | self#extract_substring start finish) 68 | 69 | method extract_all_code () = 70 | Buffer.contents text 71 | end 72 | 73 | module SourceCodeManager = struct 74 | let source_code_instance = ref (new source_code) 75 | 76 | let get_instance () = !source_code_instance 77 | end 78 | 79 | module Lexpos = struct 80 | type t = Lexing.position 81 | [@@name "lexpos"] 82 | 83 | let pp fmt lpos = 84 | Format.fprintf fmt 85 | "File %s, line %d, char %d" lpos.Lexing.pos_fname lpos.Lexing.pos_lnum lpos.Lexing.pos_cnum 86 | 87 | let show v = Format.asprintf "%a" pp v 88 | end 89 | 90 | 91 | module Position = struct 92 | type t = { 93 | start : Lexpos.t; 94 | finish : Lexpos.t; 95 | code : source_code; 96 | } 97 | [@@name "position"] 98 | 99 | let pp : Format.formatter -> t -> unit = fun fmt pos -> 100 | let pp_non_dummy () = 101 | let file = pos.start.Lexing.pos_fname in 102 | 103 | let bold = "\027[1m" 104 | and reset = "\027[0m" in 105 | 106 | Format.fprintf fmt "%sFile %s, " bold file; 107 | 108 | let start_line = pos.start.Lexing.pos_lnum in 109 | let start_char = pos.start.Lexing.pos_cnum - pos.start.Lexing.pos_bol in 110 | let finish_line = pos.finish.Lexing.pos_lnum in 111 | let finish_char = pos.finish.Lexing.pos_cnum - pos.finish.Lexing.pos_bol in 112 | 113 | (* Show only first six line if the source code too long *) 114 | let finish_line = 115 | if finish_line - start_line > 5 then 116 | start_line + 5 117 | else 118 | finish_line 119 | in 120 | 121 | if start_line = finish_line then 122 | if start_char = finish_char then 123 | Format.fprintf fmt "line %d, column %d%s" start_line start_char reset 124 | else 125 | Format.fprintf fmt "line %d, columns %d to %d%s" start_line start_char finish_char reset 126 | else 127 | Format.fprintf fmt "line %d, column %d, to line %d, column %d%s" start_line start_char finish_line finish_char reset; 128 | 129 | let line_number_width = String.length (string_of_int finish_line) in 130 | let pad_line_number n = 131 | let line_number_str = string_of_int n in 132 | let padding = String.make (line_number_width - String.length line_number_str) ' ' in 133 | padding ^ line_number_str 134 | in 135 | (* Adjust this part to include line numbers with padding for alignment *) 136 | let source_code_str = 137 | if start_line = finish_line then 138 | Format.sprintf "%s| %s" (pad_line_number start_line) (pos.code#extract_line start_line) 139 | else 140 | let full_string = pos.code#extract_line_range (start_line-1) finish_line in 141 | let lines = String.split_on_char '\n' full_string in 142 | List.mapi (fun i line -> Format.sprintf "%s| %s" (pad_line_number (start_line + i)) line) lines 143 | |> String.concat "\n" 144 | in 145 | 146 | (* ANSI escape codes for red color *) 147 | let red = "\027[31m" 148 | and reset = "\027[0m" in 149 | 150 | (* Generate the marker line with ^ symbols in red *) 151 | let marker_line = 152 | String.make (line_number_width + 2 + start_char) ' ' ^ red ^ String.make (finish_char - start_char + 1) '^' ^ reset 153 | in 154 | 155 | if marker_line <> "" then 156 | Format.fprintf fmt "\n%s\n%s" source_code_str marker_line 157 | else 158 | Format.fprintf fmt "\n%s" source_code_str 159 | in 160 | if pos.start = Lexing.dummy_pos || pos.finish = Lexing.dummy_pos then 161 | Format.fprintf fmt "" 162 | else 163 | pp_non_dummy () 164 | 165 | let show v = Format.asprintf "%a" pp v 166 | 167 | let make ~start ~finish ~code = 168 | { start; finish; code; } 169 | 170 | let dummy = make ~start:Lexing.dummy_pos ~finish:Lexing.dummy_pos ~code:(SourceCodeManager.get_instance ()) 171 | 172 | let start t = t.start 173 | 174 | let finish t = t.finish 175 | 176 | let code t = t.code 177 | 178 | let format_pos pos_list = 179 | String.concat "\n " (List.map (fun pos -> Format.asprintf "%a" pp pos) pos_list) 180 | end 181 | 182 | module WithPos = struct 183 | type 'a t = { node : 'a 184 | ; pos : (Position.t[@name "position"][@opaque]) 185 | } 186 | [@@name "withP"] 187 | [@@deriving visitors { variety = "map"; polymorphic = true}] 188 | 189 | let make ?(pos = Position.dummy) node = { node; pos } 190 | let dummy node = make node 191 | 192 | let node t = t.node 193 | 194 | let pos t = t.pos 195 | 196 | let pp pp_node ppf { node; pos } = 197 | Format.fprintf ppf "%a at %a" pp_node node Position.pp pos 198 | 199 | let pp_pos_only fmt { pos; _ } = 200 | Position.pp fmt pos 201 | 202 | let extract_pos_pair w1 w2 = [w1.pos; w2.pos] 203 | 204 | let split_with_pos_list lst = 205 | ((List.map pos lst),( List.map node lst)) 206 | 207 | let extract_list_node lst = List.map node lst 208 | 209 | let extract_list_pos lst = List.map pos lst 210 | 211 | let combine_with_pos_list pos_list node_list = 212 | List.map2 (fun pos node -> make ~pos node) pos_list node_list 213 | end 214 | -------------------------------------------------------------------------------- /test/tests.json: -------------------------------------------------------------------------------- 1 | { "groups": 2 | [ 3 | { "group": "Linear functions", 4 | "tests": 5 | [ 6 | { 7 | "name": "Linear function (good)", 8 | "filename": "pat-tests/linfun-good.pat", 9 | "exit_code": 0 10 | }, 11 | { 12 | "name": "Linear function (bad #1: unused linear variable)", 13 | "filename": "pat-tests/linfun-bad-1.pat", 14 | "exit_code": 1 15 | }, 16 | { 17 | "name": "Linear function (bad #2: non-linear function closing over linear variable)", 18 | "filename": "pat-tests/linfun-bad-2.pat", 19 | "exit_code": 1 20 | }, 21 | { 22 | "name": "Linear function (bad #3: unused linear function)", 23 | "filename": "pat-tests/linfun-bad-3.pat", 24 | "exit_code": 1 25 | }, 26 | { 27 | "name": "Function returning a mailbox type", 28 | "filename": "pat-tests/mb-function-return.pat", 29 | "exit_code": 0 30 | } 31 | ] 32 | }, 33 | { 34 | "group": "Basic tests", 35 | "tests": 36 | [ 37 | { 38 | "name": "Arithmetic (1)", 39 | "filename": "pat-tests/arith.pat", 40 | "exit_code": 0 41 | }, 42 | { 43 | "name": "Arithmetic (2)", 44 | "filename": "pat-tests/arith1.pat", 45 | "exit_code": 0 46 | }, 47 | { 48 | "name": "Arithmetic (3)", 49 | "filename": "pat-tests/arith2.pat", 50 | "exit_code": 0 51 | }, 52 | { 53 | "name": "Functions", 54 | "filename": "pat-tests/functions.pat", 55 | "exit_code": 0 56 | }, 57 | { 58 | "name": "Sums (1)", 59 | "filename": "pat-tests/sum-1.pat", 60 | "exit_code": 0 61 | }, 62 | { 63 | "name": "Sums (2)", 64 | "filename": "pat-tests/sum-2.pat", 65 | "exit_code": 0 66 | }, 67 | { 68 | "name": "Annotated let (1)", 69 | "filename": "pat-tests/let-annot-1.pat", 70 | "exit_code": 0 71 | }, 72 | { 73 | "name": "Annotated let (2)", 74 | "filename": "pat-tests/let-annot-2.pat", 75 | "exit_code": 0 76 | }, 77 | { 78 | "name": "Annotated let (3)", 79 | "filename": "pat-tests/let-annot-3.pat", 80 | "exit_code": 0 81 | }, 82 | { 83 | "name": "Atoms", 84 | "filename": "pat-tests/atoms.pat", 85 | "exit_code": 0 86 | }, 87 | { 88 | "name": "n-tuples (1)", 89 | "filename": "pat-tests/n-tuples.pat", 90 | "exit_code": 0 91 | }, 92 | { 93 | "name": "n-tuples (2)", 94 | "filename": "pat-tests/n-tuples-2.pat", 95 | "exit_code": 0 96 | }, 97 | { 98 | "name": "n-tuples, bad (1)", 99 | "filename": "pat-tests/n-tuples-bad-1.pat", 100 | "exit_code": 1 101 | }, 102 | { 103 | "name": "n-tuples, bad (2)", 104 | "filename": "pat-tests/n-tuples-bad-2.pat", 105 | "exit_code": 1 106 | } 107 | ] 108 | }, 109 | { "group": "Correct examples (de Liguoro & Padovani)", 110 | "tests": 111 | [ 112 | {"name": "Account", "filename": "examples/de_liguoro_padovani/account.pat", "exit_code": 0}, 113 | {"name": "Account with Future", "filename": "examples/de_liguoro_padovani/account_future.pat", "exit_code": 0}, 114 | {"name": "Future", "filename": "examples/de_liguoro_padovani/future.pat", "exit_code": 0}, 115 | {"name": "Future with explicit fail guard", "filename": "examples/de_liguoro_padovani/futurefail.pat", "exit_code": 0}, 116 | {"name": "Future with state passing", "filename": "examples/de_liguoro_padovani/future_state_passing.pat", "exit_code": 0}, 117 | {"name": "Lock", "filename": "examples/de_liguoro_padovani/lock.pat", "exit_code": 0}, 118 | {"name": "Master-Worker", "filename": "examples/de_liguoro_padovani/master_worker.pat", "exit_code": 0}, 119 | {"name": "Session types", "filename": "examples/de_liguoro_padovani/sessions.pat", "exit_code": 0} 120 | ] 121 | }, 122 | { "group": "Correct examples (Savina)", 123 | "tests": 124 | [ 125 | {"name": "Banking", "filename": "examples/savina/banking.pat", "exit_code": 0}, 126 | {"name": "Big", "filename": "examples/savina/big.pat", "exit_code": 0}, 127 | {"name": "Cigarette Smoker", "filename": "examples/savina/cig_smok.pat", "exit_code": 0}, 128 | {"name": "Count", "filename": "examples/savina/count.pat", "exit_code": 0}, 129 | {"name": "Fibonacci", "filename": "examples/savina/fib.pat", "exit_code": 0}, 130 | {"name": "Fibonacci with Pairs", "filename": "examples/savina/fib_pairs.pat", "exit_code": 0}, 131 | {"name": "kfork", "filename": "examples/savina/kfork.pat", "exit_code": 0}, 132 | {"name": "Log Map", "filename": "examples/savina/log_map.pat", "exit_code": 0}, 133 | {"name": "Philosopher", "filename": "examples/savina/philosopher.pat", "exit_code": 0}, 134 | {"name": "Ping Pong", "filename": "examples/savina/ping_pong.pat", "exit_code": 0}, 135 | {"name": "Ping Pong (Strict)", "filename": "examples/savina/ping_pong_strict.pat", "exit_code": 0}, 136 | {"name": "Thread Ring", "filename": "examples/savina/thread_ring.pat", "exit_code": 0} 137 | ] 138 | }, 139 | { "group": "Correct examples (Others)", 140 | "tests": 141 | [ 142 | {"name": "n-Robots", "filename": "examples/robotsn.pat", "exit_code": 0}, 143 | {"name": "Guard annotation is a subpattern", "filename": "examples/pat_constr.pat", "exit_code": 0} 144 | ] 145 | }, 146 | { "group": "Incorrect examples", 147 | "tests": 148 | [ 149 | {"name": "Aliasing through communication (1)", "filename": "errors/alias_comm1.pat", "exit_code": 1}, 150 | {"name": "Aliasing through communication (2)", "filename": "errors/alias_comm2.pat", "exit_code": 1}, 151 | {"name": "Aliasing through communication (3)", "filename": "errors/simple_alias_comm.pat", "exit_code": 1}, 152 | { 153 | "name": "Lock", 154 | "filename": "errors/lock.pat", 155 | "exit_code": 1 156 | }, 157 | { 158 | "name": "Future", 159 | "filename": "errors/future.pat", 160 | "exit_code": 1 161 | }, 162 | { 163 | "name": "Use after free", 164 | "filename": "errors/useafterfree.pat", 165 | "exit_code": 1 166 | }, 167 | { 168 | "name": "Use after free (2)", 169 | "filename": "errors/uaf1.pat", 170 | "exit_code": 1 171 | }, 172 | { 173 | "name": "Use after free (3)", 174 | "filename": "errors/uaf2.pat", 175 | "exit_code": 1 176 | }, 177 | { 178 | "name": "Use after free (4)", 179 | "filename": "errors/uaf3.pat", 180 | "exit_code": 1 181 | }, 182 | {"name": "Insufficient type information", "filename": "errors/pat_constr.pat", "exit_code": 1}, 183 | {"name": "Non-exhaustive guards", "filename": "errors/pat_constr2.pat", "exit_code": 1}, 184 | {"name": "Additional non-supported non-fail guard with nontrivial continuation", "filename": "errors/pat_constr3.pat", "exit_code": 1}, 185 | {"name": "Additional non-supported free guard", "filename": "errors/pat_constr4.pat", "exit_code": 1} 186 | ] 187 | } 188 | ] 189 | } 190 | -------------------------------------------------------------------------------- /ARTIFACT.md: -------------------------------------------------------------------------------- 1 | # ICFP 2023 Artifact Instructions 2 | 3 | Name: *Special Delivery: Programming with Mailbox Types* 4 | 5 | ## Artifact Instructions 6 | 7 | This is the artifact for the paper "Special Delivery: Programming with Mailbox 8 | Types". The artifact consists of a QEMU image (based on the ICFP base image) 9 | containing the Pat typechecker and scripts to help evaluate the artifact. 10 | The typechecker is written in OCaml, and uses Z3 as a backend solver for 11 | Presburger formulae. Please see the "QEMU Instructions" section for instructions 12 | on how to boot the QEMU image. 13 | 14 | ## Credentials 15 | 16 | * Username: artifact 17 | * Password: password 18 | 19 | ### Scope 20 | 21 | The typechecker implements the bidirectional type system described in Section 4. 22 | In addition, it implements all of the extensions (products, sums, lambdas, and 23 | interfaces). The artifact will also allow you to generate the table from the 24 | Evaluation section of the paper; includes all of the examples from the paper and 25 | evaluation; and will allow you to test your own examples. 26 | 27 | ### Sample evaluation workflow 28 | 29 | 1. `cd mbcheck` into the project directory. 30 | 2. Build the `mbcheck` binary by running `make`. 31 | 2. Run the test suite by running `make test`. 32 | 3. Try the examples from the paper (see the "Mapping to Paper" section) 33 | 4. Generate the table from section 6 by running `./generate-table.py`. (Note, 34 | this is set to perform 100 iterations by default; you can change this by 35 | modifying the `REPETITIONS` parameter) 36 | 5. Try your own examples, if you like! You can invoke the typechecker by 37 | `./mbcheck `. It will exit silently if the example typechecks. If you 38 | would like to see the inferred and simplified patterns, use the `-v` option. 39 | 6. Have a look at the salient parts of the implementation (see the "Navigating 40 | the source code" section) 41 | 42 | ### Tool options 43 | 44 | Invoke `mbcheck` as `./mbcheck filename`. The options are as follows: 45 | * `-v`: verbose mode; outputs program with solved constraints 46 | * `-d`: debug mode; outputs detailed information about pattern constraints 47 | * `-b ` or `--benchmark=`: output mean time taken to typecheck 48 | file over `` iterations 49 | * `--ir` prints the IR after translation 50 | * `--mode=MODE` where `MODE` is one of `strict`, `interface`, or `none`: 51 | defines alias checking mode. `strict` requires that no free names occur 52 | within a guard; `interface` (default) requires that received names have a 53 | different interface to the free names in a guard; and `none` (unsound) 54 | turns off alias checking 55 | 56 | ### Mapping to Paper 57 | 58 | All Pat code snippets in the paper, along with all examples, are included in the 59 | artifact. 60 | 61 | You can run all of these using the `./run-paper-examples.py` script. 62 | 63 | * The Future example from the introduction can be found in 64 | `test/examples/de_liguoro_padovani/future.pat`. This should typecheck without 65 | error. 66 | * The use-after-free examples should all raise errors, and can be found as follows: 67 | - Fig 3(a): `test/errors/uaf1.pat` 68 | - Fig 3(b): `test/errors/uaf2.pat` 69 | - Fig 3(c): `test/errors/uaf3.pat` 70 | * Programs introducing the problem in "Aliasing through communication" should 71 | also raise errors, and can be found in: 72 | - `test/errors/alias_comm1.pat` 73 | - `test/errors/alias_comm2.pat` 74 | * The product example from Sec 5.1 can be found in `test/examples/product.pat` 75 | * The interface example from Sec 5.1 can be found in `test/examples/interfaces.pat` 76 | * The de'Liguoro & Padovani examples from Sec 6 can be found in 77 | `test/examples/de_liguoro_padovani`. 78 | * The Savina examples from Sec 6 can be found in `test/examples/savina`. 79 | * The Robots case study from Sec 6 can be found in `test/examples/robotsn.pat`. 80 | 81 | ### Language guide & build / installation instructions 82 | A guide to the language, as well as build and installation instructions, can be 83 | found in `mbcheck/README.md`. 84 | 85 | ### Difference between core calculus and concrete syntax 86 | 87 | The implementation is fairly faithful to the syntax from Fig. 4, with the 88 | following syntactic modifications: 89 | 90 | * Since we perform an A-normalisation step, it is possible to write nested 91 | expressions (i.e., `(1 + 2) + 3` rather than `let x = 1 + 2 in x + 3`). 92 | * It is not necessary to specify a pattern or usage when writing a mailbox 93 | type (you can see this, for example, in the Future example). 94 | - You can write `Future!` to mean a send mailbox with interface `Future`. 95 | - You can also ascribe a pattern to a mailbox type: for example, you could 96 | write `Future!Put` to denote a mailbox type with interface Future, which 97 | must send a Put message. 98 | - By default, send mailbox types are inferred as having a second-class 99 | usage, whereas receive mailbox types are inferred as being returnable. 100 | You can specify the usage explicitly using the `[U]` (for second-class) 101 | and `[R]` (for returnable) modifiers. 102 | So, to complete our example, a returnable output mailbox type for the Future 103 | interface which can send a Put message is `Future!Put[R]` 104 | * Messages are written with parentheses rather than braces (e.g., `x ! m(y)` 105 | rather than `x ! m[y]`). 106 | * We require interfaces as standard, so it's necessary to specify an interface 107 | name with `new`, i.e., `let x = new[Future] in ...` 108 | * Branches of case expressions are separated with a pipe (`|`) rather than a 109 | semicolon, i.e., `case V { inl x -> M | inr y -> N }` 110 | 111 | ### Navigating the source code 112 | 113 | The source code can be found in the `mbcheck` directory. Salient code locations 114 | are as follows: 115 | 116 | * `bin/main.ml`: main entry point / command line processing 117 | * `lib/common/sugar_ast.ml`: post-parsing AST 118 | * `lib/common/ir.ml`: explicitly-sequenced intermediate representation 119 | * `lib/frontend/parser.mly`: grammar 120 | * `lib/frontend/pipeline.ml`: desugaring / typechecking pipeline 121 | * `lib/frontend/sugar_to_ir.ml`: IR conversion, converting sugared AST 122 | to explicitly-sequenced representation 123 | * `lib/typecheck/pretypecheck.ml`: contextual typing pass to propagate 124 | interface information (sec 5) 125 | * `lib/typecheck/gen_constraints.ml`: backwards bidirectional type system 126 | described in section 4 127 | - `synthesise_val` and `synthesise_comp` correspond to the synthesis 128 | judgement `M =P=> t |> env; constrs` 129 | - `check_val` and `check_comp` correspond to the checking judgement 130 | `M <=P= t |> env; constrs` 131 | - `check_guard` corresponds to the guard checking judgement 132 | `{E} G <=P= t |> Phi; consts; F` 133 | * `lib/typecheck/ty_env.ml`: algorithmic type & environment joining / merging 134 | - `combine` corresponds to disjoint combination `t1 + t2 |> t; constrs` 135 | - `join` corresponds to sequential combination `t1 ; t2 |> t; constrs` 136 | - `intersect` corresponds to disjoint combination `t1 cap t2 |> t; constrs` 137 | * `lib/typecheck/solve_constraints.ml` converts pattern constraints into 138 | Presburger formulae to be solved by Z3 139 | * `lib/typecheck/z3_solver.ml` interfaces with the Z3 solver 140 | 141 | ## QEMU Instructions 142 | 143 | The ICFP 2023 Artifact Evaluation Process is using a Debian QEMU image as a 144 | base for artifacts. The Artifact Evaluation Committee (AEC) will verify that 145 | this image works on their own machines before distributing it to authors. 146 | Authors are encouraged to extend the provided image instead of creating their 147 | own. If it is not practical for authors to use the provided image then please 148 | contact the AEC co-chairs before submission. 149 | 150 | QEMU is a hosted virtual machine monitor that can emulate a host processor 151 | via dynamic binary translation. On common host platforms QEMU can also use 152 | a host provided virtualization layer, which is faster than dynamic binary 153 | translation. 154 | 155 | QEMU homepage: https://www.qemu.org/ 156 | 157 | ### Installation 158 | 159 | #### OSX 160 | ``brew install qemu`` 161 | 162 | #### Debian and Ubuntu Linux 163 | ``sudo apt update`` 164 | ``sudo apt install qemu-system-x86`` 165 | 166 | On x86 laptops and server machines you may need to enable the 167 | "Intel Virtualization Technology" setting in your BIOS, as some manufacturers 168 | leave this disabled by default. See Debugging.md for details. 169 | 170 | 171 | #### Arch Linux 172 | 173 | ``pacman -Sy qemu`` 174 | 175 | See the [Arch wiki](https://wiki.archlinux.org/title/QEMU) for more info. 176 | 177 | See Debugging.md if you have problems logging into the artifact via SSH. 178 | 179 | 180 | #### Windows 10 181 | 182 | Download and install QEMU via the links at 183 | 184 | https://www.qemu.org/download/#windows. 185 | 186 | Ensure that `qemu-system-x86_64.exe` is in your path. 187 | 188 | Start Bar -> Search -> "Windows Features" 189 | -> enable "Hyper-V" and "Windows Hypervisor Platform". 190 | 191 | Restart your computer. 192 | 193 | #### Windows 8 194 | 195 | See Debugging.md for Windows 8 install instructions. 196 | 197 | ### Startup 198 | 199 | The base artifact provides a `start.sh` script to start the VM on unix-like 200 | systems and `start.bat` for Windows. Running this script will open a graphical 201 | console on the host machine, and create a virtualized network interface. 202 | On Linux you may need to run with `sudo` to start the VM. If the VM does not 203 | start then check `Debugging.md` 204 | 205 | Once the VM has started you can login to the guest system from the host. 206 | Whenever you are asked for a password, the answer is `password`. The default 207 | username is `artifact`. 208 | 209 | ``` 210 | $ ssh -p 5555 artifact@localhost 211 | ``` 212 | 213 | You can also copy files to and from the host using scp. 214 | 215 | ``` 216 | $ scp -P 5555 artifact@localhost:somefile . 217 | ``` 218 | 219 | ### Shutdown 220 | 221 | To shutdown the guest system cleanly, login to it via ssh and use 222 | 223 | ``` 224 | $ sudo shutdown now 225 | ``` 226 | -------------------------------------------------------------------------------- /lib/common/sugar_ast.ml: -------------------------------------------------------------------------------- 1 | open Common_types 2 | open Util.Utility 3 | open Format 4 | 5 | 6 | module WithPos = Source_code.WithPos 7 | 8 | (* Basic sugared AST *) 9 | (* Expressions *) 10 | type expr = expr_node WithPos.t [@name "withP"] 11 | and expr_node = 12 | | Var of sugar_var 13 | | Atom of atom_name 14 | | Primitive of (primitive_name[@name "primitive_name"]) 15 | (* Type annotation, used for synthesis --> checking switch. *) 16 | | Annotate of expr * (Type.t[@name "ty"]) 17 | | Constant of constant 18 | | Lam of { 19 | linear: bool; 20 | parameters: (sugar_binder * (Type.t[@name "ty"])) list; 21 | result_type: (Type.t[@name "ty"]); 22 | body: expr } 23 | | Let of { 24 | binder: sugar_binder; 25 | annot: (Type.t[@name "ty"]) option; 26 | term: expr; 27 | body: expr } 28 | | Seq of expr * expr 29 | | App of { 30 | func: expr; 31 | args: expr list 32 | } 33 | | If of { test: expr; then_expr: expr; else_expr: expr } 34 | (* Tuples *) 35 | | Tuple of expr list 36 | | LetTuple of { 37 | binders: sugar_binder list; 38 | annot: ((Type.t[@name "ty"]) list) option; 39 | term: expr; 40 | cont: expr 41 | } 42 | (* Sums *) 43 | | Inl of expr 44 | | Inr of expr 45 | | Case of { 46 | term: expr; 47 | branch1: (sugar_binder * (Type.t[@name "ty"])) * expr; 48 | branch2: (sugar_binder * (Type.t[@name "ty"])) * expr 49 | } 50 | (* Note that we're using the versions of new and spawn where they are 51 | not wired to their continuations. I've experimented with the 52 | bidirectional rules and it seems that this does not pose any problems. *) 53 | (* That said, we may revisit this later when we look at deadlock detection. *) 54 | | New of string (* interface name *) 55 | | Spawn of expr 56 | (* interface names for Send and Guard will be added after pre-type checking *) 57 | | Send of { 58 | target: expr; 59 | message: (string * (expr list)); 60 | iname: string option 61 | } 62 | | Guard of { 63 | target: expr; 64 | (* At least at the moment, each guard must be annotated with a pattern *) 65 | pattern: (Type.Pattern.t [@name "pattern"]); 66 | guards: guard list; 67 | iname: string option 68 | } 69 | | Free of expr 70 | (* fail(e)[A], desugars to (guard e : 0 { fail } : A) *) 71 | | SugarFail of expr * (Type.t [@name "ty"]) 72 | and constant = 73 | [%import: Common_types.Constant.t] 74 | and sugar_var = string 75 | and atom_name = string 76 | and sugar_binder = string 77 | and primitive_name = string 78 | (* Guards are either a receive expression, free, or fail *) 79 | and guard = guard_node WithPos.t [@name "withP"] 80 | and guard_node = 81 | | Receive of { 82 | tag: string; 83 | payload_binders: sugar_binder list; 84 | mailbox_binder: sugar_binder; 85 | cont: expr 86 | } 87 | | GFree of expr 88 | | Empty of (sugar_var * expr) 89 | (* For now, require annotation since Fail can have any type *) 90 | (* It would be nice to get rid of this later. *) 91 | | Fail of (Type.t[@name "ty"]) 92 | and decl = { 93 | decl_name: string; 94 | decl_parameters: (string * (Type.t[@name "ty"])) list; 95 | decl_return_type: (Type.t[@name "ty"]); 96 | decl_body: expr 97 | } 98 | and prog_interfaces_node = (Interface.t[@name "interface"]) 99 | and program = { 100 | prog_interfaces: (prog_interfaces_node WithPos.t [@name "withP"]) list; 101 | prog_decls: (decl WithPos.t [@name "withP"]) list; 102 | prog_body: expr option 103 | } 104 | [@@deriving visitors { 105 | variety = "map"; 106 | ancestors = ["Type.map"; "Interface.map"; "WithPos.map"]; 107 | data = false } ] 108 | 109 | let is_receive_guard = function 110 | | Receive _ -> true 111 | | _ -> false 112 | 113 | let is_free_guard = function 114 | | GFree _ -> true 115 | | _ -> false 116 | 117 | let is_empty_guard = function 118 | | Empty _ -> true 119 | | _ -> false 120 | 121 | let is_fail_guard = function 122 | | Fail _ -> true 123 | | _ -> false 124 | 125 | (* Pretty-printing of the AST *) 126 | (* Programs *) 127 | let rec pp_program ppf { prog_interfaces; prog_decls; prog_body } = 128 | fprintf ppf "%a@.%a@.@.%a" 129 | (pp_print_newline_list pp_interface) prog_interfaces 130 | (pp_print_double_newline_list pp_decl) prog_decls 131 | (pp_print_option pp_expr) prog_body 132 | (* Interfaces *) 133 | and pp_interface ppf iface = 134 | let pp_msg_ty ppf (tag, tys) = 135 | fprintf ppf "%s(%a)" tag 136 | (pp_print_comma_list Type.pp) tys 137 | in 138 | let xs = Interface.bindings (WithPos.node iface) in 139 | fprintf ppf "interface %s { %a }" 140 | (Interface.name (WithPos.node iface) ) 141 | (pp_print_comma_list pp_msg_ty) xs 142 | (* Declarations *) 143 | and pp_decl ppf decl = 144 | let { decl_name; decl_parameters; decl_return_type; decl_body } = 145 | WithPos.node decl 146 | in 147 | fprintf ppf "def %s(%a): %a {@,@[ %a@]@,}" 148 | decl_name 149 | (pp_print_comma_list pp_param) decl_parameters 150 | Type.pp decl_return_type 151 | pp_expr decl_body 152 | (* Messages *) 153 | and pp_message ppf (tag, es) = 154 | fprintf ppf "%s(%a)" 155 | tag 156 | (pp_print_comma_list pp_expr) es 157 | (* Parameters *) 158 | and pp_param ppf (param, ty) = fprintf ppf "%s: %a" param Type.pp ty 159 | and pp_let_annot ppf ty = fprintf ppf ": %a" Type.pp ty 160 | and pp_bnd_ann ppf (bnd, ann) = 161 | fprintf ppf 162 | "%s%a" 163 | bnd 164 | pp_let_annot ann 165 | (* Expressions *) 166 | and pp_expr ppf expr_with_pos = 167 | (* Might want, at some stage, to print out pretype info *) 168 | let expr_node = WithPos.node expr_with_pos in 169 | match expr_node with 170 | | Var x -> pp_print_string ppf x 171 | | Atom x -> pp_print_string ppf (":" ^ x) 172 | | Primitive x -> pp_print_string ppf x 173 | | Annotate (expr, ty) -> 174 | fprintf ppf "(%a : %a)" pp_expr expr Type.pp ty 175 | | Constant c -> Constant.pp ppf c 176 | | Lam { linear; parameters; body; result_type } -> 177 | let lin = if linear then "linfun" else "fun" in 178 | fprintf ppf "%s(%a): %a {@, @[%a@]@,}" 179 | lin 180 | (pp_print_comma_list pp_param) parameters 181 | Type.pp result_type 182 | pp_expr body 183 | | Let { binder; annot; term; body } -> 184 | fprintf ppf "let %s%a = @[%a@] in@,%a" 185 | binder 186 | (pp_print_option pp_let_annot) annot 187 | pp_expr term 188 | pp_expr body 189 | | If { test; then_expr; else_expr } -> 190 | fprintf ppf "if (%a) {@[%a@]} else {@[%a@]}}" 191 | pp_expr test 192 | pp_expr then_expr 193 | pp_expr else_expr 194 | | Seq (e1, e2) -> 195 | fprintf ppf "(%a;@,%a)" pp_expr e1 pp_expr e2 196 | | App { func; args } -> 197 | fprintf ppf "%a(%a)" 198 | pp_expr func 199 | (pp_print_comma_list pp_expr) args 200 | | New iname -> fprintf ppf "new[%s]" iname 201 | | Spawn e -> fprintf ppf "spawn {@[@,%a@]@,}" pp_expr e 202 | | Send { target; message; _ (* iname *) } -> 203 | (* Special-case the common case of sending to a variable. 204 | Bracket the rest for readability. *) 205 | begin 206 | match WithPos.node target with 207 | | Var _ -> 208 | fprintf ppf "%a ! %a" 209 | pp_expr target 210 | pp_message message 211 | | _ -> 212 | fprintf ppf "(@[%a@]) ! %a" 213 | pp_expr target 214 | pp_message message 215 | end 216 | | Inl e -> fprintf ppf "inl %a" pp_expr e 217 | | Inr e -> fprintf ppf "inr %a" pp_expr e 218 | | Case { term; branch1 = (bnd1, e1); branch2 = (bnd2, e2) } -> 219 | fprintf 220 | ppf 221 | "case %a of {@[@[inl %a -> [@%a@]@][@inr %a -> [@%a@]@]@]}" 222 | pp_expr term 223 | pp_bnd_ann bnd1 224 | pp_expr e1 225 | pp_bnd_ann bnd2 226 | pp_expr e2 227 | | Tuple es -> 228 | fprintf ppf "(%a)" (pp_print_comma_list pp_expr) es 229 | | LetTuple { binders = bs; annot = None; term; cont } -> 230 | fprintf ppf "let (%a) = %a in %a" 231 | (pp_print_comma_list pp_print_string) bs 232 | pp_expr term 233 | pp_expr cont 234 | | LetTuple { binders = bs; annot = Some ts; term; cont } -> 235 | assert (List.length bs = List.length ts); 236 | fprintf ppf "let (%a) : (%a) = %a in %a" 237 | (pp_print_comma_list pp_print_string) bs 238 | (pp_print_comma_list Type.pp) ts 239 | pp_expr term 240 | pp_expr cont 241 | | Guard { target; pattern; guards; _ } -> 242 | fprintf ppf 243 | "guard %a : %a {@,@[ %a@]@,}" 244 | pp_expr target 245 | Type.Pattern.pp pattern 246 | (pp_print_newline_list pp_guard) guards 247 | | Free e -> fprintf ppf "free(%a)" pp_expr e 248 | | SugarFail (e, ty) -> fprintf ppf "fail(%a)[%a]" pp_expr e Type.pp ty 249 | and pp_guard ppf guard_with_node = 250 | let guard_node = WithPos.node guard_with_node in 251 | match guard_node with 252 | | Receive { tag; payload_binders; mailbox_binder; cont } -> 253 | fprintf ppf "receive %s(%a) from %s ->@,@[ %a@]" 254 | tag 255 | (pp_print_comma_list pp_print_string) payload_binders 256 | mailbox_binder 257 | pp_expr cont 258 | (* 259 | free -> M 260 | can be treated as syntactic sugar for 261 | empty(x) -> free(x); M 262 | *) 263 | | GFree e -> 264 | fprintf ppf "free ->@, @[%a@]" pp_expr e 265 | | Empty (x, e) -> 266 | fprintf ppf "empty(%s) ->@, @[%a@]" x pp_expr e 267 | | Fail ty -> 268 | fprintf ppf "fail[%a]" Type.pp ty 269 | 270 | (* Probably prettier ways of doing this... *) 271 | let show_program prog = asprintf "%a" pp_program prog 272 | let show_expr expr = asprintf "%a" pp_expr expr 273 | 274 | (* Substitutes a pattern solution through the program *) 275 | let substitute_solution sol = 276 | let visitor = 277 | object 278 | inherit [_] map 279 | 280 | method! visit_PatVar _env x = 281 | match StringMap.find_opt x sol with 282 | | Some ty -> ty 283 | | None -> Type.Pattern.PatVar x 284 | end 285 | in 286 | visitor#visit_program () 287 | 288 | -------------------------------------------------------------------------------- /lib/common/ir.ml: -------------------------------------------------------------------------------- 1 | (* FGCBV IR *) 2 | open Common_types 3 | open Format 4 | open Util.Utility 5 | open Source_code 6 | 7 | module Binder = struct 8 | type t = { id: int; name: string } 9 | [@@name "binder"] 10 | [@@deriving visitors { variety = "map"; data = false }] 11 | 12 | (* Accessors *) 13 | let id x = x.id 14 | let name x = x.name 15 | 16 | let source = ref 0 17 | 18 | let gen () = 19 | let res = !source in 20 | incr source; 21 | res 22 | 23 | let make ?(name="") () = 24 | { id = gen (); name = name } 25 | 26 | (* Display *) 27 | let pp ppf x = 28 | let prefix = 29 | if x.name = "" then "_" else x.name in 30 | Format.pp_print_string ppf (prefix ^ (string_of_int x.id)) 31 | end 32 | 33 | module Var = struct 34 | type t = { id: int; name: string } 35 | [@@name "var"] 36 | [@@deriving visitors { variety = "map"; data = false }] 37 | 38 | (* Accessors *) 39 | let id x = x.id 40 | let name x = x.name 41 | 42 | (* Display *) 43 | let pp ppf x = 44 | let prefix = 45 | if x.name = "" then "_" else x.name in 46 | Format.pp_print_string ppf (prefix ^ (string_of_int x.id)) 47 | 48 | let pp_name ppf x = 49 | Format.pp_print_string ppf x.name 50 | 51 | let unique_name = 52 | Format.asprintf "%a" pp 53 | 54 | let of_binder : Binder.t -> t = fun x -> 55 | { id = Binder.id x; name = Binder.name x } 56 | 57 | let compare x1 x2 = 58 | compare (unique_name x1) (unique_name x2) 59 | end 60 | 61 | 62 | type program = { 63 | prog_interfaces: ((Interface.t[@name "interface"]) WithPos.t [@name "withP"]) list; 64 | prog_decls: (decl WithPos.t [@name "withP"]) list; 65 | prog_body: comp option 66 | } 67 | and decl = { 68 | decl_name: (Binder.t[@name "binder"]); 69 | decl_parameters: ((Binder.t[@name "binder"]) * (Type.t[@name "ty"])) list; 70 | decl_return_type: (Type.t[@name "ty"]); 71 | decl_body: comp 72 | } 73 | and comp = (comp_node WithPos.t [@name "withP"]) 74 | and comp_node = 75 | | Annotate of comp * (Type.t[@name "ty"]) 76 | | Let of { 77 | binder: (Binder.t[@name "binder"]); 78 | term: comp; 79 | cont: comp 80 | } 81 | | Seq of (comp * comp) 82 | | Return of value 83 | | App of { 84 | func: value; 85 | args: value list 86 | } 87 | | If of { test: value; then_expr: comp; else_expr: comp } 88 | | LetTuple of { 89 | (* By annotating with inferred pretypes, we can always use a checking rule 90 | during inference, irrespective of whether both of the binders are used. *) 91 | binders: ((Binder.t[@name "binder"]) * (Pretype.t[@name "pretype"]) option) list; 92 | tuple: value; 93 | cont: comp 94 | } 95 | | Case of { 96 | term: value; 97 | branch1: ((Binder.t[@name "binder"]) * (Type.t[@name "ty"])) * comp; 98 | branch2: ((Binder.t[@name "binder"]) * (Type.t[@name "ty"])) * comp 99 | } 100 | | New of string 101 | | Spawn of comp 102 | | Send of { 103 | target: value; 104 | message: (message[@name "msg"]); 105 | iname: string option 106 | } 107 | | Free of (value * string option) 108 | | Guard of { 109 | target: value; 110 | pattern: (Type.Pattern.t[@name "pattern"]); 111 | guards: guard list; 112 | iname: string option 113 | } 114 | and value = (value_node WithPos.t [@name "withP"]) 115 | and value_node = 116 | | VAnnotate of value * (Type.t[@name "ty"]) 117 | | Atom of atom_name 118 | | Constant of constant 119 | | Primitive of primitive_name 120 | | Variable of (Var.t[@name "var"]) * (Pretype.t[@name "pretype"]) option 121 | | Tuple of value list 122 | | Inl of value 123 | | Inr of value 124 | | Lam of { 125 | linear: bool; 126 | parameters: ((Binder.t[@name "binder"]) * (Type.t[@name "ty"])) list; 127 | result_type: (Type.t[@name "ty"]); 128 | body: comp 129 | } 130 | and message = (string * value list) 131 | [@@name "msg"] 132 | and primitive_name = string 133 | and atom_name = string 134 | and constant = 135 | [%import: Common_types.Constant.t] 136 | and guard = (guard_node WithPos.t [@name "withP"]) 137 | and guard_node = 138 | | Receive of { 139 | tag: string; 140 | payload_binders: (Binder.t[@name "binder"]) list; 141 | mailbox_binder: (Binder.t[@name "binder"]); 142 | cont: comp 143 | } 144 | | Empty of ((Binder.t[@name "binder"]) * comp) 145 | | Fail 146 | [@@deriving visitors { 147 | variety = "map"; 148 | ancestors = [ 149 | "Type.map"; "Pretype.map"; "Binder.map"; 150 | "Interface.map"; "Var.map"; "WithPos.map"]; 151 | data = false }, 152 | show] 153 | 154 | (* Pretty-printing of the AST *) 155 | (* Programs *) 156 | let rec pp_program ppf { prog_interfaces; prog_decls; prog_body } = 157 | fprintf ppf "%a@.%a@.@.%a" 158 | (pp_print_newline_list pp_interface) prog_interfaces 159 | (pp_print_double_newline_list pp_decl) prog_decls 160 | (pp_print_option pp_comp) prog_body 161 | (* Interfaces *) 162 | and pp_interface ppf iface = 163 | let pp_msg_ty ppf (tag, tys) = 164 | fprintf ppf "%s(%a)" tag 165 | (pp_print_comma_list Type.pp) tys 166 | in 167 | let xs = Interface.bindings (WithPos.node iface) in 168 | fprintf ppf "interface %s { %a }" 169 | (Interface.name (WithPos.node iface)) 170 | (pp_print_comma_list pp_msg_ty) xs 171 | (* Declarations *) 172 | and pp_decl ppf decl_with_pos = 173 | let { WithPos.node = { decl_name; decl_parameters; decl_return_type; decl_body }; _ } = decl_with_pos in 174 | fprintf ppf "def %a(%a): %a {@,@[ %a@]@,}" 175 | Binder.pp decl_name 176 | (pp_print_comma_list pp_param) decl_parameters 177 | Type.pp decl_return_type 178 | pp_comp decl_body 179 | (* Messages *) 180 | and pp_message ppf (tag, vs) = 181 | fprintf ppf "%s(%a)" 182 | tag 183 | (pp_print_comma_list pp_value) vs 184 | (* Parameters *) 185 | and pp_param ppf (param, ty) = fprintf ppf "%a: %a" Binder.pp param Type.pp ty 186 | and pp_branch name ppf ((bnd, ty), c) = 187 | fprintf ppf "%s(%a): %a -> @[%a@]" 188 | name 189 | Binder.pp bnd 190 | Type.pp ty 191 | pp_comp c 192 | (* Expressions *) 193 | and pp_comp ppf comp_with_pos = 194 | let comp_node = WithPos.node comp_with_pos in 195 | match comp_node with 196 | | Annotate (c, ty) -> 197 | fprintf ppf "(%a : %a)" pp_comp c Type.pp ty 198 | | Seq (c1, c2) -> 199 | fprintf ppf "(%a;@,%a)" pp_comp c1 pp_comp c2 200 | | Let { binder; term; cont } -> 201 | fprintf ppf "let %a = @[%a@] in@,%a" 202 | Binder.pp binder 203 | pp_comp term 204 | pp_comp cont 205 | | Return v -> pp_value ppf v 206 | | Free (v, _) -> 207 | fprintf ppf "free(%a)" pp_value v 208 | | If { test; then_expr; else_expr } -> 209 | fprintf ppf "if (%a) {@[%a@]} else {@[%a@]}}" 210 | pp_value test 211 | pp_comp then_expr 212 | pp_comp else_expr 213 | | App { func; args } -> 214 | fprintf ppf "%a(%a)" 215 | pp_value func 216 | (pp_print_comma_list pp_value) args 217 | | New iname -> fprintf ppf "new[%s]" iname 218 | | Spawn e -> fprintf ppf "spawn {@[@,%a@]@,}" pp_comp e 219 | | Send { target; message; _ (* iname *) } -> 220 | (* Special-case the common case of sending to a variable. 221 | Bracket the rest for readability. *) 222 | begin 223 | match WithPos.node target with 224 | | Variable _ -> 225 | fprintf ppf "%a ! %a" 226 | pp_value target 227 | pp_message message 228 | | _ -> 229 | fprintf ppf "(@[%a@]) ! %a" 230 | pp_value target 231 | pp_message message 232 | end 233 | | LetTuple { binders = bs; tuple; cont } -> 234 | let bs = List.map fst bs in 235 | fprintf ppf "let %a = @[%a@] in@,%a" 236 | (pp_print_comma_list Binder.pp) bs 237 | pp_value tuple 238 | pp_comp cont 239 | | Case { term; branch1; branch2 } -> 240 | fprintf ppf 241 | "case %a of {@[@[%a@]@,@[%a@]@]}" 242 | pp_value term 243 | (pp_branch "inl") branch1 244 | (pp_branch "inr") branch2 245 | | Guard { target; pattern; guards; _ } -> 246 | fprintf ppf 247 | "guard %a : %a {@,@[ %a@]@,}" 248 | pp_value target 249 | Type.Pattern.pp pattern 250 | (pp_print_newline_list pp_guard) guards 251 | and pp_value ppf v = 252 | let value = WithPos.node v in 253 | match value with 254 | (* Might want, at some stage, to print out pretype info *) 255 | | VAnnotate (value, ty) -> 256 | fprintf ppf "(%a : %a)" pp_value value Type.pp ty 257 | | Atom name -> Format.pp_print_string ppf (":" ^ name) 258 | | Primitive prim -> Format.pp_print_string ppf prim 259 | | Variable (var, _) -> Var.pp ppf var 260 | | Constant c -> Constant.pp ppf c 261 | | Tuple vs -> 262 | fprintf ppf "%a" (pp_print_comma_list pp_value) vs 263 | | Inl v -> fprintf ppf "inl(%a)" pp_value v 264 | | Inr v -> fprintf ppf "inr(%a)" pp_value v 265 | | Lam { linear; parameters; result_type; body } -> 266 | let lin = if linear then "linfun" else "fun" in 267 | fprintf ppf "%s(%a): %a {@, @[%a@]@,}" 268 | lin 269 | (pp_print_comma_list pp_param) parameters 270 | Type.pp result_type 271 | pp_comp body 272 | and pp_guard ppf guard_with_pos = 273 | let guard_node = WithPos.node guard_with_pos in 274 | match guard_node with 275 | | Receive { tag; payload_binders; mailbox_binder; cont } -> 276 | fprintf ppf "receive %s(%a) from %a ->@,@[ %a@]" 277 | tag 278 | (pp_print_comma_list Binder.pp) payload_binders 279 | Binder.pp mailbox_binder 280 | pp_comp cont 281 | | Empty (x, e) -> 282 | fprintf ppf "empty(%a) ->@, @[%a@]" Binder.pp x pp_comp e 283 | | Fail -> 284 | fprintf ppf "fail" 285 | 286 | let unit = Tuple [] 287 | 288 | let is_receive_guard = function 289 | | Receive _ -> true 290 | | _ -> false 291 | 292 | let is_free_guard = function 293 | | Free _ -> true 294 | | _ -> false 295 | 296 | let is_fail_guard guard = 297 | match WithPos.node guard with 298 | | Fail -> true 299 | | _ -> false 300 | 301 | 302 | (* Substitutes a pattern solution through the program *) 303 | let substitute_solution sol = 304 | let visitor = 305 | object 306 | inherit [_] map 307 | 308 | method! visit_PatVar _env x = 309 | match StringMap.find_opt x sol with 310 | | Some ty -> ty 311 | | None -> Type.Pattern.PatVar x 312 | end 313 | in 314 | visitor#visit_program () 315 | 316 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MBCheck: A typechecker for the Pat language 2 | 3 | ## About 4 | This project is a typechecker for the Pat language, introduced in the paper 5 | [Special Delivery: Programming with Mailbox Types](https://simonjf.com/drafts/pat-draft-mar23.pdf). 6 | 7 | This paper extends the mailbox typing discipline 8 | introduced by de' Liguoro and Padovani at ECOOP 2018 9 | (https://drops.dagstuhl.de/opus/volltexte/2018/9220/pdf/LIPIcs-ECOOP-2018-15.pdf) 10 | to the setting of a programming language. 11 | 12 | ## Credits 13 | 14 | Several core ideas of our typechecking algorithm originated in the following, both by [Luca Padovani](https://boystrange.github.io/index.html): 15 | 16 | * [MCC](https://boystrange.github.io/mcc/) 17 | * [A type checking algorithm for concurrent object protocols](https://www.sciencedirect.com/science/article/pii/S2352220817301463) 18 | 19 | ## Installation 20 | 21 | The type checker for `Pat` is developed in OCaml, a general-purpose functional programming language. OCaml can be installed by following these instructions. 22 | 23 | ### macOS 24 | 25 | The easiest way to install OCaml on macOS is to use the Homebrew package manager. Homebrew can be downloaded and installed by following the instructions on the [website](https://brew.sh). Once Homebrew is installed and configured, the latest OCaml package manager, `opam`, can be installed as shown: 26 | 27 | ```bash 28 | $ brew install opam 29 | ``` 30 | 31 | ### Ubuntu 32 | 33 | `opam` on Ubuntu Linux can be installed via the `apt` package manager. 34 | 35 | ```bash 36 | $ sudo add-apt-repository ppa:avsm/ppa 37 | $ sudo apt update 38 | $ sudo apt install opam 39 | ``` 40 | 41 | On Ubuntu, one also needs to install `libgmp-dev`, which is a development library for the GMP (GNU Multiple Precision Arithmetic) that provides functions for performing arithmetic operations on large numbers. This library is used by the Z3 constraint solver invoked externally by the 'Pat' type checker. 42 | 43 | ```bash 44 | sudo apt install libgmp-dev 45 | ``` 46 | 47 | 48 | 49 | ### Initialising `opam` 50 | 51 | The next step is to initialise `opam`: 52 | 53 | ```bash 54 | $ opam init 55 | ``` 56 | 57 | Once the initialisation is completed, the following command updates the current shell environment. 58 | 59 | ```bash 60 | $ eval $(opam env --switch=default) 61 | ``` 62 | 63 | 64 | 65 | ## Downloading and building the `Pat` type checker 66 | 67 | `Pat` can be cloned from this GitHub repository as follows. 68 | 69 | ```bash 70 | $ git clone https://github.com/SimonJF/mbcheck.git 71 | ``` 72 | 73 | The `Pat` type checker uses a number of OCaml libraries that should be installed prior to compiling it. 74 | 75 | ```bash 76 | $ opam install dune menhir ppx_import visitors cmdliner z3 bag 77 | ``` 78 | 79 | The type-checking tool can then be compiled using `make` after installing these dependencies. 80 | 81 | ```bash 82 | $ cd mbcheck 83 | mbcheck$ make 84 | ``` 85 | 86 | 87 | ## Running 88 | 89 | Usage: `./mbcheck `. If the program completes successfully, then the 90 | program is correct. 91 | 92 | For more information, you can use the `-d` (debug) and `-v` (verbose) flags -- 93 | although the outputs of these are currently pretty unpleasant :) 94 | 95 | ## Mailbox Types 96 | 97 | Mailbox types characterise communication with *mailboxes*: incoming message queues with 98 | many writers and a single reader. 99 | 100 | In short, mailbox types consist of a *capability* : either ! for output, similar 101 | to a PID in Erlang, or ? for input; and a *pattern* which characterises the 102 | 103 | A pattern is a *commutative regular expression* which denotes the pattern of 104 | messages contained within that mailbox (for input capabilities), or the pattern 105 | of messages which must be sent (for output capabilities). 106 | 107 | There are various patterns: 108 | 109 | * 0: the unreliable mailbox (denotes an error) 110 | * 1: the empty mailbox 111 | * M: a message with tag M 112 | * E + F: either pattern E or pattern F 113 | * E . F: pattern E or F in any order 114 | * *E: many instances of pattern E 115 | 116 | As a concrete example, the receive endpoint for an empty future can be given the 117 | type 118 | 119 | ?(Put.*Get) 120 | 121 | which states that the mailbox contains at most one Put message and many Get 122 | messages; this would rule out the invalid behaviour of sending two Put messages. 123 | 124 | ## Base types 125 | 126 | Pat also supports base types: String, Int, Bool. 127 | 128 | ## Usable vs. Returnable Types 129 | 130 | In order to avoid some horrible name hygiene issues, Pat uses *quasi-linear 131 | typing*. In essence, this means that mailbox names can be used at most once in a 132 | thread as a 'full' name (i.e., being allowed to be returned as part of an 133 | expression, stored as part of a data type, etc.), and other times as a 'partial' 134 | or 'second-class' name (allowing it to be used as part of an expression -- e.g., 135 | sending or passing as an argument). 136 | 137 | Furthermore, the full or 'returnable' use must be the final lexical use of the 138 | name. 139 | 140 | Another point is that when receiving a mailbox name as part of a message, this 141 | can only be treated as usable (and may not, therefore, escape the scope of the 142 | `receive`). 143 | 144 | These restrictions in turn rule out bad aliasing, use-after-free, and 145 | self-deadlocks. 146 | 147 | ## Language Guide 148 | 149 | Pat is a concurrent functional language with first-class mailboxes and mailbox 150 | types. Examples can be found in the `examples` directory, but here we go over 151 | some of the main points here. 152 | 153 | ### Interfaces 154 | 155 | A message consists of a tag (i.e., a message name) and a list of message 156 | payloads. 157 | 158 | An *interface* describes the messages that a mailbox can receive. 159 | Note that it does *not* describe any sequencing or pattern information about the 160 | message. As an example, the interface for the `Future` example is as follows: 161 | 162 | ``` 163 | interface Future { Put(Int), Get(User!) } 164 | interface User { Reply(Int) } 165 | ``` 166 | 167 | Here, we can see that the `Future` interface says that a `Future` mailbox can 168 | receive a `Put` message (with an `Int` payload), and a `Get` message (with a 169 | `User!` payload), but it does not describe the invariant that the mailbox can 170 | only contain a single Put message, for example. Interfaces are used to provide 171 | type information for the inference pass. 172 | 173 | ### Programs 174 | 175 | A Pat program consists of a series of *definitions* followed by a *body*. 176 | 177 | Pat has very limited support for first-class functions, so instead a Pat program 178 | typically consists of a series of *definitions*, which are explicitly annotated 179 | with argument and return types, and contain an expression. 180 | Definitions must be declared at the top level, and do not close over any values. 181 | 182 | The body is a single expression, defined at the end of a file; a definition can 183 | be called in the usual way. 184 | 185 | Here is a simple Pat program: 186 | 187 | ``` 188 | def addTwoNumbers(x: Int, y: Int): Int { 189 | x + y 190 | } 191 | 192 | addTwoNumbers(10, 15) 193 | ``` 194 | 195 | This would have type Int. 196 | 197 | ### Basic Language Features 198 | 199 | As a functional language, Pat has immutable data. Therefore, typically a Pat 200 | expression consists of `let` bindings for intermediate computation steps: 201 | 202 | ``` 203 | let x = 5 in 204 | let y = 10 in 205 | x + y 206 | ``` 207 | 208 | Variables `x` and `y` are standard. 209 | 210 | Pat also includes side-effecting operations (such as sending messages), so we 211 | also allow sequencing `e1; e2` where `e1` returns the unit value `()`. 212 | The unit value is a value which conveys no information and is often used as a 213 | return value for side-effecting operations. 214 | 215 | ### Concurrency Primitives 216 | 217 | A mailbox is a message queue which can be written to by many processes, but read 218 | by only one. In the actor model, a mailbox is associated with every process, and 219 | messages are sent to that particular process ID. 220 | 221 | #### Spawn 222 | 223 | The `spawn M` construct spawns a term as a new process. Since the process will 224 | run concurrently, all usages are masked as 2nd-class. For example, whereas the 225 | following will not compile: 226 | 227 | ``` 228 | guard x : M { receive M() -> free(x) }; 229 | x ! M() 230 | ``` 231 | 232 | (since the first `guard` is returnable) 233 | 234 | the following is permitted, since the `guard` is in a separate thread: 235 | 236 | ``` 237 | spawn { guard x : M { receive M() -> free(x) } }; 238 | x ! M() 239 | ``` 240 | 241 | #### Mailbox creation (new) 242 | 243 | The mailbox calculus decouples *creation* of a mailbox from the process with 244 | which it is associated. For this, we use the `new` construct: 245 | 246 | `let mb = new[InterfaceName] in ...` 247 | 248 | Here, `mb` will have type `?1`, denoting that all messages must have been 249 | received. 250 | 251 | #### Message send 252 | 253 | To send a message to a mailbox, we use the `!` construct, which is similar to 254 | Erlang. 255 | 256 | `mb ! Foo(10)` 257 | 258 | Here, we are sending a message with tag `Foo` and payload `10` to mailbox `mb`. 259 | In this case, as a result of the send, `mb` will have type `!Foo`. By sending to 260 | a mailbox reference, we create an obligation that the message must be received 261 | by that mailbox. 262 | 263 | 264 | #### Guards 265 | 266 | Erlang has a `receive` statement to retrieve messages from a mailbox. The 267 | analogous construct in Pat is `guard`, which is slightly generalised in that it 268 | also allows us to free a mailbox that we know isn't being used. 269 | 270 | As an example, here is a guard expression on a mailbox for a mailbox with type 271 | `(M . N) + 1` (i.e., a mailbox which either has both `M` and `N` messages, or 272 | does not contain any messages) 273 | 274 | ``` 275 | interface Test { M(Int), N(Int) } 276 | 277 | let mb = new[Test] in 278 | if (rand()) then { 279 | spawn { mb ! M(5) }; 280 | spawn { mb ! N(10) } 281 | } else { 282 | () 283 | }; 284 | in 285 | guard mb : (M . N) + 1 { 286 | free -> () 287 | receive M(x) from mb -> 288 | guard mb : N { 289 | receive N[y] from mb -> free(mb) 290 | } 291 | receive N(x) from mb -> 292 | guard mb : M { 293 | receive M[y] from mb -> free(mb) 294 | } 295 | } 296 | ``` 297 | 298 | Note that in the `receive` clauses, the variable after `from` is a *binding* 299 | occurrence. 300 | 301 | Here, we specify the mailbox name we're guarding on (in this case, `mb`), along 302 | with the pattern it currently contains (`(M . N) + 1`). We then add three guard 303 | clauses: 304 | 305 | * `free` which handles the case where there are no messages in the mailbox, 306 | and the mailbox can be freed. Note that `mb` is not re-bound and so is 307 | unusable. 308 | 309 | * `receive M(x) from mb -> ...` which receives a message `M` from the mailbox, 310 | re-binding the mailbox name to `mb` with type `?N` 311 | 312 | * `receive N(x) from mb -> ...` which receives a message `N` from the mailbox, 313 | re-binding the mailbox name to `mb` with type `?M` 314 | 315 | In both of the receive clauses, we need a further receive to clear the other 316 | message. 317 | 318 | We can also write `free(mb)` as syntactic sugar for the more verbose: 319 | 320 | ``` 321 | guard mb : 1 { free -> () } 322 | ``` 323 | 324 | ## Overview of salient code locations 325 | * Lexer: `lib/frontend/lexer.mll` 326 | * Parser: `lib/frontend/parser.mly` 327 | * Desugaring: `lib/frontend/desugar_sugared_guards.ml` and 328 | `lib/frontend/insert_pattern_variables.ml` 329 | * IR conversion: `lib/frontend/sugar_to_ir.ml` 330 | * Constraint generation (backwards bidirectional typing): 331 | `lib/typecheck/gen_cosntraints.ml` 332 | * Constraint solving: `lib/typecheck/solve_constraints.ml` and 333 | `lib/typecheck/z3_solver.ml` 334 | * Examples: `test/examples` 335 | * Examples deliberately raising errors: `test/errors` 336 | --------------------------------------------------------------------------------