├── docs ├── .nojekyll ├── CNAME ├── handlers-tutorial.pdf └── try │ ├── effmode.js │ └── examples │ ├── syntax.eff │ ├── state.eff │ ├── probability.eff │ ├── threads.eff │ └── printing.eff ├── .ocamlformat ├── src ├── 00-utils │ ├── dune │ ├── option.ml │ ├── location.mli │ ├── utils.ml │ ├── error.ml │ ├── config.ml │ ├── list.mli │ ├── symbols.ml │ ├── list.ml │ ├── symbol.mli │ ├── error.mli │ ├── config.mli │ ├── location.ml │ ├── assoc.ml │ └── print.ml ├── eff │ ├── eff.mli │ └── dune ├── 01-language │ ├── dune │ ├── effect.ml │ ├── tyName.ml │ ├── tyScheme.ml │ ├── tyParam.ml │ ├── const.mli │ ├── backend.ml │ ├── dirt.ml │ ├── const.ml │ ├── untypedSyntax.mli │ └── skeleton.ml ├── 05-backends │ ├── runtime │ │ ├── runtime.mli │ │ ├── dune │ │ ├── eval.mli │ │ ├── runtime.ml │ │ └── value.ml │ ├── plain-ocaml │ │ ├── plainOCaml.mli │ │ ├── dune │ │ └── primitives.ml │ └── multicore-ocaml │ │ ├── multicoreOCaml.mli │ │ ├── dune │ │ ├── translate.mli │ │ ├── symbol.ml │ │ ├── syntax.mli │ │ └── primitives.ml ├── 03-typechecker │ ├── dune │ ├── typeDefinitionContext.mli │ └── exhaust.mli ├── 04-optimizer │ └── dune ├── 02-parser │ ├── README.md │ ├── dune │ ├── commands.ml │ └── desugarer.mli ├── jseff │ ├── dune │ └── jseff.ml └── 06-loader │ ├── dune │ └── shell.mli ├── tests ├── codegen │ ├── norec.eff │ ├── compose.eff │ ├── test3.eff │ ├── rec1.eff │ ├── rec2.eff │ ├── test4.eff │ ├── application_red.eff │ ├── interp.eff │ ├── let_list_to_bind.eff │ ├── loop.eff │ ├── parser.eff │ ├── queens.eff │ ├── range.eff │ ├── tree.eff │ ├── optimize_short_circuit.eff │ ├── match_red.eff │ ├── test2.eff │ ├── test5.eff │ ├── poly_bind.eff │ ├── map.eff │ ├── capability_benchmarks.eff │ ├── optimize_pattern_match.eff │ ├── test1.eff │ ├── test17.eff │ ├── test-handle_effect_skip.eff │ ├── substitution.eff │ ├── test6.eff │ ├── test14.eff │ ├── test20.eff │ ├── test7.eff │ ├── ifthenelse.eff │ ├── test8.eff │ ├── test9.eff │ ├── original.eff │ ├── not-found.eff │ ├── test10.eff │ ├── test12.eff │ ├── test18.eff │ ├── test11.eff │ ├── handler_beta_reduction.eff │ ├── reuse_toplevel_handler.eff │ ├── test13.eff │ ├── is_relatively_pure.eff │ ├── test21.eff │ ├── one_input.eff │ ├── test19.eff │ ├── test15.eff │ ├── test16.eff │ ├── handle_rec.eff │ ├── redefine_local.eff │ ├── two_inputs.eff │ ├── handle_match.eff │ ├── top-letrec_fails.eff │ ├── break-split.eff │ ├── other-effect.eff │ ├── nested_handlers.eff │ ├── pm-3_passes.eff │ ├── pm-2_passes.eff │ ├── pm-1_fails.eff │ └── constant_folding_match.eff ├── ocamlHeader.ml ├── invalid │ ├── occurs_check.eff │ ├── duplicate_let_toplevel.eff │ ├── shadow_eff.eff │ ├── duplicate_let.eff │ ├── less_than_handler.eff │ ├── less_than_function.eff │ ├── non_linear_pattern.eff │ ├── polymorphism_id_id.eff │ ├── shadow_field.eff │ ├── shadow_label.eff │ ├── shadow_type.eff │ ├── invalid_match_type.eff │ ├── use_undefined_type.eff │ ├── malformed_type_application.eff │ ├── duplicate_field_tydef_record.eff │ ├── duplicate_variant_tydef_sum.eff │ ├── less_than_complex.eff │ ├── non_linear_record.eff │ └── duplicate_operation_tydef_effect.eff ├── dune ├── valid │ ├── semisemi.eff │ ├── higher_order_op.eff │ ├── orelse_andalso.eff │ ├── polymorphism.eff │ ├── test1.eff │ ├── lexer.eff │ ├── test_equality.eff │ ├── patterns.eff │ ├── tydef.eff │ ├── test_less_than.eff │ ├── typing.eff │ ├── type_annotations.eff │ ├── state.eff │ └── choice.eff └── README.markdown ├── ocamlHeader └── dune ├── misc ├── code-generation-benchmarks │ ├── generate-graphs │ │ ├── tables │ │ │ └── .gitkeep │ │ └── dune │ ├── benchmark-suite │ │ ├── config.plain.ml │ │ ├── native_multicore │ │ │ ├── .ocamlformat-ignore │ │ │ ├── dune │ │ │ ├── rangeMulticore.ml │ │ │ ├── rangeMulticoreCustomList.ml │ │ │ ├── queensMulticore.ml │ │ │ ├── loopMulticore.ml │ │ │ ├── queensMulticoreTranslated.ml │ │ │ └── capabilityBenchmarks.ml │ │ ├── .ocamlformat-ignore │ │ ├── rangeNative.ml │ │ ├── dune │ │ ├── rangeOpt.ml │ │ ├── loopNative.ml │ │ ├── range.eff │ │ ├── loop.eff │ │ ├── generate_benchmark_rules.ml │ │ ├── queensNative.ml │ │ ├── queens.eff │ │ └── loopOpt.ml │ └── display-results │ │ └── dune ├── type-inference-time-complexity │ ├── stat │ │ ├── dummy_timing.txt │ │ ├── dummy10_timing_100_runs.txt │ │ ├── dummy60_timing_100_runs.txt │ │ ├── dummy70_timing_100_runs.txt │ │ ├── dummy80_timing_100_runs.txt │ │ ├── dummy90_timing_100_runs.txt │ │ ├── dummy_fun20_timing_100_runs.txt │ │ ├── dummy_fun40_timing_100_runs.txt │ │ ├── dummy_fun50_timing_100_runs.txt │ │ ├── dummy_fun60_timing_100_runs.txt │ │ ├── dummy_fun100_timing_100_runs.txt │ │ ├── dummy_fun70_timing_100_runs.txt │ │ ├── dummy_fun90_timing_100_runs.txt │ │ ├── dummy100_timing_100_runs.txt │ │ ├── dummy_fun10_timing_100_runs.txt │ │ ├── dummy_fun30_timing_100_runs.txt │ │ ├── dummy_fun80_timing_100_runs.txt │ │ ├── dummy_constraints.txt │ │ ├── dummy_fun_constraints.txt │ │ ├── dummy_fun_type.txt │ │ ├── dummy_type.txt │ │ ├── dummy20_timing_100_runs.txt │ │ ├── dummy30_timing_100_runs.txt │ │ ├── dummy50_timing_100_runs.txt │ │ ├── dummy40_timing_100_runs.txt │ │ ├── bench.m │ │ ├── createfig.m │ │ ├── createfigure.m │ │ ├── dummy_timing_100_runs.txt │ │ ├── 8queens_timing_100_runs.txt │ │ ├── timing.txt │ │ ├── 100dummy_fun_timing_100_runs.txt │ │ ├── 100dummy_timing_100_runs.txt │ │ └── loop_timing_100_runs.txt │ ├── code │ │ ├── dummy.eff │ │ ├── dummy_fun10.eff │ │ ├── dummy_fun20.eff │ │ ├── dummy10.eff │ │ ├── dummy_fun30.eff │ │ ├── dummy_fun40.eff │ │ ├── dummy_fun50.eff │ │ ├── dummy20.eff │ │ └── dummy_fun60.eff │ └── bench.py ├── dune └── old-benchmarks-for-other-systems │ ├── links │ ├── compiling-links-effect-to-ocaml.pdf │ ├── liberating-effects-with-rows-and-handlers.pdf │ ├── compile.sh │ └── install_links.sh │ ├── interp │ ├── interpNative.ml │ ├── multicore.ml │ └── interp.eff │ └── multicoreQueens.ml ├── etc ├── eff.tmbundle │ ├── eff.sublime-build │ ├── Document.sublime-snippet │ ├── begin.sublime-snippet │ ├── let.sublime-snippet │ ├── effect.sublime-snippet │ ├── fun.sublime-snippet │ ├── type-(type).sublime-snippet │ ├── match-pattern.sublime-snippet │ ├── method-(method).sublime-snippet │ ├── let-in.sublime-snippet │ ├── function-label.sublime-snippet │ ├── module.sublime-snippet │ ├── with-handle.sublime-snippet │ ├── While-Loop.sublime-snippet │ ├── module-type.sublime-snippet │ ├── try.sublime-snippet │ ├── module-signature.sublime-snippet │ ├── untitled.sublime-snippet │ ├── func.sublime-snippet │ ├── handle-with.sublime-snippet │ ├── match.sublime-snippet │ ├── For-Loop.sublime-snippet │ ├── class.sublime-snippet │ ├── handler.sublime-snippet │ ├── Symbol List_ Variants.tmPreferences │ ├── Symbol List_ Classes.tmPreferences │ ├── Symbol List_ Types.tmPreferences │ ├── Symbol List_ Exceptions.tmPreferences │ ├── Miscellaneous.tmPreferences │ └── Indent rules.tmPreferences ├── README.txt └── eff-mode.el ├── examples ├── README.txt ├── delimited.eff ├── yield.eff ├── modulus.eff ├── threads.eff ├── amb.eff └── choice.eff ├── .gitignore ├── dune-project ├── .github └── workflows │ ├── test.yml │ └── gh-pages.yml ├── Makefile ├── eff.opam └── LICENSE.txt /docs/.nojekyll: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.25.1 -------------------------------------------------------------------------------- /docs/CNAME: -------------------------------------------------------------------------------- 1 | www.eff-lang.org -------------------------------------------------------------------------------- /src/00-utils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name utils)) 3 | -------------------------------------------------------------------------------- /tests/codegen/norec.eff: -------------------------------------------------------------------------------- 1 | 2 | let f x = () 3 | 4 | -------------------------------------------------------------------------------- /tests/ocamlHeader.ml: -------------------------------------------------------------------------------- 1 | ../ocamlHeader/ocamlHeader.ml -------------------------------------------------------------------------------- /ocamlHeader/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ocamlHeader)) 3 | -------------------------------------------------------------------------------- /tests/codegen/compose.eff: -------------------------------------------------------------------------------- 1 | let compose f g x = f (g x) 2 | -------------------------------------------------------------------------------- /tests/codegen/test3.eff: -------------------------------------------------------------------------------- 1 | handler 2 | | x -> x ;; 3 | -------------------------------------------------------------------------------- /tests/invalid/occurs_check.eff: -------------------------------------------------------------------------------- 1 | let rec f x = f in f;; 2 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/generate-graphs/tables/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_timing.txt: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /tests/codegen/rec1.eff: -------------------------------------------------------------------------------- 1 | 2 | let rec f x = () 3 | in f 1 4 | -------------------------------------------------------------------------------- /tests/codegen/rec2.eff: -------------------------------------------------------------------------------- 1 | 2 | let rec f x = () 3 | in 10 (* f 1 *) 4 | -------------------------------------------------------------------------------- /src/eff/eff.mli: -------------------------------------------------------------------------------- 1 | (** Main eff executable *) 2 | 3 | val main : unit 4 | -------------------------------------------------------------------------------- /tests/codegen/test4.eff: -------------------------------------------------------------------------------- 1 | with (handler 2 | | x -> x) handle 1 ;; 3 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps 3 | ../eff.exe 4 | (source_tree .))) 5 | -------------------------------------------------------------------------------- /src/01-language/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name language) 3 | (libraries utils)) 4 | -------------------------------------------------------------------------------- /src/05-backends/runtime/runtime.mli: -------------------------------------------------------------------------------- 1 | module Backend : Language.Backend.S 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy10_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 3.499; 29 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy60_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 376.3; 179 2 | -------------------------------------------------------------------------------- /src/01-language/effect.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | include Symbol.Make (Symbol.String) 3 | -------------------------------------------------------------------------------- /src/01-language/tyName.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | include Symbol.Make (Symbol.String) 3 | -------------------------------------------------------------------------------- /src/05-backends/plain-ocaml/plainOCaml.mli: -------------------------------------------------------------------------------- 1 | module Backend : Language.Backend.S 2 | -------------------------------------------------------------------------------- /tests/codegen/application_red.eff: -------------------------------------------------------------------------------- 1 | let x = (fun y -> y*2) in 2 | x 3 3 | ;; 4 | -------------------------------------------------------------------------------- /tests/invalid/duplicate_let_toplevel.eff: -------------------------------------------------------------------------------- 1 | let x = 5 2 | and y = 6 3 | and x = 7 4 | -------------------------------------------------------------------------------- /tests/invalid/shadow_eff.eff: -------------------------------------------------------------------------------- 1 | effect A : unit 2 | effect B : unit 3 | effect A : unit -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy70_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 603.826; 209 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy80_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 919.467; 239 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy90_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 1275.375; 269 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun20_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 5.0; 38 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun40_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 33.661; 78 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun50_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 67.854; 98 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun60_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 114.23; 118 2 | -------------------------------------------------------------------------------- /src/03-typechecker/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typechecker) 3 | (libraries language)) 4 | -------------------------------------------------------------------------------- /src/05-backends/runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name runtime) 3 | (libraries language)) 4 | -------------------------------------------------------------------------------- /tests/codegen/interp.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/interp.eff -------------------------------------------------------------------------------- /tests/codegen/let_list_to_bind.eff: -------------------------------------------------------------------------------- 1 | let x = 2 and 2 | y = 1 in 3 | x + y;; 4 | -------------------------------------------------------------------------------- /tests/codegen/loop.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/loop.eff -------------------------------------------------------------------------------- /tests/codegen/parser.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/parser.eff -------------------------------------------------------------------------------- /tests/codegen/queens.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/queens.eff -------------------------------------------------------------------------------- /tests/codegen/range.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/range.eff -------------------------------------------------------------------------------- /tests/codegen/tree.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/tree.eff -------------------------------------------------------------------------------- /tests/invalid/duplicate_let.eff: -------------------------------------------------------------------------------- 1 | let x = 5 2 | and y = 6 3 | and x = 7 4 | in x + y 5 | -------------------------------------------------------------------------------- /tests/invalid/less_than_handler.eff: -------------------------------------------------------------------------------- 1 | (handler x -> 2 * x) < (handler x -> 3 * x) ;; 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun100_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 494.367; 198 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun70_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 173.456; 138 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun90_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 360.313; 178 2 | -------------------------------------------------------------------------------- /tests/codegen/optimize_short_circuit.eff: -------------------------------------------------------------------------------- 1 | let a b c = 2 | if b then c else false 3 | ;; 4 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy100_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 1728.4669999999999; 299 2 | -------------------------------------------------------------------------------- /src/04-optimizer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name optimizer) 3 | (libraries language typechecker)) 4 | -------------------------------------------------------------------------------- /tests/invalid/less_than_function.eff: -------------------------------------------------------------------------------- 1 | (fun x -> x) < (fun x -> 2 * x) ;; (* This breaks. *) 2 | -------------------------------------------------------------------------------- /tests/invalid/non_linear_pattern.eff: -------------------------------------------------------------------------------- 1 | (* A pattern must be linear. *) 2 | let (a,a) = (5,4) 3 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun10_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 1.5130000000000001; 18 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun30_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 15.261000000000001; 58 2 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun80_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 263.11400000000003; 158 2 | -------------------------------------------------------------------------------- /tests/codegen/match_red.eff: -------------------------------------------------------------------------------- 1 | 2 | let x = true in 3 | match x with 4 | | true -> 1 5 | | _ -> 2 6 | -------------------------------------------------------------------------------- /tests/codegen/test2.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | #type perform (Op 1) ; perform (Op 2) ;; 3 | 4 | -------------------------------------------------------------------------------- /tests/codegen/test5.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | handler 4 | | effect (Op n) k -> 2 ;; 5 | -------------------------------------------------------------------------------- /tests/invalid/polymorphism_id_id.eff: -------------------------------------------------------------------------------- 1 | let u x = x;; 2 | let v = u u;; 3 | (v 42, v "foo");; 4 | 5 | -------------------------------------------------------------------------------- /tests/invalid/shadow_field.eff: -------------------------------------------------------------------------------- 1 | type cow = {horn : int} 2 | type bull = {tail : int; horn : string} 3 | -------------------------------------------------------------------------------- /tests/invalid/shadow_label.eff: -------------------------------------------------------------------------------- 1 | type cow = Horn of int 2 | type bull = Tail of string | Horn of bull 3 | -------------------------------------------------------------------------------- /docs/handlers-tutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matijapretnar/eff/HEAD/docs/handlers-tutorial.pdf -------------------------------------------------------------------------------- /tests/codegen/poly_bind.eff: -------------------------------------------------------------------------------- 1 | let f _ = 2 | handle 3 | 1 + 2 4 | with 5 | | _ -> 5 6 | -------------------------------------------------------------------------------- /src/02-parser/README.md: -------------------------------------------------------------------------------- 1 | # Parser 2 | 3 | - grammar.mly is not parser.mly as not to clash with module name 4 | -------------------------------------------------------------------------------- /src/05-backends/plain-ocaml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name plainOCaml) 3 | (libraries utils language typechecker)) 4 | -------------------------------------------------------------------------------- /tests/codegen/map.eff: -------------------------------------------------------------------------------- 1 | let rec map f = 2 | function 3 | | [] -> [] 4 | | x :: xs -> f x :: map f xs -------------------------------------------------------------------------------- /tests/codegen/capability_benchmarks.eff: -------------------------------------------------------------------------------- 1 | ../../misc/code-generation-benchmarks/benchmark-suite/capability_benchmarks.eff -------------------------------------------------------------------------------- /tests/codegen/optimize_pattern_match.eff: -------------------------------------------------------------------------------- 1 | let k b = 2 | let rec a (x,y) z = 3 | (x + y) + z + b 4 | in 5 | a -------------------------------------------------------------------------------- /tests/codegen/test1.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | #type (fun f -> f 1) (fun x -> perform (Op x));; 4 | 5 | -------------------------------------------------------------------------------- /tests/codegen/test17.eff: -------------------------------------------------------------------------------- 1 | type my_ty = Cons of my_ty 2 | 3 | ;; 4 | 5 | function 6 | | Cons argmnt -> Cons argmnt 7 | -------------------------------------------------------------------------------- /tests/invalid/shadow_type.eff: -------------------------------------------------------------------------------- 1 | type cow = Horn of int 2 | type bull = Tail of string 3 | type cow = Hoof of bool 4 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/config.plain.ml: -------------------------------------------------------------------------------- 1 | let test_suite = Benchmark_config.default_test_suite 2 | -------------------------------------------------------------------------------- /src/05-backends/multicore-ocaml/multicoreOCaml.mli: -------------------------------------------------------------------------------- 1 | module Backend : Language.Backend.S 2 | 3 | val stdlib : string 4 | -------------------------------------------------------------------------------- /tests/codegen/test-handle_effect_skip.eff: -------------------------------------------------------------------------------- 1 | handle 2 | perform (Print "hello\n") 3 | with 4 | | (_ : unit) -> 42 5 | -------------------------------------------------------------------------------- /tests/invalid/invalid_match_type.eff: -------------------------------------------------------------------------------- 1 | type a = A 2 | type b = B 3 | ;; 4 | let a = [A] in 5 | match a with 6 | | B -> () -------------------------------------------------------------------------------- /tests/invalid/use_undefined_type.eff: -------------------------------------------------------------------------------- 1 | type foo = {a : bar; b : integer } 2 | 3 | type bar = integer -> integer 4 | 5 | -------------------------------------------------------------------------------- /src/00-utils/option.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Option 2 | 3 | let default_map default f = function None -> default | Some x -> f x 4 | -------------------------------------------------------------------------------- /tests/codegen/substitution.eff: -------------------------------------------------------------------------------- 1 | let decide_func bl = 2 | let x = 10 in 3 | let y = 20 in 4 | (if bl then x else y) 5 | -------------------------------------------------------------------------------- /tests/codegen/test6.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | handle 1 with 4 | | x -> x 5 | | effect (Op n) k -> 2 ;; 6 | -------------------------------------------------------------------------------- /tests/codegen/test14.eff: -------------------------------------------------------------------------------- 1 | type integer = int ;; 2 | 3 | effect Op : integer ;; 4 | 5 | let f y = let z = perform Op in z + y in f -------------------------------------------------------------------------------- /tests/codegen/test20.eff: -------------------------------------------------------------------------------- 1 | let rec even n = if n = 0 then true else odd (n - 1) 2 | and odd n = if n = 0 then false else even (n - 1) 3 | -------------------------------------------------------------------------------- /tests/codegen/test7.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | handle perform (Op 1) with 4 | | x -> x 5 | | effect (Op n) k -> 2 ;; 6 | -------------------------------------------------------------------------------- /tests/invalid/malformed_type_application.eff: -------------------------------------------------------------------------------- 1 | (* Malformed type application *) 2 | type 'a foo = 'a * 'a 3 | type bar = (int, int) foo 4 | -------------------------------------------------------------------------------- /tests/codegen/ifthenelse.eff: -------------------------------------------------------------------------------- 1 | let rec _loop n = 2 | if n = 0 then 3 | 0 4 | else 5 | _loop (n - 1) 6 | in () 7 | 8 | -------------------------------------------------------------------------------- /tests/codegen/test8.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | handle perform (Op 1) with 4 | | x -> x 5 | | effect (Op n) k -> k 2 ;; 6 | -------------------------------------------------------------------------------- /tests/codegen/test9.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | handle perform (Op 1) with 4 | | x -> x 5 | | effect (Op n) k -> k n ;; 6 | -------------------------------------------------------------------------------- /tests/invalid/duplicate_field_tydef_record.eff: -------------------------------------------------------------------------------- 1 | (* Duplicate fields are not allowed in a record type. *) 2 | type cow = {a : unit; a : int} 3 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/.ocamlformat-ignore: -------------------------------------------------------------------------------- 1 | # ocamlformat does not recognize multicore syntax 2 | * 3 | -------------------------------------------------------------------------------- /tests/codegen/original.eff: -------------------------------------------------------------------------------- 1 | 2 | 3 | let rec loop n = 4 | if n = 0 then 5 | 0 6 | else 7 | loop (n - 1) 8 | in loop 10 9 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_constraints.txt: -------------------------------------------------------------------------------- 1 | 29 2 | 59 3 | 89 4 | 119 5 | 149 6 | 179 7 | 209 8 | 239 9 | 269 10 | 299 11 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun_constraints.txt: -------------------------------------------------------------------------------- 1 | 18 2 | 38 3 | 58 4 | 78 5 | 98 6 | 118 7 | 138 8 | 158 9 | 178 10 | 198 11 | -------------------------------------------------------------------------------- /src/02-parser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parser) 3 | (libraries utils language)) 4 | 5 | (ocamllex lexer) 6 | 7 | (menhir 8 | (modules grammar)) 9 | -------------------------------------------------------------------------------- /tests/invalid/duplicate_variant_tydef_sum.eff: -------------------------------------------------------------------------------- 1 | (* Duplicate variants are not allowed in a sum type *) 2 | type cow = Horn of int | Horn of unit 3 | 4 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/.ocamlformat-ignore: -------------------------------------------------------------------------------- 1 | # Formatting generated code is time consuming 2 | capability_benchmarks_cps_paper.ml 3 | -------------------------------------------------------------------------------- /misc/dune: -------------------------------------------------------------------------------- 1 | (data_only_dirs 2 | exeff-skeleff-multicore 3 | noeff-alternative 4 | old-benchmarks-for-other-systems 5 | type-inference-time-complexity) 6 | -------------------------------------------------------------------------------- /tests/codegen/not-found.eff: -------------------------------------------------------------------------------- 1 | 2 | effect Op1 : int -> int ;; 3 | 4 | handle 5 | perform (Op1 5) 6 | with 7 | | effect (Op1 x) k -> k 11 8 | | x -> x 9 | -------------------------------------------------------------------------------- /tests/codegen/test10.eff: -------------------------------------------------------------------------------- 1 | effect Op : int -> int ;; 2 | 3 | #type match perform (Op 1) with 4 | | x -> x 5 | | effect (Op n) k -> perform (Op 2) ;; 6 | -------------------------------------------------------------------------------- /tests/invalid/less_than_complex.eff: -------------------------------------------------------------------------------- 1 | let h = (handler x -> x) ;; 2 | let g = (handler x -> x) ;; 3 | 4 | (1, 2, [h]) < (1, 2, [g]) ;; (* This breaks *) 5 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_fun_type.txt: -------------------------------------------------------------------------------- 1 | 951 2 | 2239 3 | 3659 4 | 5002 5 | 6312 6 | 7622 7 | 8932 8 | 10242 9 | 11552 10 | 12862 11 | -------------------------------------------------------------------------------- /tests/invalid/non_linear_record.eff: -------------------------------------------------------------------------------- 1 | (* A record must be linear *) 2 | type cow = {left : int; right : int} 3 | let c = {left=42; left=23; right=42} 4 | 5 | 6 | -------------------------------------------------------------------------------- /tests/valid/semisemi.eff: -------------------------------------------------------------------------------- 1 | (* Testing whether;; works *) 2 | 3 | let a = 5 4 | 5 | let b = 6;; 6 | 7 | let c = 7;; 8 | 9 | 2 + 2;; 10 | 11 | 3 + 8 12 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_type.txt: -------------------------------------------------------------------------------- 1 | 7602 2 | 16388 3 | 25930 4 | 35760 5 | 45590 6 | 55456 7 | 66306 8 | 77168 9 | 88006 10 | 98304 11 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/eff.sublime-build: -------------------------------------------------------------------------------- 1 | { 2 | "cmd": ["eff", "$file"], 3 | "file_regex": "^[ ]*File \"(...*?)\", line ([0-9]*), char ([0-9]*).*", 4 | "selector": "source.eff" 5 | } 6 | -------------------------------------------------------------------------------- /tests/codegen/test12.eff: -------------------------------------------------------------------------------- 1 | effect Op1 : int -> int ;; 2 | effect Op2 : int -> int ;; 3 | 4 | handler 5 | | x -> x 6 | | effect (Op1 n) k -> 1 7 | | effect (Op2 n) k -> 2 ;; 8 | -------------------------------------------------------------------------------- /tests/codegen/test18.eff: -------------------------------------------------------------------------------- 1 | type nat = Zero | Succ of nat 2 | 3 | ;; 4 | 5 | let rec add m = function 6 | | Zero -> m 7 | | Succ n -> Succ (add m n) 8 | 9 | in 10 | 11 | add 12 | -------------------------------------------------------------------------------- /tests/codegen/test11.eff: -------------------------------------------------------------------------------- 1 | effect Op1 : int -> int ;; 2 | effect Op2 : int -> int ;; 3 | 4 | #type match perform (Op1 1) with 5 | | x -> x 6 | | effect (Op1 n) k -> perform (Op2 2) ;; 7 | -------------------------------------------------------------------------------- /src/eff/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name eff) 3 | (public_name eff) 4 | (libraries utils language runtime multicoreOCaml plainOCaml loader unix) 5 | (promote 6 | (until-clean) 7 | (into ../../))) 8 | -------------------------------------------------------------------------------- /tests/codegen/handler_beta_reduction.eff: -------------------------------------------------------------------------------- 1 | effect Eff : int -> int 2 | 3 | ;; 4 | 5 | 6 | handle 7 | perform (Eff (1 + 3)) 8 | with 9 | | effect (Eff x) k -> k (x + 2) 10 | | y -> y + 4 11 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/links/compiling-links-effect-to-ocaml.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matijapretnar/eff/HEAD/misc/old-benchmarks-for-other-systems/links/compiling-links-effect-to-ocaml.pdf -------------------------------------------------------------------------------- /src/01-language/tyScheme.ml: -------------------------------------------------------------------------------- 1 | type t = { params : Type.Params.t; constraints : Constraints.t; ty : Type.ty } 2 | 3 | let monotype ty = 4 | { params = Type.Params.empty; constraints = Constraints.empty; ty } 5 | -------------------------------------------------------------------------------- /tests/codegen/reuse_toplevel_handler.eff: -------------------------------------------------------------------------------- 1 | let h = handler 2 | | x -> x 3 | ;; 4 | (* If the value restriction kicks in, handler types won't match) *) 5 | with h handle 1 6 | ;; 7 | 8 | with h handle (1,2) 9 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/generate-graphs/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names graphs) 3 | (modes native) 4 | (ocamlopt_flags 5 | (:standard -O3)) 6 | (libraries benchmark_suite) 7 | (promote (until-clean))) 8 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy.eff: -------------------------------------------------------------------------------- 1 | effect Dummy : unit -> int;; 2 | 3 | let h1 = handler 4 | | effect (Dummy _) k -> 3 5 | | x -> 0 6 | 7 | in (with h1 handle (perform (Dummy ()))) 8 | -------------------------------------------------------------------------------- /tests/codegen/test13.eff: -------------------------------------------------------------------------------- 1 | effect Op1 : int -> int ;; 2 | effect Op2 : int -> int ;; 3 | 4 | handle perform (Op1 1); perform (Op2 2) with 5 | | x -> x 6 | | effect (Op1 n) k -> 1 7 | | effect (Op2 n) k -> 2 ;; 8 | -------------------------------------------------------------------------------- /tests/valid/higher_order_op.eff: -------------------------------------------------------------------------------- 1 | type 'a wrapped = 2 | | Wrapper of 'a 3 | 4 | effect Op : (unit -> unit) wrapped 5 | 6 | ;; 7 | 8 | let wrapped_t = perform Op in 9 | match wrapped_t with 10 | | Wrapper t -> t () 11 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/links/liberating-effects-with-rows-and-handlers.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matijapretnar/eff/HEAD/misc/old-benchmarks-for-other-systems/links/liberating-effects-with-rows-and-handlers.pdf -------------------------------------------------------------------------------- /tests/codegen/is_relatively_pure.eff: -------------------------------------------------------------------------------- 1 | 2 | 3 | effect Op1 : int -> unit;; 4 | effect Op2 : int -> unit;; 5 | 6 | handle 7 | perform (Op1 1) 8 | with 9 | | effect (Op2 n) k -> 10 | k () 11 | | x -> x 12 | -------------------------------------------------------------------------------- /tests/invalid/duplicate_operation_tydef_effect.eff: -------------------------------------------------------------------------------- 1 | (* Duplicate operations are not allowed in an effect type *) 2 | type cow = 3 | effect 4 | operation chew : unit -> integer 5 | operation chew : unit -> integer 6 | end 7 | 8 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Document.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 3 | doc 4 | source.eff 5 | Document 6 | 7 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/begin.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 5 | begin 6 | source.eff 7 | begin 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/let.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 3 | let 4 | source.eff 5 | let 6 | 7 | -------------------------------------------------------------------------------- /examples/README.txt: -------------------------------------------------------------------------------- 1 | Many of the examples in this directory are taken from the paper 2 | "Programming with Algebraic Effects and Handlers" by Andrej Bauer and 3 | Matija Pretnar. The paper is available at http://arxiv.org/abs/1203.1539. 4 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name nativeMulticore) 3 | (enabled_if 4 | (or 5 | (= %{ocaml_version} "4.10.0+multicore") 6 | (= %{ocaml_version} "4.12.0+domains+effects")))) 7 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/links/compile.sh: -------------------------------------------------------------------------------- 1 | ./links-effects/links -c queens_all.links -o queens_all 2 | ./links-effects/links -c queens_cps.links -o queens_cps 3 | ./links-effects/links -c queens_option.links -o queens_option 4 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy20_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 22.663; 59 2 | 19.456; 59 3 | 20.044; 59 4 | 19.164; 59 5 | 19.442999999999998; 59 6 | 18.535; 59 7 | 19.656; 59 8 | 18.256; 59 9 | 19.399; 59 10 | 18.568; 59 11 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/effect.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 5 | effect 6 | source.eff 7 | effect 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/fun.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | ${2:body})]]> 3 | fun 4 | source.eff 5 | function 6 | 7 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/type-(type).sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 3 | type 4 | source.eff 5 | type 6 | 7 | -------------------------------------------------------------------------------- /tests/codegen/test21.eff: -------------------------------------------------------------------------------- 1 | let z = 2 | match [1] with 3 | | ([] : int list) -> 2 4 | | x :: _ -> x 5 | in 6 | let w = 7 | match [true] with 8 | | ([] : bool list) -> true 9 | | x :: _ -> x 10 | in 11 | (z, w) 12 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/match-pattern.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | $0]]> 3 | | 4 | source.eff 5 | match pattern 6 | 7 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy30_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 53.726000000000006; 89 2 | 55.446000000000005; 89 3 | 54.266; 89 4 | 53.585; 89 5 | 53.875; 89 6 | 54.037; 89 7 | 57.145; 89 8 | 53.867; 89 9 | 55.942; 89 10 | 55.885; 89 11 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/method-(method).sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 3 | method 4 | source.eff 5 | method 6 | 7 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/let-in.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 3 | lin 4 | source.eff 5 | let in 6 | 7 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy50_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 233.789; 149 2 | 225.08100000000002; 149 3 | 226.766; 149 4 | 225.129; 149 5 | 225.123; 149 6 | 224.469; 149 7 | 226.745; 149 8 | 223.917; 149 9 | 225.795; 149 10 | 220.434; 149 11 | -------------------------------------------------------------------------------- /src/jseff/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name jseff) 3 | (libraries runtime js_of_ocaml utils loader) 4 | (preprocess 5 | (pps js_of_ocaml-ppx)) 6 | (modes js) 7 | (promote 8 | (until-clean) 9 | (into ../../docs/try) 10 | (only jseff.bc.js))) 11 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/function-label.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | ${2:body})]]> 3 | ~f 4 | source.eff 5 | function label 6 | 7 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/module.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 5 | module 6 | source.eff 7 | module 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/with-handle.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 4 | with 5 | source.eff 6 | with handle 7 | 8 | -------------------------------------------------------------------------------- /src/06-loader/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name loader) 3 | (libraries language typechecker optimizer parser)) 4 | 5 | (rule 6 | (with-stdout-to 7 | stdlib_eff.ml 8 | (progn 9 | (echo "let source = {|") 10 | (cat stdlib.eff) 11 | (echo "|}")))) 12 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/While-Loop.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 5 | while 6 | source.eff 7 | while loop 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/module-type.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 5 | mtype 6 | source.eff 7 | module type 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/try.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | failwith "Unknown"]]> 6 | try 7 | source.eff 8 | try 9 | 10 | -------------------------------------------------------------------------------- /src/05-backends/multicore-ocaml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name multicoreOCaml) 3 | (libraries language typechecker)) 4 | 5 | (rule 6 | (with-stdout-to 7 | stdlib_eff.ml 8 | (progn 9 | (echo "let source = {|") 10 | (cat stdlib.eff) 11 | (echo "|}")))) 12 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/module-signature.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 5 | sig 6 | source.eff 7 | module signature 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/untitled.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 3 | $0 4 | ) ())]]> 5 | thread 6 | source.eff 7 | untitled 8 | 9 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy40_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 124.391; 119 2 | 123.116; 119 3 | 116.255; 119 4 | 121.23299999999999; 119 5 | 121.09599999999999; 119 6 | 117.847; 119 7 | 122.271; 119 8 | 117.195; 119 9 | 118.685; 119 10 | 119.06700000000001; 119 11 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/func.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | ${2:expr1} 4 | | ${3:patt2} -> ${4:expr2})]]> 5 | func 6 | source.eff 7 | function alt 8 | 9 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/handle-with.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | failwith "Unknown"]]> 6 | handle 7 | source.eff 8 | handle with 9 | 10 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/match.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | ${3:expr} 4 | | ${4:_} -> ${5:expr2}]]> 5 | match 6 | source.eff 7 | match 8 | 9 | -------------------------------------------------------------------------------- /tests/valid/orelse_andalso.eff: -------------------------------------------------------------------------------- 1 | (false && (1 / 0 = 5));; 2 | 3 | (true || (1 / 0 = 5));; 4 | 5 | (false && false);; 6 | (false && true);; 7 | (true && false);; 8 | (true && true);; 9 | 10 | (false || false);; 11 | (false || true);; 12 | (true || false);; 13 | (true || true);; 14 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/For-Loop.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 6 | for 7 | source.eff 8 | for loop 9 | 10 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/class.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | 6 | class 7 | source.eff 8 | class 9 | 10 | -------------------------------------------------------------------------------- /tests/codegen/one_input.eff: -------------------------------------------------------------------------------- 1 | effect Decide : unit -> bool 2 | ;; 3 | 4 | let choose_sum = handler 5 | | effect (Decide ()) k -> k true + k false 6 | | x -> x 7 | in 8 | let decide_func1 x = 9 | (if perform (Decide ()) then x else 20) in 10 | with choose_sum handle (decide_func1 10 ) 11 | -------------------------------------------------------------------------------- /tests/codegen/test19.eff: -------------------------------------------------------------------------------- 1 | type nat = Zero | Succ of nat 2 | 3 | ;; 4 | 5 | let swap (w, k, num) = function 6 | | (Zero, Zero, 0) -> (w, k, Zero, 0, 0) 7 | | (Zero, z, n) -> (Zero, z, Zero, num, n) 8 | | (x, Zero, n) -> (Zero, w, x, 1, n) 9 | | (_, _, _) -> (Zero, Zero, Zero, 0, 0) 10 | 11 | in 12 | 13 | swap 14 | -------------------------------------------------------------------------------- /tests/valid/polymorphism.eff: -------------------------------------------------------------------------------- 1 | let g x y = (fun x y -> x) x y;; 2 | 3 | (g 4 "foo", g "foo" 4);; 4 | 5 | let u = [];; 6 | 7 | (1 :: u, "foo" :: u);; 8 | 9 | let v = [[]];; 10 | 11 | ([] :: v, [2] :: v);; 12 | 13 | (fun x -> let h t u = u in h x x);; 14 | 15 | (fun x -> let h t u = t in h x x);; 16 | 17 | let rec u x = u x;; 18 | u;; -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | # Executable 3 | eff.exe 4 | docs/try/jseff.bc.js 5 | 6 | # Backup files 7 | *~ 8 | 9 | # Silly Mac OS X files 10 | .DS_Store 11 | 12 | # VSCode 13 | .vscode 14 | .devcontainer 15 | 16 | # Dune takes care of merlin 17 | .merlin 18 | 19 | misc/code-generation-benchmarks/generate-graphs/tables/*.table 20 | graphs.exe -------------------------------------------------------------------------------- /tests/codegen/test15.eff: -------------------------------------------------------------------------------- 1 | type foo = A | B of bar 2 | and bar = { 3 | x : foo 4 | } ;; 5 | 6 | effect Op1 : int -> bar ;; 7 | effect Op2 : bar -> foo ;; 8 | effect Op3 : foo -> int ;; 9 | 10 | let f a = 11 | let x = perform (Op1 10) in 12 | let y = perform (Op2 x) in 13 | let z = perform (Op3 y) in 14 | a + z 15 | in 16 | f -------------------------------------------------------------------------------- /tests/codegen/test16.eff: -------------------------------------------------------------------------------- 1 | effect Get : unit -> int ;; 2 | effect Put : int -> unit ;; 3 | 4 | (let rec loop n = 5 | if 0 < n then perform (Put ((perform Get) + 1)); loop (n - 1) else () 6 | in match (loop 10) with 7 | | x -> (fun _ -> x) 8 | | effect (Get _) k -> (fun s -> k s s) 9 | | effect (Put s) k -> (fun _ -> k () s) 10 | ) 0 11 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/rangeMulticore.ml: -------------------------------------------------------------------------------- 1 | effect Fetch : unit -> int 2 | 3 | 4 | let test n = 5 | let rec range n = 6 | match n with 7 | | 0 -> [] 8 | | _ -> 9 | (perform (Fetch ()):: (range (n - 1))) 10 | in 11 | try 12 | range n 13 | with 14 | | effect (Fetch _) k -> (continue k 42) 15 | -------------------------------------------------------------------------------- /tests/valid/test1.eff: -------------------------------------------------------------------------------- 1 | (* https://github.com/matijapretnar/eff/issues/89 *) 2 | 3 | effect A : unit 4 | effect B : unit 5 | 6 | type 'a testtype = T of (('a testtype -> 'a) list) 7 | 8 | let testbug = handler 9 | | effect A k -> fun (T ks) -> continue k () (T ((k ()) :: ks)) 10 | | effect B k -> fun (T l) -> perform (Print "hello") ; continue k () (T l) -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/rangeNative.ml: -------------------------------------------------------------------------------- 1 | type int_list = Nil | Cons of int * int_list 2 | 3 | let test n = 4 | let rec range n = match n with 0 -> Nil | _ -> Cons (42, range (n - 1)) in 5 | range n 6 | 7 | let testGenerator m = 8 | let n = 42 in 9 | let rec su i acc = if i = 0 then acc else su (i - 1) (acc + (i mod n)) in 10 | su m 0 11 | -------------------------------------------------------------------------------- /src/05-backends/multicore-ocaml/translate.mli: -------------------------------------------------------------------------------- 1 | open Language 2 | 3 | val of_expression : Term.expression -> Syntax.term 4 | val of_computation : Term.computation -> Syntax.term 5 | val of_abstraction : Term.abstraction -> Syntax.abstraction 6 | val of_pattern : Term.pattern -> Syntax.pattern 7 | val of_type : Type.ty -> Syntax.ty 8 | val of_tydef : Type.tydef -> Syntax.tydef 9 | -------------------------------------------------------------------------------- /tests/codegen/handle_rec.eff: -------------------------------------------------------------------------------- 1 | effect Eff : unit -> unit 2 | ;; 3 | 4 | let rec f x = if x = 0 then 1 else (perform (Eff ()); f (x - 1)) 5 | in 6 | handle 7 | f 5 8 | with 9 | effect (Eff ()) k -> k () * 2 10 | ;; 11 | 12 | let rec g x = if x = 0 then 1 else g (x - 1) 13 | in 14 | handle 15 | g 5 16 | with 17 | effect (Eff ()) k -> k () * 2 18 | ;; 19 | -------------------------------------------------------------------------------- /tests/codegen/redefine_local.eff: -------------------------------------------------------------------------------- 1 | effect Ping: unit -> unit 2 | 3 | let test_simple x = 4 | let h1 = handler 5 | | effect (Ping ()) k -> k () 6 | in 7 | with h1 handle ( 8 | (perform (Ping ()), 1) 9 | ) 10 | 11 | let test_simple2 () = 12 | let h3 = handler 13 | | effect (Ping ()) k -> k () 14 | in 15 | with h3 handle ( 16 | perform (Ping ()) 17 | ) -------------------------------------------------------------------------------- /etc/eff.tmbundle/handler.sublime-snippet: -------------------------------------------------------------------------------- 1 | 2 | ${2:comp1} 4 | | ${3:inst2#op2 x k} -> ${4:comp2}${5: 5 | | ${6:val x} -> ${7:comp_val}}${8: 6 | | ${9:finally x} -> ${10:comp_fin}})]]> 7 | hand 8 | source.eff 9 | handler 10 | 11 | -------------------------------------------------------------------------------- /tests/valid/lexer.eff: -------------------------------------------------------------------------------- 1 | (* Tests for lexer. *) 2 | 3 | let _a = 10 in _a;; 4 | let a' = 20 in a';; 5 | let a'b' = 30 in a'b';; 6 | let a''' = 40 in a''';; 7 | 8 | -1_000_000_000;; 9 | 42;; 10 | (-0b101010);; 11 | 0b101010;; 12 | 0B101010;; 13 | 0xabcdef;; 14 | 0XAbCdEf;; 15 | 0o76510;; 16 | 0O76510;; 17 | 18 | 3.141592;; 19 | 4.141_592;; 20 | -51592e-4;; 21 | 61592E-4;; 22 | -0.00314e+3___;; 23 | -------------------------------------------------------------------------------- /tests/valid/test_equality.eff: -------------------------------------------------------------------------------- 1 | 1 = 1 ;; 2 | 1 = 2 ;; 3 | (1,2) = (1,2) ;; 4 | (2,1) = (1,2) ;; 5 | [1;2;3] = [] ;; 6 | [1;2;3] = [1;2;3] ;; 7 | 8 | (* Nested structures *) 9 | type ('a,'b) rabbit = { eye : 'a; tail : 'b list } ;; 10 | 11 | let x = ([1,2], {eye = 7; tail = []}) in 12 | let y = ([1,3], {eye = 7; tail = []}) in 13 | ("nested", x = x, x = y, y = y) ;; 14 | 15 | let f x y = x = y ;; -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy_fun10.eff: -------------------------------------------------------------------------------- 1 | let f9 = fun x -> x in 2 | 3 | let f8 = fun x -> (f9 x) in 4 | 5 | let f7 = fun x -> (f8 x) in 6 | 7 | let f6 = fun x -> (f7 x) in 8 | 9 | let f5 = fun x -> (f6 x) in 10 | 11 | let f4 = fun x -> (f5 x) in 12 | 13 | let f3 = fun x -> (f4 x) in 14 | 15 | let f2 = fun x -> (f3 x) in 16 | 17 | let f1 = fun x -> (f2 x) in 18 | 19 | (f1 3) 20 | -------------------------------------------------------------------------------- /src/06-loader/shell.mli: -------------------------------------------------------------------------------- 1 | module type Shell = sig 2 | type state 3 | 4 | val initialize : unit -> state 5 | val execute_file : string -> state -> state 6 | val load_file : string -> state -> state 7 | val execute_source : string -> state -> state 8 | val load_source : string -> state -> state 9 | val finalize : state -> unit 10 | end 11 | 12 | module Make (Backend : Language.Backend.S) : Shell 13 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/rangeMulticoreCustomList.ml: -------------------------------------------------------------------------------- 1 | effect Fetch : unit -> int 2 | 3 | type int_list = Nil | Cons of int * int_list 4 | 5 | let test n = 6 | let rec range n = 7 | match n with 8 | | 0 -> Nil 9 | | _ -> 10 | Cons((perform (Fetch ()), (range (n - 1)))) 11 | in 12 | match 13 | range n 14 | with 15 | | effect (Fetch _) k -> (continue k 42) 16 | | x -> x 17 | -------------------------------------------------------------------------------- /tests/valid/patterns.eff: -------------------------------------------------------------------------------- 1 | let a = 5 in a;; 2 | let (a,b) = (1,2) in (a,b);; 3 | let x :: y = [1;2;3;4] in (x,y);; 4 | let _ :: y = [1;2;3;4] in y;; 5 | 6 | type 'a cow = Moo of 'a;; 7 | let Moo x = Moo 10 in x;; 8 | 9 | let Moo x as y = Moo 10 in (x,y);; 10 | let x as y as z = 42 in (x,y,z);; 11 | let x,y,z as a = (1,2,3) in (x,y,z,a);; 12 | 13 | (* This one should work also, but currently it does not: 14 | let x as y, z = ("foo", "bar") in (x,y,z);; *) 15 | -------------------------------------------------------------------------------- /tests/codegen/two_inputs.eff: -------------------------------------------------------------------------------- 1 | effect Decide : unit -> bool 2 | 3 | type int_list = Nil | Cons of int * int_list 4 | 5 | 6 | ;; 7 | 8 | let rec (@) xs ys = 9 | match xs with 10 | | Nil -> ys 11 | | Cons (x, xs) -> Cons (x, (xs @ ys)) 12 | in 13 | 14 | let choose_all = handler 15 | | effect (Decide ()) k -> k true @ k false 16 | | x -> Cons (x, Nil) 17 | in 18 | 19 | let decide_func1 x y = 20 | (if perform (Decide ()) then x else y) in 21 | with choose_all handle (decide_func1 10 20 ) 22 | -------------------------------------------------------------------------------- /tests/codegen/handle_match.eff: -------------------------------------------------------------------------------- 1 | type int_list = Nil | Cons of int * int_list 2 | 3 | ;; 4 | let f y = 5 | handle 6 | match y with 7 | | Nil -> 1 8 | | Cons (x, Nil) -> x 9 | | Cons (_, Cons (y, Nil)) -> y 10 | | Cons (x, _) -> x 11 | with 12 | | x -> x + 10 13 | ;; 14 | 15 | 16 | handle 17 | match Cons (4, Cons (5, Cons (6, Nil))) with 18 | | Nil -> 1 19 | | Cons (x, Nil) -> x 20 | | Cons (_, Cons (y, Nil)) -> y 21 | | Cons (x, _) -> x 22 | with 23 | | x -> x + 10 24 | ;; 25 | -------------------------------------------------------------------------------- /src/01-language/tyParam.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | module TyParam = struct 4 | include Symbol.Make (Symbol.Parameter (struct 5 | let ascii_symbol = "ty" 6 | let utf8_symbol = "\207\132" 7 | end)) 8 | 9 | let print_old ?(poly = []) k ppf = 10 | let c = if List.mem k poly then "'" else "'_" in 11 | fold 12 | (fun _ k -> 13 | if 0 <= k && k <= 25 then 14 | Format.fprintf ppf "%s%c" c (char_of_int (k + int_of_char 'a')) 15 | else Format.fprintf ppf "%sty%i" c (k - 25)) 16 | k 17 | end 18 | -------------------------------------------------------------------------------- /tests/codegen/top-letrec_fails.eff: -------------------------------------------------------------------------------- 1 | effect Decide : bool;; 2 | 3 | type intlist = 4 | | IntNil 5 | | IntCons of int * intlist;; 6 | 7 | (* Top-level let-rec *) 8 | let rec concat xs = ( 9 | match xs with 10 | | IntNil -> fun ys -> ys 11 | | IntCons (z,zs) -> fun ys -> IntCons (z, concat zs ys) 12 | ) ;; 13 | 14 | (* This returns a list of four possibilities [10; 5; 20; 15] *) 15 | with 16 | (* This handler collects all results that we can get by making different choices. *) 17 | (handler 18 | | x -> IntNil 19 | ) 20 | handle ( 21 | 1 22 | ) 23 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (using menhir 2.1) 3 | (generate_opam_files true) 4 | (cram enable) 5 | 6 | (name eff) 7 | (version dev) 8 | (source (github matijapretnar/eff)) 9 | (homepage "http://www.eff-lang.org/") 10 | (authors "Andrej Bauer" "Matija Pretnar") 11 | (license BSD2) 12 | (maintainers "matija@pretnar.info") 13 | 14 | (package 15 | (name eff) 16 | (synopsis "A functional programming language based on algebraic effect handlers") 17 | (depends 18 | js_of_ocaml 19 | js_of_ocaml-ppx 20 | menhir 21 | (ocaml (>= 4.14.1)) 22 | (ocamlformat (= 0.25.1)))) 23 | -------------------------------------------------------------------------------- /tests/valid/tydef.eff: -------------------------------------------------------------------------------- 1 | type baire = int -> int 2 | 3 | type 'a tree = Empty | Node of 'a * 'a tree * 'a tree 4 | 5 | type complex = {re : float; im : float} 6 | 7 | type ('k,'v) assoc = ('k * 'v) list 8 | 9 | 10 | (* Mutually recursive types. *) 11 | type cow = bull -> int 12 | 13 | and bull = 14 | | Tail 15 | | Legs of bull list 16 | | Horns of cow 17 | 18 | (* Handler type. *) 19 | type 'a collector = 'a => 'a list;; 20 | 21 | Tail;; 22 | 23 | {re = 1.2; im = 2.4};; 24 | 25 | (Node (10, Empty, Node (20, Empty, Empty)));; 26 | 27 | (Horns (fun _ -> 10)) 28 | 29 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | workflow_dispatch: 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v2 12 | 13 | - name: Setup OCaml 14 | uses: ocaml/setup-ocaml@v3 15 | with: 16 | ocaml-compiler: 4.14.x 17 | 18 | - name: Install Opam packages 19 | run: opam pin add -n .; opam install eff --deps-only 20 | 21 | - name: Format 22 | run: opam exec -- make format 23 | 24 | - name: Test 25 | run: opam exec -- make test -------------------------------------------------------------------------------- /src/05-backends/runtime/eval.mli: -------------------------------------------------------------------------------- 1 | open Utils 2 | open Language 3 | 4 | type state 5 | 6 | val initial_state : state 7 | val extend : Term.pattern -> Value.value -> state -> state 8 | val extend_let_rec : state -> (Term.variable, Term.abstraction) Assoc.t -> state 9 | val eval_expression : state -> Term.expression -> Value.value 10 | val run : state -> Term.computation -> Value.value 11 | val update : Language.Term.Variable.t -> Value.value -> state -> state 12 | val lookup : Term.variable -> state -> Value.value option 13 | val add_runner : Term.effect -> (Value.value -> Value.value) -> state -> state 14 | -------------------------------------------------------------------------------- /src/01-language/const.mli: -------------------------------------------------------------------------------- 1 | type t = private 2 | | Integer of int 3 | | String of string 4 | | Boolean of bool 5 | | Float of float 6 | 7 | type ty = IntegerTy | StringTy | BooleanTy | FloatTy 8 | type comparison = Less | Equal | Greater | Invalid 9 | 10 | val of_integer : int -> t 11 | val of_string : string -> t 12 | val of_boolean : bool -> t 13 | val of_float : float -> t 14 | val of_true : t 15 | val of_false : t 16 | val print : t -> Format.formatter -> unit 17 | val print_ty : ty -> Format.formatter -> unit 18 | val infer_ty : t -> ty 19 | val compare : t -> t -> comparison 20 | val equal : t -> t -> bool 21 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Symbol List_ Variants.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Symbol List: Variants 7 | scope 8 | entity.name.type.variant.eff | entity.name.type.variant.polymorphic.eff 9 | settings 10 | 11 | showInSymbolList 12 | 0 13 | 14 | uuid 15 | A40FC961-E731-454E-AEB3-0B7307EF17E0 16 | 17 | 18 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Symbol List_ Classes.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Symbol List: Classes 7 | scope 8 | entity.name.type.class.eff 9 | settings 10 | 11 | showInSymbolList 12 | 1 13 | symbolTransformation 14 | s/^/class: / 15 | 16 | uuid 17 | 72C6F9CD-7D1F-4956-8451-22F35339ABAB 18 | 19 | 20 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Symbol List_ Types.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Symbol List: Types 7 | scope 8 | storage.type.user-defined.eff 9 | settings 10 | 11 | showInSymbolList 12 | 1 13 | symbolTransformation 14 | s/^/type: / 15 | 16 | uuid 17 | 3605208D-9963-4F10-A4BC-C0EF15B84BCF 18 | 19 | 20 | -------------------------------------------------------------------------------- /tests/codegen/break-split.eff: -------------------------------------------------------------------------------- 1 | effect Decide : bool;; 2 | 3 | 4 | (* handle (let rec f x = if perform (Decide ()) then 0 else f (x - 1) in f 0) with | effect Decide k -> k true;; *) 5 | 6 | let two = 2;; 7 | let three = 3;; 8 | 9 | 10 | (* This handler collects all results that we can get by making different choices. *) 11 | 12 | 13 | (* This returns a list of four possibilities [10; 5; 20; 15] *) 14 | 15 | with 16 | (handler 17 | | effect Decide k -> k true + k false 18 | | x -> x 19 | ) 20 | handle 21 | let rec f x = if perform (Decide ()) then 2 else 3 in f () 22 | (* let rec f x = if perform (Decide ()) then two else three in f () *) 23 | 24 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Symbol List_ Exceptions.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Symbol List: Exceptions 7 | scope 8 | entity.name.type.exception.eff 9 | settings 10 | 11 | showInSymbolList 12 | 1 13 | symbolTransformation 14 | s/^/exception: / 15 | 16 | uuid 17 | 5852E31D-A343-4FD5-953A-76996068C515 18 | 19 | 20 | -------------------------------------------------------------------------------- /tests/codegen/other-effect.eff: -------------------------------------------------------------------------------- 1 | effect WriteInt : int -> unit;; 2 | 3 | (* THIS ONE TERMINATES JUST FINE: *) 4 | 5 | with 6 | (handler 7 | | effect (WriteInt n) k -> n + k () 8 | | y -> 0 9 | ) 10 | handle 11 | let rec f x = perform (WriteInt x) 12 | ; if x = 0 13 | then () 14 | else f (x - 1) 15 | in f 10 16 | 17 | (* THIS VERSION DOES NOT TERMINATE AND IT MAKES NO SENSE 18 | with 19 | (handler 20 | | effect (WriteInt n) k -> n + k () 21 | | y -> 0 22 | ) 23 | handle 24 | let rec f x = if x = 0 25 | then () 26 | else perform (WriteInt x); f (x - 1) 27 | in f 0 28 | *) 29 | 30 | -------------------------------------------------------------------------------- /tests/codegen/nested_handlers.eff: -------------------------------------------------------------------------------- 1 | effect Get: unit -> int 2 | effect Fail: unit -> unit 3 | effect Decide: unit -> bool 4 | 5 | let test_nested m = 6 | let rec simple () = 7 | perform (Get ()) 8 | in 9 | let h = handler 10 | | x -> x 11 | in 12 | let d = handler 13 | | effect (Get ()) k -> k m 14 | in 15 | ((with d handle ((with h handle simple ())))) 16 | 17 | let test_nested m = 18 | let rec go n = 19 | if n = 0 then (perform (Fail ())) 20 | else (if (perform (Decide ())) then go (n-1) else go (n-2)) 21 | in 22 | handle (go m) with 23 | | effect (Decide ()) k -> ( 24 | handle k true with 25 | | effect (Fail ()) _k -> k false 26 | ) -------------------------------------------------------------------------------- /tests/codegen/pm-3_passes.eff: -------------------------------------------------------------------------------- 1 | 2 | effect Decide : bool;; 3 | 4 | type intlist = 5 | | IntNil 6 | | IntCons of int * intlist;; 7 | 8 | (* This returns a list of four possibilities [10; 5; 20; 15] *) 9 | let rec concat xs = ( 10 | match xs with 11 | | IntNil -> fun ys -> ys 12 | | IntCons (z,zs) -> fun ys -> IntCons (z, concat zs ys) 13 | ) in 14 | with 15 | (* This handler collects all results that we can get by making different choices. *) 16 | (handler 17 | | effect Decide k -> concat (k true) (k false) 18 | | x -> IntCons (x,IntNil) 19 | ) 20 | handle ( 21 | let x = (if perform Decide then 10 else 20) in 22 | let y = (if perform Decide then 0 else 5) in 23 | x - y 24 | ) 25 | -------------------------------------------------------------------------------- /src/03-typechecker/typeDefinitionContext.mli: -------------------------------------------------------------------------------- 1 | open Utils 2 | open Language 3 | 4 | type state = (TyName.t, Type.type_data) Assoc.t 5 | 6 | val initial_state : state 7 | val extend_type_definitions : Type.type_data Type.Field.Map.t -> state -> state 8 | val infer_variant : Type.Label.t -> state -> Type.ty option * Type.ty 9 | 10 | val infer_field : 11 | Type.Label.t -> state -> Type.ty * (TyName.t * Type.ty Type.Field.Map.t) 12 | 13 | val find_field : 14 | Type.Field.t -> 15 | state -> 16 | (TyName.t * Type.tydef_params * Type.ty Type.Field.Map.t) option 17 | 18 | val find_variant : 19 | Type.Label.t -> 20 | state -> 21 | (TyName.t 22 | * Type.tydef_params 23 | * Type.ty option Type.Field.Map.t 24 | * Type.ty option) 25 | option 26 | -------------------------------------------------------------------------------- /src/03-typechecker/exhaust.mli: -------------------------------------------------------------------------------- 1 | (** Pattern matching exhaustiveness checking as described by Maranget [1]. These 2 | functions assume that patterns are type correct, so they should be run only 3 | after types are inferred. 4 | 5 | [1] http://pauillac.inria.fr/~maranget/papers/warn/index.html 6 | *) 7 | 8 | val is_irrefutable : 9 | TypeDefinitionContext.state -> Language.UntypedSyntax.pattern -> unit 10 | (** Check that a pattern is irrefutable. *) 11 | 12 | val check_computation : 13 | TypeDefinitionContext.state -> Language.UntypedSyntax.computation -> unit 14 | 15 | val check_expression : 16 | TypeDefinitionContext.state -> Language.UntypedSyntax.expression -> unit 17 | (** Check for refutable patterns in let statements and non-exhaustive match statements. *) 18 | -------------------------------------------------------------------------------- /src/00-utils/location.mli: -------------------------------------------------------------------------------- 1 | (** Source code locations 2 | 3 | To show the user what piece of code is causing errors, we tag each construct 4 | with a corresponding location in the source. This consists of the name of 5 | the file and starting and ending position in the file (i.e. line and column 6 | number). *) 7 | 8 | type t 9 | (** Type of locations. *) 10 | 11 | val print : t -> Format.formatter -> unit 12 | (** Print a location. *) 13 | 14 | val make : Lexing.position -> Lexing.position -> t 15 | (** Make a location from two lexing positions. *) 16 | 17 | val union : t -> t -> t 18 | (** Computes the smallest location containing the two given locations. *) 19 | 20 | val of_lexeme : Lexing.lexbuf -> t 21 | (** Get the location of the current lexeme in a lexing buffer. *) 22 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy_fun20.eff: -------------------------------------------------------------------------------- 1 | let f19 = fun x -> x in 2 | 3 | let f18 = fun x -> (f19 x) in 4 | 5 | let f17 = fun x -> (f18 x) in 6 | 7 | let f16 = fun x -> (f17 x) in 8 | 9 | let f15 = fun x -> (f16 x) in 10 | 11 | let f14 = fun x -> (f15 x) in 12 | 13 | let f13 = fun x -> (f14 x) in 14 | 15 | let f12 = fun x -> (f13 x) in 16 | 17 | let f11 = fun x -> (f12 x) in 18 | 19 | let f10 = fun x -> (f11 x) in 20 | 21 | let f9 = fun x -> (f10 x) in 22 | 23 | let f8 = fun x -> (f9 x) in 24 | 25 | let f7 = fun x -> (f8 x) in 26 | 27 | let f6 = fun x -> (f7 x) in 28 | 29 | let f5 = fun x -> (f6 x) in 30 | 31 | let f4 = fun x -> (f5 x) in 32 | 33 | let f3 = fun x -> (f4 x) in 34 | 35 | let f2 = fun x -> (f3 x) in 36 | 37 | let f1 = fun x -> (f2 x) in 38 | 39 | (f1 3) 40 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: format 2 | dune build src/eff 3 | .PHONY: default 4 | 5 | format: 6 | dune build @fmt --auto-promote 7 | .PHONY: format 8 | 9 | release: format 10 | dune build --profile release 11 | .PHONY: release 12 | 13 | clean: 14 | dune clean 15 | .PHONY: clean 16 | 17 | test: default 18 | dune runtest 19 | .PHONY: test 20 | 21 | generate_benchmarks: 22 | dune build @generate_benchmarks --auto-promote 23 | .PHONY: generate_benchmark 24 | 25 | benchmark: 26 | dune build @benchmark --auto-promote 27 | .PHONY: benchmark 28 | 29 | graphs: 30 | cd misc/code-generation-benchmarks/generate-graphs && dune build . --auto-promote && ./graphs.exe 31 | .PHONY: graphs 32 | 33 | install: release 34 | dune install 35 | .PHONY: install 36 | 37 | uninstall: release 38 | dune uninstall 39 | .PHONY: uninstall 40 | -------------------------------------------------------------------------------- /src/00-utils/utils.ml: -------------------------------------------------------------------------------- 1 | module Assoc = Assoc 2 | module Config = Config 3 | module Error = Error 4 | module Graph = Graph 5 | module List = List 6 | module Location = Location 7 | module Option = Option 8 | module Print = Print 9 | module Symbol = Symbol 10 | module Symbols = Symbols 11 | 12 | type 'a located = { it : 'a; at : Location.t } 13 | type ('trm, 'ty) typed = { term : 'trm; ty : 'ty } 14 | type variance = Contravariant | Invariant | Covariant 15 | 16 | let inverse = function 17 | | Contravariant -> Covariant 18 | | Invariant -> Invariant 19 | | Covariant -> Contravariant 20 | 21 | let print_variance ?max_level p ppf = 22 | let print ?at_level = Print.print ?max_level ?at_level ppf in 23 | match p with 24 | | Covariant -> print "+" 25 | | Contravariant -> print "-" 26 | | Invariant -> print "" 27 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/display-results/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names benchmark) 3 | (ocamlopt_flags 4 | (:standard -O3)) 5 | (modes native) 6 | (libraries benchmark_suite bechamel-notty notty notty.unix unix)) 7 | 8 | (rule 9 | (deps 10 | (source_tree .)) 11 | (targets benchmark.output) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ./benchmark.exe)))) 16 | 17 | (rule 18 | (deps 19 | (source_tree .) 20 | benchmark.output) 21 | (targets benchmark.output.version) 22 | (action 23 | (with-stdout-to 24 | %{targets} 25 | (pipe-outputs 26 | (run echo "Ocaml Version: %{ocaml_version}\n") 27 | (run cat - benchmark.output))))) 28 | 29 | (rule 30 | (alias benchmark) 31 | (deps benchmark.output.version) 32 | (action 33 | (diff benchmark.expected benchmark.output.version))) 34 | -------------------------------------------------------------------------------- /etc/README.txt: -------------------------------------------------------------------------------- 1 | This directory contains miscellaneous support files. 2 | 3 | Support for Emacs 4 | ================= 5 | 6 | The file `eff-mode.el` is a derived Emacs mode for editing eff files. It is 7 | based on the [tuareg mode](http://www.emacswiki.org/emacs/TuaregMode) for 8 | Ocaml and thus requires that you have a working `tuareg-mode`. 9 | 10 | To use eff mode, copy `eff-mode.el` wherever you keep your Emacs lisp files 11 | and put something like this in your `.emacs` file: 12 | 13 | (autoload 'eff-mode "/eff-mode" "Major mode for editing eff files" t) 14 | (setq auto-mode-alist (cons '("\\.eff$" . eff-mode) auto-mode-alist)) 15 | 16 | Support for Textmate 17 | ==================== 18 | 19 | The directory `eff.tmbundle` contains a Textmate editing mode for eff 20 | files. Use it as you usually do. 21 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Miscellaneous.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Comments 7 | scope 8 | source.eff 9 | settings 10 | 11 | shellVariables 12 | 13 | 14 | name 15 | TM_COMMENT_START 16 | value 17 | (* 18 | 19 | 20 | name 21 | TM_COMMENT_END 22 | value 23 | *) 24 | 25 | 26 | 27 | uuid 28 | 4C99F5E7-F7D2-47A3-B232-C1E99C828F5D 29 | 30 | 31 | -------------------------------------------------------------------------------- /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v3 13 | 14 | - name: Setup OCaml 15 | uses: ocaml/setup-ocaml@v3 16 | with: 17 | ocaml-compiler: 4.14.x 18 | 19 | - name: Install Opam packages 20 | run: opam pin add -n .; opam install eff --deps-only 21 | 22 | - name: Test 23 | run: opam exec -- make test 24 | 25 | - name: Delete problematic files 26 | run: rm -rf misc tests 27 | 28 | - name: Build 29 | run: opam exec -- make release 30 | 31 | - name: Deploy 32 | uses: peaceiris/actions-gh-pages@v3 33 | with: 34 | github_token: ${{ secrets.GITHUB_TOKEN }} 35 | publish_dir: ./docs 36 | -------------------------------------------------------------------------------- /eff.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: 5 | "A functional programming language based on algebraic effect handlers" 6 | maintainer: ["matija@pretnar.info"] 7 | authors: ["Andrej Bauer" "Matija Pretnar"] 8 | license: "BSD2" 9 | homepage: "http://www.eff-lang.org/" 10 | bug-reports: "https://github.com/matijapretnar/eff/issues" 11 | depends: [ 12 | "dune" {>= "2.8"} 13 | "js_of_ocaml" 14 | "js_of_ocaml-ppx" 15 | "menhir" 16 | "ocaml" {>= "4.14.1"} 17 | "ocamlformat" {= "0.25.1"} 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 | dev-repo: "git+https://github.com/matijapretnar/eff.git" 35 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/dune: -------------------------------------------------------------------------------- 1 | (include dune.inc) 2 | 3 | (library 4 | (name benchmark_suite) 5 | (ocamlopt_flags 6 | (:standard -O3)) 7 | (modes native) 8 | (modules 9 | (:standard \ generate_benchmark_rules)) 10 | (libraries 11 | bechamel 12 | delimcc 13 | ocamlHeader 14 | (select 15 | config.ml 16 | from 17 | (!nativeMulticore -> "config.plain.ml") 18 | (nativeMulticore -> "config.multicore.ml")))) 19 | 20 | (executable 21 | (modules generate_benchmark_rules) 22 | (name generate_benchmark_rules)) 23 | 24 | (env 25 | (dev 26 | (flags 27 | (:standard -w -a)))) 28 | 29 | (rule 30 | (targets dune.gen) 31 | (deps 32 | (source_tree .)) 33 | (action 34 | (with-stdout-to 35 | %{targets} 36 | (run ./generate_benchmark_rules.exe)))) 37 | 38 | (rule 39 | (alias generate_benchmarks) 40 | (action 41 | (diff dune.inc dune.gen))) 42 | -------------------------------------------------------------------------------- /src/02-parser/commands.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Sugared = SugaredSyntax 3 | 4 | (* Toplevel commands (the first four do not need to be separated by [;;]) *) 5 | type t = plain_command located 6 | 7 | and plain_command = 8 | | Tydef of 9 | ( Sugared.tyname, 10 | (Sugared.typaram * variance) list * Sugared.tydef ) 11 | Assoc.t (** [type t = tydef] *) 12 | | TopLet of (Sugared.pattern * Sugared.term) list 13 | (** [let p1 = t1 and ... and pn = tn] *) 14 | | TopLetRec of (Sugared.variable * Sugared.term) list 15 | (** [let rec f1 p1 = t1 and ... and fn pn = tn] *) 16 | | DefEffect of (Sugared.effect * (Sugared.ty * Sugared.ty)) 17 | (** [effect Eff : ty1 -> t2] *) 18 | | Term of Sugared.term 19 | | Use of string (** [#use "filename.eff"] *) 20 | | Help (** [#help] *) 21 | | Quit (** [#quit] *) 22 | | TypeOf of Sugared.term (** [#type t] *) 23 | -------------------------------------------------------------------------------- /src/00-utils/error.ml: -------------------------------------------------------------------------------- 1 | (** Error reporting *) 2 | 3 | type t = Location.t option * string * string 4 | 5 | let print (loc, error_kind, msg) = Print.error ?loc error_kind "%s" msg 6 | 7 | exception Error of t 8 | 9 | (** [error ~loc error_kind fmt] raises an [Error] of kind [error_kind] with a 10 | message [fmt] at a location [loc]. The [kfprintf] magic allows us to 11 | construct the [fmt] using a format string before raising the exception. *) 12 | let error ?loc error_kind = 13 | let k _ = 14 | let msg = Format.flush_str_formatter () in 15 | raise (Error (loc, error_kind, msg)) 16 | in 17 | fun fmt -> Format.kfprintf k Format.str_formatter ("@[" ^^ fmt ^^ "@]") 18 | 19 | let fatal ?loc fmt = error ?loc "Fatal error" fmt 20 | let syntax ~loc fmt = error ~loc "Syntax error" fmt 21 | let typing ~loc fmt = error ~loc "Typing error" fmt 22 | let runtime ?loc fmt = error ?loc "Runtime error" fmt 23 | -------------------------------------------------------------------------------- /tests/valid/test_less_than.eff: -------------------------------------------------------------------------------- 1 | 1 < 1 ;; 2 | 1 < 2 ;; 3 | 2 < 1 ;; 4 | 1.0 < 1.0 ;; 5 | 1.0 < 2.0 ;; 6 | 2.0 < 1.0 ;; 7 | (1.0 /. 0.0) < 1.0 ;; 8 | 9 | "composite values" ;; 10 | (* Composite values. *) 11 | (1, "foo", []) < (1, "foo", [[]]) ;; (* should be true *) 12 | (1, "foo", [[]]) < (1, "foo", []) ;; (* should be false *) 13 | 14 | 15 | (* records *) 16 | "records" ;; 17 | type ('a, 'b) cow = { horn : 'a ; tail : 'b } ;; 18 | 19 | ({horn = 7; tail = "long"} < {horn = 7; tail = "short"}) ;; (* should be true *) 20 | ({horn = 7; tail = "short"} < {horn = 7; tail = "long"}) ;; (* should be false *) 21 | ({horn = 7; tail = "long"} < {tail = "short"; horn = 7}) ;; (* should be true *) 22 | ({horn = 8; tail = "long"} < {tail = "short"; horn = 7}) ;; (* should be false *) 23 | ({horn = [1;2]; tail = 0} < {tail = 0; horn = [3]}) ;; (* should be true *) 24 | ({tail = 0; horn = [3]} > {horn = [3]; tail = 0}) ;; (* should be false *) 25 | -------------------------------------------------------------------------------- /tests/codegen/pm-2_passes.eff: -------------------------------------------------------------------------------- 1 | 2 | effect Decide : bool;; 3 | 4 | (* handle (let rec f x = if perform (Decide ()) then 0 else f (x - 1) in f 0) with | effect Decide k -> k true;; *) 5 | 6 | let two = 2;; 7 | let three = 3;; 8 | 9 | type intlist = 10 | | IntNil 11 | | IntCons of int * intlist;; 12 | 13 | 14 | (* This handler collects all results that we can get by making different choices. *) 15 | 16 | 17 | (* This returns a list of four possibilities [10; 5; 20; 15] *) 18 | 19 | let rec concat xs = ( 20 | match xs with 21 | | IntNil -> fun ys -> ys 22 | | IntCons (z,zs) -> fun ys -> IntCons (z, concat zs ys) 23 | ) in 24 | with 25 | (handler 26 | | effect Decide k -> concat (k true) (k false) 27 | | x -> IntCons (x,IntNil) 28 | ) 29 | handle 30 | let rec f x = if perform (Decide ()) then 2 else 3 in f () 31 | (* let rec f x = if perform (Decide ()) then two else three in f () *) 32 | 33 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/bench.m: -------------------------------------------------------------------------------- 1 | dummyt = [0.67885 2 | 2.44208 3 | 5.22474 4 | 9.199 5 | 14.51163 6 | 22.82419 7 | 32.34955 8 | 40.75896 9 | 53.72458 10 | 69.26886]; 11 | 12 | dummyfunc = [18 38 58 78 98 118 138 158 178 198]; 13 | 14 | dummytype = [7602 15 | 16388 16 | 25930 17 | 35750 18 | 45590 19 | 55456 20 | 66306 21 | 77168 22 | 88006 23 | 98304]; 24 | 25 | dummyfuntype = [951 26 | 2239 27 | 3659 28 | 5002 29 | 6321 30 | 7622 31 | 8932 32 | 10242 33 | 11552 34 | 12862]; 35 | 36 | dummyfunt = [0.50272 37 | 1.10254 38 | 3.49156 39 | 7.57328 40 | 14.47544 41 | 24.32439 42 | 38.77991 43 | 58.61012 44 | 84.70287 45 | 117.16279]; 46 | 47 | dummyc = [29 59 89 119 149 179 209 239 269 299]; 48 | 49 | xval = linspace(10, 100, 10); 50 | 51 | % createfigure(xval, [transpose(dummyfunt); transpose(dummyt)]); 52 | 53 | % createfigure(xval, [dummyfunc; dummyc]); 54 | 55 | createfigure(xval, [transpose(dummyfuntype); transpose(dummytype)]); 56 | -------------------------------------------------------------------------------- /tests/codegen/pm-1_fails.eff: -------------------------------------------------------------------------------- 1 | 2 | effect Decide : bool;; 3 | 4 | (* handle (let rec f x = if perform (Decide ()) then 0 else f (x - 1) in f 0) with | effect Decide k -> k true;; *) 5 | 6 | let two = 2;; 7 | let three = 3;; 8 | 9 | type intlist = 10 | | IntNil 11 | | IntCons of int * intlist;; 12 | 13 | 14 | (* This handler collects all results that we can get by making different choices. *) 15 | 16 | 17 | (* This returns a list of four possibilities [10; 5; 20; 15] *) 18 | 19 | with 20 | (let rec concat xs = (match xs with 21 | | IntNil -> fun ys -> ys 22 | | IntCons (z,zs) -> fun ys -> IntCons (z, concat zs ys)) in 23 | handler 24 | | effect Decide k -> concat (k true) (k false) 25 | | x -> IntCons (x,IntNil) 26 | ) 27 | handle 28 | let rec f x = if perform (Decide ()) then 2 else 3 in f () 29 | (* let rec f x = if perform (Decide ()) then two else three in f () *) 30 | 31 | -------------------------------------------------------------------------------- /src/01-language/backend.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type state 3 | 4 | val initial_state : state 5 | 6 | val process_computation : 7 | state -> Type.Params.t * Term.computation * Constraints.t -> state 8 | 9 | val process_type_of : 10 | state -> Type.Params.t * Term.computation * Constraints.t -> state 11 | 12 | val process_def_effect : state -> Term.effect -> state 13 | 14 | val process_top_let : 15 | state -> 16 | (Term.pattern * Type.Params.t * Constraints.t * Term.computation) list -> 17 | state 18 | 19 | val process_top_let_rec : state -> Term.top_rec_definitions -> state 20 | 21 | val load_primitive_value : 22 | state -> Term.variable -> Primitives.primitive_value -> state 23 | 24 | val load_primitive_effect : 25 | state -> Term.effect -> Primitives.primitive_effect -> state 26 | 27 | val process_tydef : state -> (TyName.t, Type.type_data) Utils.Assoc.t -> state 28 | val finalize : state -> unit 29 | end 30 | -------------------------------------------------------------------------------- /tests/valid/typing.eff: -------------------------------------------------------------------------------- 1 | (* Basic types *) 2 | 3;; 3 | true;; 4 | "foo";; 5 | ();; 6 | 4.2;; 7 | 8 | (* Tuples *) 9 | (3,4);; 10 | ([], "foo");; 11 | 12 | (* variants *) 13 | type ('a,'b) cow = Small of 'a | Large of 'b;; 14 | Small "brown";; 15 | Large "white";; 16 | (fun cow -> match cow with Small k -> Large (k + 3) | Large s -> Small ("foo"::s));; 17 | 18 | (* records *) 19 | type ('a,'b) bull = {small : 'a; large : 'b};; 20 | {small = 5; large = "foo"};; 21 | (fun {small=k} -> k + 2);; 22 | (fun {large=l} -> [] :: l);; 23 | 24 | (* effects *) 25 | effect Bark : string -> string 26 | effect Wag : unit -> int;; 27 | 28 | fun _ -> perform (Bark "tree");; 29 | fun _ -> perform Wag;; 30 | 31 | (* Polymorphism *) 32 | (fun x -> x);; 33 | (fun x -> x) (fun y -> y);; 34 | (fun x -> (x, x));; 35 | ((fun x -> x), []);; 36 | ((fun x -> x), (fun x -> x) (fun y -> y));; 37 | (fun x y -> x);; 38 | [[[]]];; 39 | (fun x y -> (fun a -> a) x);; 40 | 41 | let rec h x = x;; 42 | h;; 43 | -------------------------------------------------------------------------------- /tests/valid/type_annotations.eff: -------------------------------------------------------------------------------- 1 | (* functions *) 2 | let f (x: int) = x;; 3 | let f (x: int) : int = x;; 4 | let f (x: bool) (y: int) (z: int -> bool -> int) : int = z y x in f true;; 5 | let f x : int*int = (x, x);; 6 | 7 | let g (x: 'a) = x;; 8 | let g (x: 'a) : 'a = 12;; 9 | let g (x: 'a) y : 'a = y;; 10 | let g x : 'a*'b = (x, x);; 11 | 12 | let f = function 13 | | (x: int) -> x 14 | ;; 15 | 16 | (* variants *) 17 | type ('a,'b) cow = Small of 'a | Large of 'b;; 18 | 19 | let f (x : ('a, 'b) cow) : int = 20 | match x with 21 | | Small x -> x 22 | | Large x -> 100 23 | ;; 24 | 25 | let f x : int = 26 | match x with 27 | | Small s -> 100 28 | | Large (l :int) -> 100 29 | ;; 30 | 31 | (* records *) 32 | type ('a,'b) bull = {small : 'a; large : 'b};; 33 | 34 | let f {small= (x: int); large= (y: int)} = x;; 35 | 36 | 37 | (* other *) 38 | let x = ([] : int list);; 39 | 40 | effect E : int -> string 41 | 42 | let h : int => 'a = handler 43 | | effect (E (x : int)) (k : string -> int) -> k "" 44 | -------------------------------------------------------------------------------- /etc/eff.tmbundle/Indent rules.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Indent rules 7 | scope 8 | source.eff 9 | settings 10 | 11 | decreaseIndentPattern 12 | ^\s*(end|done|with|in|else)\b|^\s*;;|^[^\("]*\) 13 | increaseIndentPattern 14 | ^.*(\([^)"\n]*|begin)$|\bobject\s*$|\blet [a-zA-Z0-9_-]+( [^ ]+)+ =\s*$|method[ \t]+.*=[ \t]*$|->[ \t]*$|\b(for|while)[ \t]+.*[ \t]+do[ \t]*$|(\btry$|\bhandle$|\bwith\s+.*\shandle$|\bif\s+.*\sthen$|\belse|[:=]\s*(sig|effect)|=\s*struct)\s*$ 15 | indentNextLinePattern 16 | (?!\bif.*then.*(else.*|(;|[ \t]in)[ \t]*$))\bif|\bthen[ \t]*$|\belse[ \t]*$$ 17 | 18 | uuid 19 | AD257FE4-8F09-4FE6-A0C3-CD5E15F75C5D 20 | 21 | 22 | -------------------------------------------------------------------------------- /tests/valid/state.eff: -------------------------------------------------------------------------------- 1 | effect Get: int 2 | effect Set: int -> unit 3 | effect Fail : empty ;; 4 | 5 | let state x = handler 6 | | y -> (fun _ -> y) 7 | | effect Get k -> (fun s -> k s s) 8 | | effect (Set s') k -> (fun _ -> k () s') 9 | 10 | let better_state x = handler 11 | | y -> (fun _ -> y) 12 | | effect Get k -> (fun s -> k s s) 13 | | effect (Set s') k -> (fun _ -> k () s') 14 | | finally f -> f x 15 | 16 | let transaction = handler 17 | | effect Get k -> (fun s -> k s s) 18 | | effect (Set s') k -> (fun s -> k () s') 19 | | x -> (fun s -> perform (Set s); x) 20 | | finally f -> f (perform Get);; 21 | 22 | with better_state 10 handle 23 | handle 24 | perform (Set 20); 25 | let x = perform Get in check x; 26 | (with transaction handle 27 | perform (Set 30); 28 | let x = perform Get in check x; 29 | absurd (perform Fail); 30 | perform (Set 50)); 31 | let x = perform Get in check x; 32 | 1 33 | with 34 | | effect (Fail _) _ -> let x = perform Get in check x; 0 35 | 36 | -------------------------------------------------------------------------------- /tests/codegen/constant_folding_match.eff: -------------------------------------------------------------------------------- 1 | type a = Nil | Cons of (int * a) 2 | ;; 3 | let f x = 4 | match x with 5 | | 1 -> 0 6 | | _ -> 4 7 | ;; 8 | let g a = 9 | let a0 = 10 | match a with 11 | | Nil -> 0 12 | | Cons(x, Nil) -> x + 4 13 | | Cons(4, x) -> 7 14 | | x -> 13 15 | in 16 | let a1 = 17 | match Nil with 18 | | Nil -> 0 19 | | Cons(x, Nil) -> x + 4 20 | | Cons(4, x) -> 7 21 | | x -> 13 22 | in 23 | let a2 = 24 | match Cons(3, Nil) with 25 | | Nil -> 0 26 | | Cons(x, Nil) -> x + 4 27 | | Cons(4, x) -> 7 28 | | x -> 13 29 | in 30 | let a3 = 31 | match Cons(3, Cons(4, Cons(10, Nil))) with 32 | | Nil -> 0 33 | | Cons(x, Nil) -> x + 4 34 | | Cons(4, x) -> 7 35 | | x -> 13 36 | in 37 | let a4 = 38 | match Cons(4, Cons(4, Cons(10, Nil))) with 39 | | Nil -> 0 40 | | Cons(x, Nil) -> x + 4 41 | | Cons(4, x) -> 7 42 | | x -> 13 43 | in (a0, a1, a2, a3, a4) -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy10.eff: -------------------------------------------------------------------------------- 1 | effect Dummy : unit -> int;; 2 | 3 | let h9 = handler 4 | | effect (Dummy _) k -> 3 5 | | x -> x 6 | in 7 | 8 | let h8 = handler 9 | | effect (Dummy _) k -> with h9 handle 3 10 | | x -> x 11 | in 12 | 13 | let h7 = handler 14 | | effect (Dummy _) k -> with h8 handle 3 15 | | x -> x 16 | in 17 | 18 | let h6 = handler 19 | | effect (Dummy _) k -> with h7 handle 3 20 | | x -> x 21 | in 22 | 23 | let h5 = handler 24 | | effect (Dummy _) k -> with h6 handle 3 25 | | x -> x 26 | in 27 | 28 | let h4 = handler 29 | | effect (Dummy _) k -> with h5 handle 3 30 | | x -> x 31 | in 32 | 33 | let h3 = handler 34 | | effect (Dummy _) k -> with h4 handle 3 35 | | x -> x 36 | in 37 | 38 | let h2 = handler 39 | | effect (Dummy _) k -> with h3 handle 3 40 | | x -> x 41 | in 42 | 43 | let h1 = handler 44 | | effect (Dummy _) k -> with h2 handle 3 45 | | x -> x 46 | 47 | in (with h1 handle (perform (Dummy ()))) 48 | -------------------------------------------------------------------------------- /tests/README.markdown: -------------------------------------------------------------------------------- 1 | # Eff test suite 2 | 3 | This directory contains scripts that test various aspects of Eff: 4 | 5 | It uses [cram tests](https://dune.readthedocs.io/en/stable/tests.html#cram-tests), 6 | where each `*.t` file contains the set of shell commands to run together with their 7 | expected output. Files may contain multiple such commands, though we often run just 8 | a single command that loops over all `*.eff` files in a folder. 9 | 10 | - Folders `valid` and `invalid` contain basic regression tests, which ensure that 11 | inferred types and computed values are what we expect. Any time a bug is 12 | found, one should add a new test that covers it. Folder `valid` contains programs 13 | that terminate successfuly, while the ones in `invalid` must terminate with an error. 14 | 15 | To add new test case, create a test file `text_xyz.eff` in the appropriate folder, 16 | run `dune runtest` to obtain the output, and update the cram file with `dune promote`. 17 | 18 | You can also create additional cram files which may source their `*.eff` files from 19 | an existing or a new subfolder. 20 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/rangeOpt.ml: -------------------------------------------------------------------------------- 1 | open OcamlHeader 2 | 3 | type (_, _) eff_internal_effect += Fetch : (unit, int) eff_internal_effect 4 | type int_list = Nil | Cons of (int * int_list) 5 | 6 | let _test_42 (_n_43 : int) = 7 | let rec _range_79 (_x_56, _k_81) = 8 | match _x_56 with 9 | | 0 -> _k_81 Nil 10 | | _ -> 11 | _range_79 12 | (_x_56 - 1, fun (_b_101 : int_list) -> _k_81 (Cons (42, _b_101))) 13 | in 14 | _range_79 (_n_43, fun (_x_51 : int_list) -> _x_51) 15 | 16 | let test = _test_42 17 | 18 | type (_, _) eff_internal_effect += 19 | | GeneratorPut : (int, unit) eff_internal_effect 20 | 21 | type (_, _) eff_internal_effect += 22 | | GeneratorGet : (unit, int) eff_internal_effect 23 | 24 | type (_, _) eff_internal_effect += 25 | | GeneratorProduce : (int, int) eff_internal_effect 26 | 27 | let _testGenerator_102 (_m_103 : int) = 28 | let rec _sum_375 _x_376 (_x_0 : int) = 29 | if _x_376 = 0 then _x_0 else _sum_375 (_x_376 - 1) (_x_0 + (_x_376 mod 42)) 30 | in 31 | _sum_375 _m_103 _m_103 32 | 33 | let testGenerator = _testGenerator_102 34 | -------------------------------------------------------------------------------- /docs/try/effmode.js: -------------------------------------------------------------------------------- 1 | CodeMirror.defineMIME('text/x-eff', { 2 | name: 'mllike', 3 | extraWords: { 4 | 'and' : 'keyword', 5 | 'as' : 'keyword', 6 | 'asr' : 'builtin', 7 | 'begin' : 'keyword', 8 | 'check' : 'keyword', 9 | 'effect' : 'keyword', 10 | 'else' : 'keyword', 11 | 'end' : 'keyword', 12 | 'false' : 'builtin', 13 | 'finally' : 'keyword', 14 | 'fun' : 'keyword', 15 | 'function' : 'keyword', 16 | 'handle' : 'keyword', 17 | 'handler' : 'keyword', 18 | 'if' : 'keyword', 19 | 'in' : 'keyword', 20 | 'land' : 'builtin', 21 | 'let' : 'keyword', 22 | 'lor' : 'builtin', 23 | 'lsl' : 'builtin', 24 | 'lsr' : 'builtin', 25 | 'lxor' : 'builtin', 26 | 'match' : 'keyword', 27 | 'mod' : 'builtin', 28 | 'of' : 'keyword', 29 | 'or' : 'builtin', 30 | 'perform' : 'keyword', 31 | 'rec' : 'keyword', 32 | 'then' : 'keyword', 33 | 'true' : 'builtin', 34 | 'type' : 'keyword', 35 | 'with' : 'keyword', 36 | 37 | // Standard library 38 | 'assert' : 'builtin', 39 | 'option' : 'type' 40 | }, 41 | slashComments: false 42 | }); 43 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/createfig.m: -------------------------------------------------------------------------------- 1 | function createfigure(X1, YMatrix1) 2 | %CREATEFIGURE(X1, YMATRIX1) 3 | % X1: vector of x data 4 | % YMATRIX1: matrix of y data 5 | 6 | % Auto-generated by MATLAB on 21-Dec-2019 20:04:10 7 | 8 | % Create figure 9 | figure1 = figure; 10 | 11 | % Create axes 12 | axes1 = axes('Parent',figure1,... 13 | 'Position',[0.13 0.0711009174311927 0.604417344173442 0.853899082568808]); 14 | hold(axes1,'on'); 15 | 16 | % Create multiple lines using matrix input to plot 17 | plot1 = plot(X1,YMatrix1,'LineWidth',3); 18 | set(plot1(1),'DisplayName','function indirection'); 19 | set(plot1(2),'DisplayName','handler indirection','Color',[1 0 0]); 20 | 21 | % Create xlabel 22 | xlabel({'Program size [# indirections]'},'FontWeight','bold','FontSize',14); 23 | 24 | % Create ylabel 25 | ylabel({'Constraint generation and solving time [ms]'},'FontWeight','bold',... 26 | 'FontSize',14); 27 | 28 | box(axes1,'on'); 29 | % Create legend 30 | legend1 = legend(axes1,'show'); 31 | set(legend1,... 32 | 'Position',[0.152664859981933 0.772471910112359 0.143631436314363 0.0941011235955056],... 33 | 'FontSize',14); 34 | 35 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/createfigure.m: -------------------------------------------------------------------------------- 1 | function createfigure(X1, YMatrix1) 2 | %CREATEFIGURE(X1, YMATRIX1) 3 | % X1: vector of x data 4 | % YMATRIX1: matrix of y data 5 | 6 | % Auto-generated by MATLAB on 21-Dec-2019 20:04:10 7 | 8 | % Create figure 9 | figure1 = figure; 10 | 11 | % Create axes 12 | axes1 = axes('Parent',figure1,... 13 | 'Position',[0.13 0.0711009174311927 0.604417344173442 0.853899082568808]); 14 | hold(axes1,'on'); 15 | 16 | % Create multiple lines using matrix input to plot 17 | plot1 = plot(X1,YMatrix1,'LineWidth',3); 18 | set(plot1(1),'DisplayName','function indirection'); 19 | set(plot1(2),'DisplayName','handler indirection','Color',[1 0 0]); 20 | 21 | % Create xlabel 22 | xlabel({'Program size [# indirections]'},'FontWeight','bold','FontSize',14); 23 | 24 | % Create ylabel 25 | ylabel({'Constraint generation and solving time [ms]'},'FontWeight','bold',... 26 | 'FontSize',14); 27 | 28 | box(axes1,'on'); 29 | % Create legend 30 | legend1 = legend(axes1,'show'); 31 | set(legend1,... 32 | 'Position',[0.152664859981933 0.772471910112359 0.143631436314363 0.0941011235955056],... 33 | 'FontSize',14); 34 | 35 | -------------------------------------------------------------------------------- /examples/delimited.eff: -------------------------------------------------------------------------------- 1 | (* This example is described in Section 6.11 of "Programming with Algebraic Effects and 2 | Handlers" by A. Bauer and M. Pretnar. *) 3 | 4 | effect Shift : ((int -> int) -> int) -> int 5 | (* Such operations are currently less usefull due to lack of polymorphism in 6 | current version of eff. In version 3.0 it is possible to have a polymorphic 7 | version. *) 8 | 9 | let reset = 10 | let rec reset_handler () = handler 11 | | effect (Shift f) k -> with reset_handler () handle (f k) 12 | in 13 | reset_handler () 14 | ;; 15 | 16 | (* An example from http://lamp.epfl.ch/~rompf/continuations-icfp09.pdf *) 17 | 18 | with reset handle 19 | perform (Shift (fun k -> k (k (k 7)))) * 2 + 1 20 | ;; 21 | 22 | (* The yin-yang puzzle, see 23 | http://stackoverflow.com/questions/2694679/how-the-yin-yang-puzzle-works 24 | 25 | Warning: To run this example you have to turn off type checking: 26 | 27 | eff --no-types delimited.eff*) 28 | 29 | (* 30 | with reset handle 31 | let yin = (fun k -> perform Print "@"; k) (perform Shift (fun k -> k k)) in 32 | let yang = (fun k -> perform Print "*"; k) (perform Shift (fun k -> k k)) in 33 | yin yang;; 34 | *) 35 | -------------------------------------------------------------------------------- /src/01-language/dirt.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | (** dirt parameters *) 4 | module Param = Symbol.Make (Symbol.Parameter (struct 5 | let ascii_symbol = "drt" 6 | let utf8_symbol = "δ" 7 | end)) 8 | 9 | module Row = struct 10 | type t = Param of Param.t | Empty 11 | end 12 | 13 | type t = { effect_set : Effect.Set.t; row : Row.t } 14 | 15 | let print ?max_level drt ppf = 16 | let print ?at_level = Print.print ?max_level ?at_level ppf in 17 | match (drt.effect_set, drt.row) with 18 | | effect_set, Empty -> print "{%t}" (Effect.Set.print effect_set) 19 | | effect_set, Param p when Effect.Set.is_empty effect_set -> 20 | print "%t" (Param.print p) 21 | | effect_set, Param p -> 22 | print ~at_level:1 "{%t}∪%t" (Effect.Set.print effect_set) (Param.print p) 23 | 24 | let closed effect_set = { effect_set; row = Row.Empty } 25 | let no_effect param = { effect_set = Effect.Set.empty; row = Param param } 26 | let fresh () = no_effect (Param.fresh ()) 27 | let empty = closed Effect.Set.empty 28 | let is_empty drt = Effect.Set.is_empty drt.effect_set && drt.row = Empty 29 | 30 | let add_effects effect_set drt = 31 | { drt with effect_set = Effect.Set.union drt.effect_set effect_set } 32 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy_fun30.eff: -------------------------------------------------------------------------------- 1 | let f29 = fun x -> x in 2 | 3 | let f28 = fun x -> (f29 x) in 4 | 5 | let f27 = fun x -> (f28 x) in 6 | 7 | let f26 = fun x -> (f27 x) in 8 | 9 | let f25 = fun x -> (f26 x) in 10 | 11 | let f24 = fun x -> (f25 x) in 12 | 13 | let f23 = fun x -> (f24 x) in 14 | 15 | let f22 = fun x -> (f23 x) in 16 | 17 | let f21 = fun x -> (f22 x) in 18 | 19 | let f20 = fun x -> (f21 x) in 20 | 21 | let f19 = fun x -> (f20 x) in 22 | 23 | let f18 = fun x -> (f19 x) in 24 | 25 | let f17 = fun x -> (f18 x) in 26 | 27 | let f16 = fun x -> (f17 x) in 28 | 29 | let f15 = fun x -> (f16 x) in 30 | 31 | let f14 = fun x -> (f15 x) in 32 | 33 | let f13 = fun x -> (f14 x) in 34 | 35 | let f12 = fun x -> (f13 x) in 36 | 37 | let f11 = fun x -> (f12 x) in 38 | 39 | let f10 = fun x -> (f11 x) in 40 | 41 | let f9 = fun x -> (f10 x) in 42 | 43 | let f8 = fun x -> (f9 x) in 44 | 45 | let f7 = fun x -> (f8 x) in 46 | 47 | let f6 = fun x -> (f7 x) in 48 | 49 | let f5 = fun x -> (f6 x) in 50 | 51 | let f4 = fun x -> (f5 x) in 52 | 53 | let f3 = fun x -> (f4 x) in 54 | 55 | let f2 = fun x -> (f3 x) in 56 | 57 | let f1 = fun x -> (f2 x) in 58 | 59 | (f1 3) 60 | -------------------------------------------------------------------------------- /src/02-parser/desugarer.mli: -------------------------------------------------------------------------------- 1 | open Utils 2 | open Language 3 | 4 | type state 5 | 6 | val initial_state : state 7 | 8 | val load_primitive_value : 9 | state -> UntypedSyntax.variable -> Primitives.primitive_value -> state 10 | 11 | val load_primitive_effect : 12 | state -> UntypedSyntax.variable -> Primitives.primitive_effect -> state 13 | 14 | val desugar_computation : 15 | state -> SugaredSyntax.term -> state * UntypedSyntax.computation 16 | 17 | val desugar_def_effect : 18 | loc:Location.t -> 19 | state -> 20 | SugaredSyntax.effect * (SugaredSyntax.ty * SugaredSyntax.ty) -> 21 | state * (Effect.t * (Type.ty * Type.ty)) 22 | 23 | val desugar_top_let : 24 | loc:Location.t -> 25 | state -> 26 | (SugaredSyntax.pattern * SugaredSyntax.term) list -> 27 | state * (UntypedSyntax.pattern * UntypedSyntax.computation) list 28 | 29 | val desugar_top_let_rec : 30 | state -> 31 | (SugaredSyntax.variable * SugaredSyntax.term) list -> 32 | state * (Term.Variable.t * UntypedSyntax.abstraction) list 33 | 34 | val desugar_tydefs : 35 | loc:Utils.Location.t -> 36 | state -> 37 | ( string, 38 | (SugaredSyntax.typaram * variance) list * SugaredSyntax.tydef ) 39 | Assoc.t -> 40 | state * (TyName.t, Type.type_data) Assoc.t 41 | -------------------------------------------------------------------------------- /src/00-utils/config.ml: -------------------------------------------------------------------------------- 1 | (** Configuration parameters *) 2 | 3 | let version = "5.1" 4 | let use_stdlib = ref true 5 | 6 | type backend = Runtime | Multicore | Ocaml 7 | 8 | let backend = ref Runtime 9 | let ascii = ref false 10 | let interactive_shell = ref true 11 | let wrapper = ref (Some [ "rlwrap"; "ledit" ]) 12 | let include_header_open = ref true 13 | let verbosity = ref 3 14 | let output_formatter = ref Format.std_formatter 15 | let error_formatter = ref Format.err_formatter 16 | let enable_optimization = ref true 17 | let profiling = ref false 18 | let print_graph = ref false 19 | let optimization_fuel = ref 5 20 | 21 | type 'a optimizator_base_config = { 22 | specialize_functions : 'a; 23 | eliminate_coercions : 'a; 24 | push_coercions : 'a; 25 | handler_reductions : 'a; 26 | purity_aware_translation : 'a; 27 | } 28 | 29 | type optimizator_config = bool optimizator_base_config 30 | 31 | let optimizator_config = 32 | ref 33 | { 34 | (* ok *) 35 | specialize_functions = true; 36 | (* plays badly with lambda_lift *) 37 | eliminate_coercions = true; 38 | (* ok *) 39 | push_coercions = true; 40 | (* ok *) 41 | handler_reductions = true; 42 | (* not ok *) 43 | purity_aware_translation = true; 44 | } 45 | -------------------------------------------------------------------------------- /src/00-utils/list.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.List 2 | 3 | val fold : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a 4 | 5 | val fold_map : 6 | ('state -> 'a -> 'state * 'b) -> 'state -> 'a list -> 'state * 'b list 7 | 8 | val left_to_right_map : ('a -> 'b) -> 'a list -> 'b list 9 | (** Custom definition of map to ensure the order of sideffects. *) 10 | 11 | val unique_elements : 'a list -> 'a list 12 | (** Returns a list of all unique elements of given list. *) 13 | 14 | val no_duplicates : 'a list -> bool 15 | (** Checks that the list doesn't contain duplicates. *) 16 | 17 | val list_diff : 'a list -> 'a list -> 'a list 18 | (** Returns elements of the first list that or not present in the second. *) 19 | 20 | val concat_map : ('a -> 'b list) -> 'a list -> 'b list 21 | 22 | val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool 23 | (** [equal eq [a1; ...; an] [b1; ..; bm]] holds when 24 | the two input lists have the same length, and for each 25 | pair of elements [ai], [bi] at the same position we have 26 | [eq ai bi]. 27 | Note: the [eq] function may be called even if the 28 | lists have different length. If you know your equality 29 | function is costly, you may want to check {!compare_lengths} 30 | first. 31 | Natively available in: 4.12.0 32 | *) 33 | -------------------------------------------------------------------------------- /src/00-utils/symbols.ml: -------------------------------------------------------------------------------- 1 | let handler_arrow () = if !Config.ascii then "=>" else "\226\159\185 " 2 | let short_arrow () = if !Config.ascii then "->" else "\226\134\146" 3 | let times () = if !Config.ascii then " * " else " \195\151 " 4 | 5 | let subscript sub = 6 | match sub with 7 | | None -> "" 8 | | Some i -> 9 | if !Config.ascii then string_of_int i 10 | else 11 | let rec sub i = 12 | let last = 13 | List.nth 14 | [ 15 | "\226\130\128"; 16 | "\226\130\129"; 17 | "\226\130\130"; 18 | "\226\130\131"; 19 | "\226\130\132"; 20 | "\226\130\133"; 21 | "\226\130\134"; 22 | "\226\130\135"; 23 | "\226\130\136"; 24 | "\226\130\137"; 25 | ] 26 | (i mod 10) 27 | in 28 | if i < 10 then last else sub (i / 10) ^ last 29 | in 30 | sub i 31 | 32 | let param ascii_symbol utf8_symbol index poly ppf = 33 | let prefix = if poly then "_" else "" 34 | and symbol = if !Config.ascii then ascii_symbol else utf8_symbol in 35 | Print.print ppf "%s%s%s" prefix symbol (subscript (Some (index + 1))) 36 | 37 | let ty_param = param "ty" "\207\132" 38 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/links/install_links.sh: -------------------------------------------------------------------------------- 1 | # To install the effects compiler (or any other experimental OCaml compiler) 2 | # I recommend first installing Gabriel Scherer's `opam compiler-conf`: 3 | git clone https://github.com/gasche/opam-compiler-conf 4 | cd opam-compiler-conf 5 | ./opam-compiler.conf.sh 6 | cd .. 7 | 8 | # After that download and install the effects compiler: 9 | git clone -b 4.02.2+effects https://github.com/ocamllabs/ocaml-effects.git 10 | cd ocaml-effects 11 | opam compiler-conf configure 12 | make world.opt 13 | opam compiler-conf install 14 | 15 | # After installation is done, `opam' will ask you to update the environment, i.e. eval `opam config env`. 16 | # In order to install Links you need the packages `deriving' and `lwt' from opam. 17 | # However, the former depends on `ppx_tools' which is broken under the multicore/effects compiler. 18 | # Fortunately, KC has patched version on his github. We can pin it directly in opam: 19 | cd .. 20 | opam pin add ppx_tools https://github.com/kayceesrk/ppx_tools/archive/v4.02.3-effects.zip 21 | opam install lwt deriving 22 | 23 | git clone -b effect-handlers-compilation https://github.com/links-lang/links links-effects 24 | cd links-effects 25 | make nc 26 | 27 | # Now you can run links 28 | ./links -c programs/cointoss.links -o toss 29 | ./toss 30 | -------------------------------------------------------------------------------- /src/00-utils/list.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.List 2 | 3 | let fold = Stdlib.List.fold_left 4 | 5 | let fold_map f s xs = 6 | let aux (s, reversed_ys) x = 7 | let s', y = f s x in 8 | (s', y :: reversed_ys) 9 | in 10 | let s', reversed_ys = fold aux (s, []) xs in 11 | (s', Stdlib.List.rev reversed_ys) 12 | 13 | let rec left_to_right_map f = function 14 | | [] -> [] 15 | | x :: xs -> 16 | let y = f x in 17 | let ys = left_to_right_map f xs in 18 | y :: ys 19 | 20 | let unique_elements lst = 21 | let rec unique_elements acc = function 22 | | [] -> Stdlib.List.rev acc 23 | | x :: xs -> 24 | if Stdlib.List.mem x acc then unique_elements acc xs 25 | else unique_elements (x :: acc) xs 26 | in 27 | unique_elements [] lst 28 | 29 | let no_duplicates lst = 30 | let rec check seen = function 31 | | [] -> true 32 | | x :: xs -> (not (Stdlib.List.mem x seen)) && check (x :: seen) xs 33 | in 34 | check [] lst 35 | 36 | let list_diff lst1 lst2 = 37 | Stdlib.List.filter (fun x -> not (Stdlib.List.mem x lst2)) lst1 38 | 39 | let concat_map f lst = Stdlib.List.concat (Stdlib.List.map f lst) 40 | 41 | let rec equal eq l1 l2 = 42 | match (l1, l2) with 43 | | [], [] -> true 44 | | [], _ :: _ | _ :: _, [] -> false 45 | | a1 :: l1, a2 :: l2 -> eq a1 a2 && equal eq l1 l2 46 | -------------------------------------------------------------------------------- /src/00-utils/symbol.mli: -------------------------------------------------------------------------------- 1 | module type Annotation = sig 2 | type t 3 | 4 | val print : bool -> t -> int -> Format.formatter -> unit 5 | end 6 | 7 | module Anonymous : Annotation with type t = unit 8 | module String : Annotation with type t = string 9 | module Int : Annotation with type t = int 10 | 11 | module Parameter (Param : sig 12 | val ascii_symbol : string 13 | val utf8_symbol : string 14 | end) : Annotation with type t = unit 15 | 16 | module type S = sig 17 | type annot 18 | type t 19 | 20 | val compare : t -> t -> int 21 | val fresh : annot -> t 22 | val new_fresh : unit -> annot -> t 23 | val refresh : t -> t 24 | val print : ?safe:bool -> t -> Format.formatter -> unit 25 | val fold : (annot -> int -> 'a) -> t -> 'a 26 | 27 | module Set : sig 28 | include Set.S with type elt = t 29 | 30 | val print : t -> Format.formatter -> unit 31 | end 32 | 33 | module Map : sig 34 | include Map.S with type key = t 35 | 36 | val of_bindings : (key * 'a) list -> 'a t 37 | val compatible_union : 'a t -> 'a t -> 'a t 38 | val keys : 'a t -> key list 39 | val values : 'a t -> 'a list 40 | 41 | val print : 42 | ('a -> Format.formatter -> unit) -> 'a t -> Format.formatter -> unit 43 | end 44 | end 45 | 46 | module Make (Annot : Annotation) : S with type annot = Annot.t 47 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/queensMulticore.ml: -------------------------------------------------------------------------------- 1 | (* Taken verbatim from 2 | https://github.com/ocaml-multicore/effects-examples/blob/68f16120873f1ade4536ab3916ccce47fd424f9e/queens.ml 3 | *) 4 | 5 | effect Select : 'a list -> 'a 6 | 7 | let rec filter p = function 8 | | [] -> [] 9 | | x :: xs -> 10 | if p x then (x :: filter p xs) else filter p xs 11 | 12 | let rec forall p = function 13 | | [] -> true 14 | | x :: xs -> if p x then forall p xs else false 15 | 16 | let no_attack (x,y) (x',y') = 17 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 18 | 19 | let available x qs l = 20 | filter (fun y -> forall (no_attack (x,y)) qs) l 21 | 22 | let find_solution n = 23 | try 24 | let l = ref [] in 25 | for i = n downto 1 do 26 | l := i::!l; 27 | done; 28 | let rec place x qs = 29 | if x = n+1 then Some qs else 30 | let y = perform @@ Select (available x qs !l) in 31 | place (x+1) ((x, y) :: qs) 32 | in place 1 [] 33 | with 34 | | effect (Select lst) k -> 35 | let rec loop = function 36 | | [] -> None 37 | | x::xs -> 38 | match continue (Obj.clone_continuation k) x with 39 | | None -> loop xs 40 | | Some x -> Some x 41 | in loop lst 42 | 43 | let queens_all number_of_queens = 44 | find_solution number_of_queens 45 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Andrej Bauer and Matija Pretnar 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, 6 | are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, this 12 | list of conditions and the following disclaimer in the documentation and/or 13 | other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 22 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/loopNative.ml: -------------------------------------------------------------------------------- 1 | let rec loop_pure n = if n = 0 then () else loop_pure (n - 1) 2 | let test_pure n = loop_pure n 3 | 4 | (******************************************************************************) 5 | 6 | exception Fail 7 | 8 | let rec loop_latent n = 9 | if n = 0 then () else if n < 0 then raise Fail else loop_latent (n - 1) 10 | 11 | let test_latent n = loop_latent n 12 | 13 | (******************************************************************************) 14 | 15 | let rec loop_incr counter n = 16 | if n = 0 then () 17 | else ( 18 | incr counter; 19 | loop_incr counter (n - 1)) 20 | 21 | let test_incr n = 22 | let counter = ref 0 in 23 | loop_incr counter n; 24 | !counter 25 | 26 | (******************************************************************************) 27 | 28 | let rec loop_incr' counter n = 29 | if n = 0 then () 30 | else ( 31 | loop_incr' counter (n - 1); 32 | incr counter) 33 | 34 | let test_incr' n = 35 | let counter = ref 0 in 36 | loop_incr' counter n; 37 | !counter 38 | 39 | (******************************************************************************) 40 | 41 | let rec loop_state state n = 42 | if n = 0 then () 43 | else ( 44 | state := !state + 1; 45 | loop_state state (n - 1)) 46 | 47 | let test_state n = 48 | let state = ref 0 in 49 | loop_state state n; 50 | !state 51 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/interp/interpNative.ml: -------------------------------------------------------------------------------- 1 | type term = 2 | | Num of int 3 | | Add of term * term 4 | | Mul of term * term 5 | | Sub of term * term 6 | | Div of term * term 7 | 8 | exception DivByZero 9 | 10 | let rec interp = function 11 | | Num b -> b 12 | | Add (l, r) -> 13 | let x = interp l in 14 | let y = interp r in 15 | x + y 16 | | Mul (l, r) -> 17 | let x = interp l in 18 | let y = interp r in 19 | x * y 20 | | Sub (l, r) -> 21 | let x = interp l in 22 | let y = interp r in 23 | x - y 24 | | Div (l, r) -> 25 | let y = interp r in 26 | let x = interp l in 27 | begin match y with 28 | | 0 -> raise DivByZero 29 | | _ -> x / y 30 | end 31 | 32 | (******************************************************************************) 33 | 34 | let addCase = 35 | Add ( 36 | Add ( 37 | Add ((Num 20), (Num 2)), 38 | Mul ((Num 1), (Num 2)) 39 | ), 40 | Sub ( 41 | Add ((Num 2), (Num 2)), 42 | Div ((Num 1), (Num 10)) 43 | ) 44 | );; 45 | 46 | let rec createCase n = 47 | begin match n with 48 | | 1 -> (Div (Num 100, Num 0)) 49 | | _ -> Add (addCase, (createCase (n - 1))) 50 | end 51 | 52 | let finalCase = createCase 200 53 | 54 | let bigTest () = 55 | try 56 | interp (createCase 200) 57 | with 58 | | DivByZero -> -1 59 | -------------------------------------------------------------------------------- /src/jseff/jseff.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | open Js_of_ocaml 3 | 4 | let js_formatter _format echo = 5 | let buffer = ref "" in 6 | let out s p n = buffer := !buffer ^ String.sub s p n in 7 | let flush () = 8 | (Js.Unsafe.fun_call echo [| Js.Unsafe.inject (Js.string !buffer) |] : unit); 9 | buffer := "" 10 | in 11 | Format.make_formatter out flush 12 | 13 | module Shell = Loader.Shell.Make (Runtime.Backend) 14 | 15 | (* Export the interface to Javascript. *) 16 | let _ = 17 | Js.export "jseff" 18 | (object%js 19 | method initialize echo = 20 | Config.output_formatter := js_formatter "[;#00a8ff;#192a56]" echo; 21 | Config.error_formatter := js_formatter "[b;#e84118;#192a56]" echo; 22 | let state = Shell.initialize () in 23 | let state = Shell.load_source Loader.Stdlib_eff.source state in 24 | Format.fprintf !Config.output_formatter "eff %s@." Config.version; 25 | Format.fprintf !Config.output_formatter "[Type #help for help.]@."; 26 | state 27 | 28 | method executeSource state source = 29 | try Shell.execute_source (Js.to_string source) state 30 | with Error.Error err -> 31 | Error.print err; 32 | state 33 | 34 | method loadSource state source = 35 | try Shell.load_source (Js.to_string source) state 36 | with Error.Error err -> 37 | Error.print err; 38 | state 39 | end) 40 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/dummy_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 0.638 2 | 0.655 3 | 0.734 4 | 0.625 5 | 0.6679999999999999 6 | 0.6759999999999999 7 | 0.618 8 | 0.705 9 | 0.608 10 | 0.643 11 | 0.6669999999999999 12 | 0.6809999999999999 13 | 0.714 14 | 0.671 15 | 0.616 16 | 0.652 17 | 0.615 18 | 0.611 19 | 0.603 20 | 0.603 21 | 0.6539999999999999 22 | 0.601 23 | 0.678 24 | 0.603 25 | 0.597 26 | 0.603 27 | 0.637 28 | 0.6759999999999999 29 | 0.631 30 | 0.767 31 | 0.644 32 | 0.6819999999999999 33 | 0.631 34 | 0.6920000000000001 35 | 0.707 36 | 0.7649999999999999 37 | 0.639 38 | 0.652 39 | 0.623 40 | 0.634 41 | 0.662 42 | 0.8059999999999999 43 | 0.749 44 | 0.634 45 | 0.67 46 | 0.669 47 | 0.664 48 | 0.6579999999999999 49 | 0.616 50 | 0.637 51 | 0.669 52 | 0.718 53 | 0.665 54 | 0.63 55 | 0.638 56 | 0.694 57 | 0.683 58 | 0.7290000000000001 59 | 0.619 60 | 0.653 61 | 0.632 62 | 0.603 63 | 0.603 64 | 0.6980000000000001 65 | 0.633 66 | 0.601 67 | 0.744 68 | 0.714 69 | 0.732 70 | 0.623 71 | 0.639 72 | 0.6579999999999999 73 | 0.6859999999999999 74 | 0.657 75 | 0.619 76 | 0.631 77 | 0.6040000000000001 78 | 0.65 79 | 0.631 80 | 0.6880000000000001 81 | 0.6589999999999999 82 | 0.594 83 | 0.6 84 | 0.684 85 | 0.603 86 | 0.6 87 | 0.603 88 | 0.705 89 | 0.602 90 | 0.606 91 | 0.6679999999999999 92 | 0.633 93 | 0.606 94 | 0.617 95 | 0.69 96 | 0.626 97 | 0.622 98 | 0.611 99 | 0.6 100 | 0.605 101 | -------------------------------------------------------------------------------- /docs/try/examples/syntax.eff: -------------------------------------------------------------------------------- 1 | (** Overview of syntax *) 2 | 3 | (** If you are familiar with OCaml, you will find Eff easy to read 4 | and you can jump straight to examples of effects by choosing one 5 | of the above tabs. 6 | 7 | Eff syntax is close to that of OCaml, which we review 8 | quickly in this file. An online OCaml tutorial is available at 9 | http://try.ocamlpro.com. 10 | *) 11 | 12 | (* You can define variables. *) 13 | let x = 10 + 10 14 | let y = x * 3 15 | 16 | (* You can define functions. *) 17 | let double x = 2 * x 18 | 19 | (* Functions can be recursive. *) 20 | let rec fact n = 21 | if n = 0 then 1 else n * fact (n - 1) 22 | 23 | (* Or even mutually recursive. *) 24 | let rec even n = 25 | match n with 26 | | 0 -> true 27 | | x -> odd (x-1) 28 | and odd n = 29 | match n with 30 | | 0 -> false 31 | | x -> even (x-1) 32 | 33 | (* You can declare your own types. *) 34 | type shape = 35 | | Circle of float 36 | | Rectangle of float * float 37 | 38 | (* And you can use pattern matching to define functions on such types. *) 39 | let area shape = 40 | match shape with 41 | | Circle r -> 3.14159 *. r *. r 42 | | Rectangle (w, h) -> w *. h 43 | 44 | (* You can write the above using the "function" shortcut. *) 45 | let perimeter = function 46 | | Circle r -> 2.0 *. 3.14159 *. r 47 | | Rectangle (w, h) -> 2.0 *. (w +. h) 48 | 49 | (* Like in OCaml, a double semicolon separates commands in a file. *) 50 | ;; 51 | -------------------------------------------------------------------------------- /docs/try/examples/state.eff: -------------------------------------------------------------------------------- 1 | (** State *) 2 | 3 | (* It is often beneficial to have some form of a mutable state, which can be 4 | implemented using handlers. Below is an example of a simple integer state. *) 5 | 6 | effect Get: int 7 | effect Set: int -> unit 8 | 9 | (* The monad_state handler wraps the computation in a function and the state 10 | is passed around as the function input. The initial value of the state 11 | is given to the transformed computation as input. *) 12 | 13 | let monad_state = handler 14 | | y -> (fun _ -> y) 15 | | effect Get k -> (fun s -> (continue k s) s) 16 | | effect (Set s') k -> (fun _ -> (continue k ()) s') 17 | ;; 18 | 19 | let f = with monad_state handle 20 | let x = perform Get in 21 | perform (Set (2 * x)); 22 | perform Get + 10 23 | in 24 | f 30 25 | ;; 26 | 27 | (* We can improve it by giving the state a default initial value using the 28 | "finally" keyword. The value of the initial value is given to the handler 29 | as a parameter. By modifying the case for values we also return the result 30 | and the final state value instead of just the result. *) 31 | 32 | let better_state initial = handler 33 | | y -> (fun s -> (y, s)) 34 | | effect Get k -> (fun s -> (continue k s) s) 35 | | effect (Set s') k -> (fun _ -> (continue k ()) s') 36 | | finally f -> f initial 37 | ;; 38 | 39 | with better_state 30 handle 40 | let x = perform Get in 41 | perform (Set (2 * x)); 42 | perform Get + 10 43 | ;; 44 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/interp/multicore.ml: -------------------------------------------------------------------------------- 1 | type term = 2 | | Num of int 3 | | Add of term * term 4 | | Mul of term * term 5 | | Sub of term * term 6 | | Div of term * term 7 | 8 | effect DivByZero : (unit -> int) 9 | 10 | let rec interp = function 11 | | Num b -> b 12 | | Add (l, r) -> 13 | let x = interp l in 14 | let y = interp r in 15 | x + y 16 | | Mul (l, r) -> 17 | let x = interp l in 18 | let y = interp r in 19 | x * y 20 | | Sub (l, r) -> 21 | let x = interp l in 22 | let y = interp r in 23 | x - y 24 | | Div (l, r) -> 25 | let y = interp r in 26 | let x = interp l in 27 | begin match y with 28 | | 0 -> perform DivByZero () 29 | | _ -> x / y 30 | end 31 | 32 | (******************************************************************************) 33 | 34 | let addCase = 35 | Add ( 36 | Add ( 37 | Add ((Num 20), (Num 2)), 38 | Mul ((Num 1), (Num 2)) 39 | ), 40 | Sub ( 41 | Add ((Num 2), (Num 2)), 42 | Div ((Num 1), (Num 10)) 43 | ) 44 | );; 45 | 46 | let rec createCase n = 47 | begin match n with 48 | | 1 -> (Div (Num 100, Num 0)) 49 | | _ -> Add (addCase, (createCase (n - 1))) 50 | end 51 | 52 | let finalCase = createCase 200 53 | 54 | let bigTest () = 55 | match interp (createCase 200) with 56 | | x -> x 57 | | effect DivByZero k -> 58 | continue k (fun () -> -1);; 59 | -------------------------------------------------------------------------------- /src/00-utils/error.mli: -------------------------------------------------------------------------------- 1 | (** Error reporting 2 | 3 | All internal errors are represented uniformly with a single exception that 4 | carries additional details such as error kind (syntax, typing, ...), message 5 | or location. 6 | 7 | Errors are raised through helper functions that take an optional location 8 | and a message in form of a format string, for example: 9 | [Error.runtime ~loc "Unhandled effect %t" (Effect.print eff)]. *) 10 | 11 | type t 12 | (** Type of errors. *) 13 | 14 | val print : t -> unit 15 | (** Print an error. *) 16 | 17 | exception Error of t 18 | (** Exception representing all possible Eff errors. *) 19 | 20 | val fatal : ?loc:Location.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 21 | (** Fatal errors are errors over which Eff has no control, for example when 22 | a file cannot be opened. *) 23 | 24 | val syntax : loc:Location.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 25 | (** Syntax errors occur during lexing, parsing, or desugaring into Eff's core 26 | language. *) 27 | 28 | val typing : loc:Location.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 29 | (** Typing errors can occur while defining types and during type inference. *) 30 | 31 | val runtime : ?loc:Location.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 32 | (** Runtime errors are usually prevented by type-checking. Otherwise, they occur 33 | when pattern match is not exhaustive, or when an externally defined function 34 | has an incorrectly assigned type. *) 35 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/bench.py: -------------------------------------------------------------------------------- 1 | import subprocess 2 | import sys 3 | from timeit import default_timer as timer 4 | 5 | RUNS = int(sys.argv[2]) 6 | counter = 0 7 | 8 | filename = sys.argv[1] 9 | 10 | resultfile_time = open(filename + "_timing.txt" , "w+") 11 | resultfile_nb = open(filename + "_constraints.txt" , "w+") 12 | resultfile_type = open(filename + "_type.txt" , "w+") 13 | 14 | for num in range(10, 101, 10): 15 | print(num.__str__()) 16 | counter = 0 17 | while counter < RUNS: 18 | result = subprocess.check_output(["./eff", "--explicit-subtyping", filename + num.__str__() + ".eff"]).__str__()[2:] 19 | counter += 1 20 | 21 | result_lines = result.split("\\n") 22 | sum = 0 23 | typesum = 0 24 | 25 | i = 1 26 | while not result_lines[i].strip(" ").startswith("TYPESTART"): 27 | sum += int(result_lines[i].strip(" ")) 28 | i += 1 29 | while not result_lines[i].strip(" ").startswith("TYPEEND"): 30 | typesum += result_lines[i].strip(" ").__len__() 31 | i += 1 32 | while not result_lines[i].strip(" ").startswith("TIME: "): 33 | i += 1 34 | resultfile_time.write((float(result_lines[i][6:])*1000.0).__str__() + "\n") 35 | 36 | if counter == RUNS-1: 37 | resultfile_nb.write(sum.__str__() + "\n") 38 | resultfile_type.write(typesum.__str__() + "\n") 39 | 40 | resultfile_time.close() 41 | resultfile_nb.close() 42 | resultfile_type.close() 43 | -------------------------------------------------------------------------------- /src/01-language/const.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type t = Integer of int | String of string | Boolean of bool | Float of float 4 | type ty = IntegerTy | StringTy | BooleanTy | FloatTy 5 | type comparison = Less | Equal | Greater | Invalid 6 | 7 | let of_integer n = Integer n 8 | let of_string s = String s 9 | let of_boolean b = Boolean b 10 | let of_float f = Float f 11 | let of_true = of_boolean true 12 | let of_false = of_boolean false 13 | 14 | let print c ppf = 15 | match c with 16 | | Integer k -> Format.fprintf ppf "%d" k 17 | | String s -> Format.fprintf ppf "%S" s 18 | | Boolean b -> Format.fprintf ppf "%B" b 19 | | Float f -> Format.fprintf ppf "%F" f 20 | 21 | let print_ty c ppf = 22 | match c with 23 | | IntegerTy -> Format.fprintf ppf "int" 24 | | StringTy -> Format.fprintf ppf "string" 25 | | BooleanTy -> Format.fprintf ppf "bool" 26 | | FloatTy -> Format.fprintf ppf "float" 27 | 28 | let infer_ty = function 29 | | Integer _ -> IntegerTy 30 | | String _ -> StringTy 31 | | Boolean _ -> BooleanTy 32 | | Float _ -> FloatTy 33 | 34 | let compare c1 c2 = 35 | let cmp x y = 36 | let r = Stdlib.compare x y in 37 | if r < 0 then Less else if r > 0 then Greater else Equal 38 | in 39 | match (c1, c2) with 40 | | Integer n1, Integer n2 -> cmp n1 n2 41 | | String s1, String s2 -> cmp s1 s2 42 | | Boolean b1, Boolean b2 -> cmp b1 b2 43 | | Float x1, Float x2 -> cmp x1 x2 44 | | _ -> Error.runtime "Incomparable constants %t and %t" (print c1) (print c2) 45 | 46 | let equal c1 c2 = compare c1 c2 = Equal 47 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy_fun40.eff: -------------------------------------------------------------------------------- 1 | let f39 = fun x -> x in 2 | 3 | let f38 = fun x -> (f39 x) in 4 | 5 | let f37 = fun x -> (f38 x) in 6 | 7 | let f36 = fun x -> (f37 x) in 8 | 9 | let f35 = fun x -> (f36 x) in 10 | 11 | let f34 = fun x -> (f35 x) in 12 | 13 | let f33 = fun x -> (f34 x) in 14 | 15 | let f32 = fun x -> (f33 x) in 16 | 17 | let f31 = fun x -> (f32 x) in 18 | 19 | let f30 = fun x -> (f31 x) in 20 | 21 | let f29 = fun x -> (f30 x) in 22 | 23 | let f28 = fun x -> (f29 x) in 24 | 25 | let f27 = fun x -> (f28 x) in 26 | 27 | let f26 = fun x -> (f27 x) in 28 | 29 | let f25 = fun x -> (f26 x) in 30 | 31 | let f24 = fun x -> (f25 x) in 32 | 33 | let f23 = fun x -> (f24 x) in 34 | 35 | let f22 = fun x -> (f23 x) in 36 | 37 | let f21 = fun x -> (f22 x) in 38 | 39 | let f20 = fun x -> (f21 x) in 40 | 41 | let f19 = fun x -> (f20 x) in 42 | 43 | let f18 = fun x -> (f19 x) in 44 | 45 | let f17 = fun x -> (f18 x) in 46 | 47 | let f16 = fun x -> (f17 x) in 48 | 49 | let f15 = fun x -> (f16 x) in 50 | 51 | let f14 = fun x -> (f15 x) in 52 | 53 | let f13 = fun x -> (f14 x) in 54 | 55 | let f12 = fun x -> (f13 x) in 56 | 57 | let f11 = fun x -> (f12 x) in 58 | 59 | let f10 = fun x -> (f11 x) in 60 | 61 | let f9 = fun x -> (f10 x) in 62 | 63 | let f8 = fun x -> (f9 x) in 64 | 65 | let f7 = fun x -> (f8 x) in 66 | 67 | let f6 = fun x -> (f7 x) in 68 | 69 | let f5 = fun x -> (f6 x) in 70 | 71 | let f4 = fun x -> (f5 x) in 72 | 73 | let f3 = fun x -> (f4 x) in 74 | 75 | let f2 = fun x -> (f3 x) in 76 | 77 | let f1 = fun x -> (f2 x) in 78 | 79 | (f1 3) 80 | -------------------------------------------------------------------------------- /src/00-utils/config.mli: -------------------------------------------------------------------------------- 1 | (** Configuration parameters *) 2 | 3 | val version : string 4 | (** Current version *) 5 | 6 | val use_stdlib : bool ref 7 | (** Should we load the standard library? *) 8 | 9 | type backend = Runtime | Multicore | Ocaml 10 | 11 | val backend : backend ref 12 | 13 | val ascii : bool ref 14 | (** Should we use ASCII instead of Unicode for printing out types? *) 15 | 16 | val interactive_shell : bool ref 17 | (** Should the interactive shell be run? *) 18 | 19 | val wrapper : string list option ref 20 | (** The command-line wrappers that we look for *) 21 | 22 | val include_header_open : bool ref 23 | (** Should we include the open OcamlHeader in the generated files? *) 24 | 25 | val verbosity : int ref 26 | (** Select which messages should be printed: 27 | - 0 no messages 28 | - 1 only errors 29 | - 2 errors and check 30 | - 3 errors, check, and warnings 31 | - 4 errors, check, warnings, and debug messages *) 32 | 33 | val output_formatter : Format.formatter ref 34 | val error_formatter : Format.formatter ref 35 | 36 | val enable_optimization : bool ref 37 | (** Should compiled computations be optimized? *) 38 | 39 | val print_graph : bool ref 40 | 41 | val profiling : bool ref 42 | (** Should profiling be enabled? *) 43 | 44 | val optimization_fuel : int ref 45 | 46 | type 'a optimizator_base_config = { 47 | specialize_functions : 'a; 48 | eliminate_coercions : 'a; 49 | push_coercions : 'a; 50 | handler_reductions : 'a; 51 | purity_aware_translation : 'a; 52 | } 53 | 54 | type optimizator_config = bool optimizator_base_config 55 | 56 | val optimizator_config : optimizator_config ref 57 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/loopMulticore.ml: -------------------------------------------------------------------------------- 1 | let absurd x = failwith "error" 2 | let rec loop_pure n = 3 | if n = 0 then 4 | () 5 | else 6 | loop_pure (n - 1) 7 | 8 | let test_pure n = 9 | loop_pure n 10 | 11 | effect Fail : unit -> unit 12 | 13 | let rec loop_latent n = 14 | if n = 0 then 15 | () 16 | else if n < 0 then 17 | ( absurd (perform (Fail ()))) 18 | else 19 | loop_latent (n - 1) 20 | 21 | let test_latent n = 22 | loop_latent n 23 | 24 | effect Incr : unit -> unit 25 | 26 | let rec loop_incr n = 27 | if n = 0 then 28 | () 29 | else 30 | (perform (Incr ()); loop_incr (n - 1)) 31 | 32 | let test_incr n = 33 | (match loop_incr n 34 | with 35 | | effect (Incr ()) k -> (fun x -> (continue k ()) (x + 1)) 36 | | _ -> (fun x -> x) 37 | ) 0 38 | 39 | 40 | let rec loop_incr' n = 41 | if n = 0 then 42 | () 43 | else 44 | (loop_incr' (n - 1); perform (Incr ())) 45 | 46 | let test_incr' n = 47 | (match loop_incr' n with 48 | | y -> (fun x -> x) 49 | | effect (Incr ()) k -> (fun x -> (continue k ()) (x + 1)) 50 | ) 0 51 | 52 | effect Get: unit -> int 53 | effect Put: int -> unit 54 | 55 | let rec loop_state n = 56 | if n = 0 then 57 | () 58 | else 59 | (perform (Put ((perform (Get ())) + 1)); loop_state (n - 1)) 60 | 61 | let test_state n = 62 | (match loop_state n 63 | with 64 | | y -> (fun x -> x) 65 | | effect (Get ()) k -> (fun (s:int) -> (continue k s) s) (* Annotation is needed for type inference *) 66 | | effect (Put s') k -> (fun _ -> (continue k ()) s') 67 | ) 0 -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/range.eff: -------------------------------------------------------------------------------- 1 | effect Fetch : unit -> int;; 2 | 3 | type int_list = Nil | Cons of int * int_list 4 | ;; 5 | let test n = 6 | let rec range n = 7 | match n with 8 | | 0 -> Nil 9 | | _ -> 10 | Cons (perform (Fetch ()), range (n - 1)) 11 | in 12 | handle ( range n ) with 13 | | x -> x 14 | | effect (Fetch _) k -> k 42 15 | 16 | 17 | effect GeneratorPut: int -> unit 18 | effect GeneratorGet: unit -> int 19 | effect GeneratorProduce: int -> int 20 | ;; 21 | let testGenerator m = 22 | let n = 42 in 23 | let rec sum i = 24 | if i = 0 then perform (GeneratorGet ()) 25 | else 26 | (perform (GeneratorPut ( (perform (GeneratorGet ())) + (perform (GeneratorProduce i)))); 27 | sum (i-1)) 28 | in 29 | let monad_state = handler 30 | | effect (GeneratorGet ()) k -> ( 31 | fun s -> (k s) s 32 | ) 33 | | effect (GeneratorPut s) k -> ( 34 | fun _ -> (k ()) s 35 | ) 36 | | y -> (fun _ -> y) 37 | in 38 | let produce_handler = handler 39 | | effect (GeneratorProduce i) k -> (k (i mod n)) 40 | in 41 | (with monad_state handle ( 42 | with produce_handler handle (sum m) 43 | )) m 44 | 45 | 46 | 47 | (* effect Get: unit -> int_list 48 | effect Put: int_list -> unit 49 | 50 | ;; 51 | let test n = 52 | let rec range n = 53 | match n with 54 | | 0 -> perform (Put Nil) 55 | | _ -> 56 | (let q = (perform (Fetch ())) in 57 | range (n-1); 58 | perform ( Put (Cons(q, perform (Get ()) )) 59 | )) 60 | in 61 | (handle (handle ( range n ) with 62 | | x -> x 63 | | effect (Fetch _) k -> k 42 64 | ) with 65 | | y -> (fun _ -> y) 66 | | effect (Get ()) k -> (fun s -> k s s) 67 | | effect (Put s') k -> (fun _ -> k () s') 68 | ) Nil *) -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/interp/interp.eff: -------------------------------------------------------------------------------- 1 | external ( + ) : int -> int -> int = "+" 2 | external ( * ) : int -> int -> int = "*" 3 | external ( - ) : int -> int -> int = "-" 4 | external ( ~- ) : int -> int = "~-" 5 | external ( / ) : int -> int -> int = "/" 6 | 7 | (******************************************************************************) 8 | 9 | type term = 10 | | Num of int 11 | | Add of term * term 12 | | Mul of term * term 13 | | Sub of term * term 14 | | Div of term * term 15 | 16 | effect DivByZero : unit -> int 17 | 18 | let rec interp = function 19 | | Num b -> b 20 | | Add (l, r) -> 21 | let x = interp l in 22 | let y = interp r in 23 | x + y 24 | | Mul (l, r) -> 25 | let x = interp l in 26 | let y = interp r in 27 | x * y 28 | | Sub (l, r) -> 29 | let x = interp l in 30 | let y = interp r in 31 | x - y 32 | | Div (l, r) -> 33 | let y = interp r in 34 | let x = interp l in 35 | begin match y with 36 | | 0 -> #DivByZero () 37 | | _ -> x / y 38 | end 39 | 40 | let arithmeticHandler = handler 41 | | #DivByZero () k -> -1 42 | 43 | (******************************************************************************) 44 | 45 | let addCase = 46 | Add ( 47 | Add ( 48 | Add ((Num 20), (Num 2)), 49 | Mul ((Num 1), (Num 2)) 50 | ), 51 | Sub ( 52 | Add ((Num 2), (Num 2)), 53 | Div ((Num 1), (Num 10)) 54 | ) 55 | );; 56 | 57 | let rec createCase n = 58 | begin match n with 59 | | 1 -> (Div (Num 100, Num 0)) 60 | | _ -> Add (addCase, (createCase (n - 1))) 61 | end 62 | 63 | let finalCase = createCase 200 64 | 65 | let bigTest () = 66 | with arithmeticHandler handle interp (createCase 200) 67 | -------------------------------------------------------------------------------- /src/00-utils/location.ml: -------------------------------------------------------------------------------- 1 | (** Source code locations *) 2 | 3 | type t = { 4 | filename : string; 5 | start_line : int; 6 | start_column : int; 7 | end_line : int; 8 | end_column : int; 9 | } 10 | 11 | let print { filename; start_line; start_column; _ } ppf = 12 | if String.length filename != 0 then 13 | Format.fprintf ppf "file %S, line %d, char %d" filename start_line 14 | start_column 15 | else Format.fprintf ppf "line %d, char %d" (start_line - 1) start_column 16 | 17 | (** Dismantles a lexing position into its filename, line and column. *) 18 | let dismantle lexing_position = 19 | let filename = lexing_position.Lexing.pos_fname 20 | and line = lexing_position.Lexing.pos_lnum 21 | and column = 22 | lexing_position.Lexing.pos_cnum - lexing_position.Lexing.pos_bol + 1 23 | in 24 | (filename, line, column) 25 | 26 | let make start_lexing_position end_lexing_position = 27 | let start_filename, start_line, start_column = dismantle start_lexing_position 28 | and end_filename, end_line, end_column = dismantle end_lexing_position in 29 | assert (start_filename = end_filename); 30 | { filename = start_filename; start_line; start_column; end_line; end_column } 31 | 32 | let union loc1 loc2 = 33 | if loc1.filename <> loc2.filename then 34 | invalid_arg "Location.union: locations do not belong to the same file" 35 | else 36 | let start_line, start_column = 37 | min 38 | (loc1.start_line, loc1.start_column) 39 | (loc2.start_line, loc2.start_column) 40 | and end_line, end_column = 41 | max (loc1.end_line, loc1.end_column) (loc2.end_line, loc2.end_column) 42 | in 43 | { loc1 with start_line; start_column; end_line; end_column } 44 | 45 | let of_lexeme lex = make (Lexing.lexeme_start_p lex) (Lexing.lexeme_end_p lex) 46 | -------------------------------------------------------------------------------- /src/05-backends/plain-ocaml/primitives.ml: -------------------------------------------------------------------------------- 1 | module Primitives = Language.Primitives 2 | 3 | let primitive_source = function 4 | | Primitives.CompareEq -> "( = )" 5 | | Primitives.CompareGe -> "( >= )" 6 | | Primitives.CompareGt -> "( > )" 7 | | Primitives.CompareLe -> "( <= )" 8 | | Primitives.CompareLt -> "( < )" 9 | | Primitives.CompareNe -> "( <> )" 10 | | Primitives.FloatAcos -> "acos" 11 | | Primitives.FloatAdd -> "( +. )" 12 | | Primitives.FloatAsin -> "asin" 13 | | Primitives.FloatAtan -> "atan" 14 | | Primitives.FloatCos -> "cos" 15 | | Primitives.FloatDiv -> "( /. )" 16 | | Primitives.FloatExp -> "exp" 17 | | Primitives.FloatExpm1 -> "expm1" 18 | | Primitives.FloatInfinity -> "infinity" 19 | | Primitives.FloatLog -> "log" 20 | | Primitives.FloatLog1p -> "log1p" 21 | | Primitives.FloatMul -> "( *. )" 22 | | Primitives.FloatNaN -> "nan" 23 | | Primitives.FloatNeg -> "( ~-. )" 24 | | Primitives.FloatNegInfinity -> "neg_infinity" 25 | | Primitives.FloatOfInt -> "float_of_int" 26 | | Primitives.FloatSin -> "sin" 27 | | Primitives.FloatSqrt -> "sqrt" 28 | | Primitives.FloatSub -> "( -. )" 29 | | Primitives.FloatTan -> "tan" 30 | | Primitives.IntegerAdd -> "( + )" 31 | | Primitives.IntegerDiv -> "( / )" 32 | | Primitives.IntegerMod -> "( mod )" 33 | | Primitives.IntegerMul -> "( * )" 34 | | Primitives.IntegerNeg -> "( ~- )" 35 | | Primitives.IntegerAbs -> "abs" 36 | | Primitives.IntegerPow -> "( ** )" 37 | | Primitives.IntegerSub -> "( - )" 38 | | Primitives.IntOfFloat -> "int_of_float" 39 | | Primitives.StringConcat -> "( ^ )" 40 | | Primitives.StringLength -> "String.length" 41 | | Primitives.StringOfFloat -> "string_of_float" 42 | | Primitives.StringOfInt -> "string_of_int" 43 | | Primitives.StringSub -> "sub" 44 | | Primitives.ToString -> "to_string" 45 | -------------------------------------------------------------------------------- /etc/eff-mode.el: -------------------------------------------------------------------------------- 1 | ; Emacs mode for eff, derived from OCaml tuareg-mode. See LICENSE.txt 2 | ; for licensing information. 3 | ; 4 | ; This code could be much improved. 5 | ; 6 | ; To use the eff-mode, put this file somewhere and add something like the following 7 | ; in your .emacs file: 8 | ; 9 | ; (autoload 'eff-mode "/eff-mode" "Major mode for editing eff files" t) 10 | ; (setq auto-mode-alist (cons '("\\.eff$" . eff-mode) auto-mode-alist)) 11 | 12 | (defvar eff-keywords 13 | '("and" 14 | "as" 15 | "begin" 16 | "check" 17 | "do" 18 | "done" 19 | "downto" 20 | "else" 21 | "end" 22 | "effect" 23 | "finally" 24 | "for" 25 | "fun" 26 | "function" 27 | "handle" 28 | "handler" 29 | "if" 30 | "in" 31 | "match" 32 | "let" 33 | "new" 34 | "of" 35 | "operation" 36 | "rec" 37 | "val" 38 | "while" 39 | "to" 40 | "type" 41 | "then" 42 | "with")) 43 | 44 | (defvar eff-constants 45 | '( 46 | "asr" 47 | "false" 48 | "mod" 49 | "land" 50 | "lor" 51 | "lsl" 52 | "lsr" 53 | "lxor" 54 | "or" 55 | "true")) 56 | 57 | (defvar eff-tab-width 2 "Width of tab for eff mode") 58 | 59 | (defvar eff-font-lock-defaults 60 | `(( 61 | ;; stuff between " 62 | ("\"\\.\\*\\?" . font-lock-string-face) 63 | ;; prefix and infix operators, can be improved 64 | ("+\\|,\\|;" . font-lock-keyword-face) 65 | ( ,(regexp-opt eff-keywords 'words) . font-lock-keyword-face) 66 | ( ,(regexp-opt eff-constants 'words) . font-lock-constant-face) 67 | ))) 68 | 69 | (define-derived-mode eff-mode 70 | tuareg-mode 71 | "Eff" 72 | "Major mode for eff (unfinished)." 73 | 74 | (setq font-lock-defaults eff-font-lock-defaults) 75 | 76 | ; (when eff-tab-width (setq tab-width eff-tab-width)) 77 | ; 78 | ; (setq comment-start "(*") 79 | ; (setq comment-end "*)") 80 | ) 81 | 82 | (provide 'eff-mode) 83 | -------------------------------------------------------------------------------- /src/05-backends/multicore-ocaml/symbol.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | open Language 3 | 4 | let protected = 5 | [ "and"; "as"; "assert"; "asr"; "begin"; "class"; "constraint"; "do"; "done" ] 6 | @ [ "downto"; "else"; "end"; "exception"; "false"; "for"; "fun" ] 7 | @ [ "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer" ] 8 | @ [ "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; "lxor"; "match"; "method" ] 9 | @ [ 10 | "mod"; "module"; "mutable"; "new"; "nonrec"; "object"; "of"; "open"; "or"; 11 | ] 12 | @ [ "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type" ] 13 | @ [ "val"; "virtual"; "when"; "while"; "with"; "continue" ] 14 | 15 | let print_variable var ppf = 16 | let printer desc n = 17 | (* [mod] has privileges because otherwise it's stupid *) 18 | if desc = "mod" then Format.fprintf ppf "_op_%d (* %s *)" n desc 19 | else ( 20 | if List.mem desc protected then 21 | Print.warning 22 | "Warning: Protected keyword [%s]. Must be fixed by hand!@." desc; 23 | match desc.[0] with 24 | | 'a' .. 'z' | '_' -> Format.fprintf ppf "%s" desc 25 | | '$' -> ( 26 | match desc with 27 | | "$c_thunk" -> Format.fprintf ppf "_comp_%d" n 28 | | "$id_par" -> Format.fprintf ppf "_id_%d" n 29 | | "$anon" -> Format.fprintf ppf "_anon_%d" n 30 | | "$bind" -> Format.fprintf ppf "_b_%d" n 31 | | _ -> Format.fprintf ppf "_x_%d" n) 32 | | _ -> Format.fprintf ppf "_op_%d (* %s *)" n desc) 33 | in 34 | Term.Variable.fold printer var 35 | 36 | let print_effect eff ppf = Effect.print eff ppf 37 | let print_label lbl ppf = Type.Label.print lbl ppf 38 | let print_field fld ppf = Type.Field.print fld ppf 39 | 40 | let print_tyname tyname ppf = 41 | let printer desc _n = Format.fprintf ppf "%s" desc in 42 | TyName.fold printer tyname 43 | 44 | let print_typaram typaram ppf = 45 | let printer _desc n = Format.fprintf ppf "'ty_%d" n in 46 | Type.TyParam.fold printer typaram 47 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/8queens_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 88.729; 225 2 | 88.11; 225 3 | 85.298; 225 4 | 86.20800000000001; 225 5 | 92.378; 225 6 | 88.071; 225 7 | 87.59; 225 8 | 88.385; 225 9 | 85.482; 225 10 | 85.316; 225 11 | 86.038; 225 12 | 84.512; 225 13 | 84.854; 225 14 | 87.429; 225 15 | 85.445; 225 16 | 85.302; 225 17 | 85.35; 225 18 | 85.97200000000001; 225 19 | 87.78099999999999; 225 20 | 89.813; 225 21 | 89.742; 225 22 | 84.655; 225 23 | 85.701; 225 24 | 84.801; 225 25 | 89.624; 225 26 | 92.655; 225 27 | 92.045; 225 28 | 85.373; 225 29 | 88.217; 225 30 | 85.08699999999999; 225 31 | 90.979; 225 32 | 90.45100000000001; 225 33 | 93.296; 225 34 | 90.783; 225 35 | 91.49300000000001; 225 36 | 97.558; 225 37 | 89.2; 225 38 | 90.10600000000001; 225 39 | 92.63499999999999; 225 40 | 87.187; 225 41 | 93.705; 225 42 | 87.992; 225 43 | 85.341; 225 44 | 87.415; 225 45 | 85.298; 225 46 | 88.634; 225 47 | 90.077; 225 48 | 90.59200000000001; 225 49 | 90.443; 225 50 | 90.211; 225 51 | 92.622; 225 52 | 91.947; 225 53 | 86.385; 225 54 | 88.03999999999999; 225 55 | 85.405; 225 56 | 85.381; 225 57 | 85.779; 225 58 | 85.122; 225 59 | 85.022; 225 60 | 86.888; 225 61 | 84.99900000000001; 225 62 | 85.367; 225 63 | 85.252; 225 64 | 85.788; 225 65 | 84.378; 225 66 | 84.571; 225 67 | 84.84700000000001; 225 68 | 84.996; 225 69 | 84.952; 225 70 | 85.205; 225 71 | 84.777; 225 72 | 90.794; 225 73 | 92.012; 225 74 | 85.797; 225 75 | 85.804; 225 76 | 86.09400000000001; 225 77 | 91.828; 225 78 | 89.059; 225 79 | 84.875; 225 80 | 87.889; 225 81 | 88.274; 225 82 | 93.212; 225 83 | 89.488; 225 84 | 91.347; 225 85 | 92.181; 225 86 | 93.60499999999999; 225 87 | 91.42500000000001; 225 88 | 90.488; 225 89 | 89.57; 225 90 | 92.14; 225 91 | 92.517; 225 92 | 86.96900000000001; 225 93 | 86.80300000000001; 225 94 | 93.899; 225 95 | 90.174; 225 96 | 92.61500000000001; 225 97 | 93.96000000000001; 225 98 | 96.29; 225 99 | 90.43900000000001; 225 100 | 90.82600000000001; 225 101 | -------------------------------------------------------------------------------- /src/01-language/untypedSyntax.mli: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | (** Syntax of the core language. *) 4 | 5 | type variable = Term.Variable.t 6 | type effect = Effect.t 7 | type label = Type.Label.t 8 | type field = Type.Field.t 9 | 10 | type pattern = plain_pattern located 11 | 12 | and plain_pattern = 13 | | PVar of variable 14 | | PAnnotated of pattern * Type.ty 15 | | PAs of pattern * variable 16 | | PTuple of pattern list 17 | | PRecord of pattern Type.Field.Map.t 18 | | PVariant of label * pattern option 19 | | PConst of Const.t 20 | | PNonbinding 21 | 22 | type expression = plain_expression located 23 | (** Pure expressions *) 24 | 25 | and plain_expression = 26 | | Var of variable 27 | | Const of Const.t 28 | | Annotated of expression * Type.ty 29 | | Tuple of expression list 30 | | Record of expression Type.Field.Map.t 31 | | Variant of label * expression option 32 | | Lambda of abstraction 33 | | Effect of effect 34 | | Handler of handler 35 | 36 | and computation = plain_computation located 37 | (** Impure computations *) 38 | 39 | and plain_computation = 40 | | Value of expression 41 | | Let of (pattern * computation) list * computation 42 | | LetRec of (variable * abstraction) list * computation 43 | | Match of expression * abstraction list 44 | | Apply of expression * expression 45 | | Handle of expression * computation 46 | | Check of computation 47 | 48 | and handler = { 49 | effect_clauses : (effect, abstraction2) Assoc.t; 50 | value_clause : abstraction; 51 | finally_clause : abstraction; 52 | } 53 | (** Handler definitions *) 54 | 55 | and abstraction = pattern * computation 56 | (** Abstractions that take one argument. *) 57 | 58 | and abstraction2 = pattern * pattern * computation 59 | (** Abstractions that take two arguments. *) 60 | 61 | val print_pattern : ?max_level:int -> pattern -> Format.formatter -> unit 62 | 63 | val print_computation : 64 | ?max_level:int -> computation -> Format.formatter -> unit 65 | 66 | val print_expression : ?max_level:int -> expression -> Format.formatter -> unit 67 | -------------------------------------------------------------------------------- /src/05-backends/runtime/runtime.ml: -------------------------------------------------------------------------------- 1 | (* Evaluation of the intermediate language, big step. *) 2 | 3 | open Utils 4 | module V = Value 5 | module Type = Language.Type 6 | 7 | module Backend : Language.Backend.S = struct 8 | type state = Eval.state 9 | 10 | let initial_state = Eval.initial_state 11 | 12 | let load_primitive_value state x prim = 13 | Eval.update x (Primitives.primitive_value prim) state 14 | 15 | let load_primitive_effect state eff prim = 16 | Eval.add_runner eff (Primitives.runner prim) state 17 | 18 | (* Processing functions *) 19 | let process_computation state ((params : Type.Params.t), c, _) = 20 | let v = Eval.run state c in 21 | Format.fprintf !Config.output_formatter "- : @[%t@] = @[%t@]@." 22 | (Type.print_pretty params.skel_params (fst c.ty).ty) 23 | (V.print_value v); 24 | state 25 | 26 | let process_type_of state (_, c, _) = 27 | Format.fprintf !Config.output_formatter "- : %t@." (Type.print_dirty c.ty); 28 | state 29 | 30 | let process_def_effect state _ = state 31 | 32 | let process_top_let state defs = 33 | match defs with 34 | | [] -> state 35 | | [ (pat, (params : Type.Params.t), _constraints, comp) ] -> 36 | let v = Eval.run state comp in 37 | Format.fprintf !Config.output_formatter "@[val %t : %t = %t@]@." 38 | (Language.Term.print_pattern pat) 39 | (Type.print_pretty params.skel_params (fst comp.ty).ty) 40 | (V.print_value v); 41 | Eval.extend pat v state 42 | | _ -> failwith __LOC__ 43 | 44 | let process_top_let_rec state defs = 45 | Assoc.iter 46 | (fun (f, ((params : Type.Params.t), _constraints, abs)) -> 47 | Format.fprintf !Config.output_formatter "@[val %t : %t = @]@." 48 | (Language.Term.Variable.print f) 49 | (Type.print_pretty params.skel_params (Type.arrow abs.ty).ty)) 50 | defs; 51 | Eval.extend_let_rec state (Assoc.map (fun (_, _, abs) -> abs) defs) 52 | 53 | let process_tydef state _tydefs = state 54 | let finalize _state = () 55 | end 56 | -------------------------------------------------------------------------------- /examples/yield.eff: -------------------------------------------------------------------------------- 1 | (* Yield from http://parametricity.net/dropbox/yield.subc.pdf *) 2 | 3 | (* The type is output_type -> input_type. *) 4 | effect Yield : int -> int 5 | 6 | type ('i, 'o, 'r) iterator = 7 | (* Final result of iterator. *) 8 | | Result of 'r 9 | (* Suspended value encapsulating the yielded value and the updated iterator. *) 10 | | Susp of 'o * ('i -> ('i, 'o, 'r) iterator) 11 | ;; 12 | 13 | let run = handler 14 | (* Return the value of yield and the continuation as the updated iterator. *) 15 | | effect (Yield x) k -> Susp (x, k) 16 | (* The iterator has finished. *) 17 | | x -> Result x 18 | ;; 19 | 20 | (* Example of depthWalk presented in the original paper. *) 21 | 22 | type 'a tree = Node of 'a tree * 'a tree | Leaf of 'a;; 23 | 24 | (* A function that traverses the tree and transforms the leaves by using the 25 | iterator. *) 26 | let rec depthWalk = function 27 | | Node (l, r) -> 28 | let l' = depthWalk l in 29 | let r' = depthWalk r in 30 | Node (l', r') 31 | | Leaf a -> 32 | let b = perform (Yield a) in 33 | Leaf b 34 | ;; 35 | 36 | (* The actual iterator behaviour is defined in the handler. *) 37 | let rec renum = function 38 | | Susp(x,k) -> renum (k (x+1)) 39 | | Result r -> r 40 | ;; 41 | 42 | let iter_tree = 43 | (with run handle 44 | depthWalk (Node (Leaf 10, Leaf 20))) 45 | in 46 | renum iter_tree 47 | ;; 48 | 49 | 50 | (* Translation of yield to shift and reset. 51 | [Doesn't work without better types for #Yield.] 52 | 53 | let shift f = perform (Yield f) 54 | ;; 55 | 56 | let rec reset thunk = 57 | interp (with run handle thunk ()) 58 | and interp = function 59 | | Result r -> r 60 | | Susp (f, k) -> reset (fun () -> f (fun i -> interp (k i))) 61 | ;; 62 | 63 | *) 64 | (* To run this example, you have to turn off type checking with --no-types: 65 | 66 | eff --no-types yield.eff 67 | *) 68 | (* 69 | reset (fun () -> 70 | let yin = (fun k -> perform (Print "@"); k) (shift (fun k -> k k)) in 71 | let yang = (fun k -> perform (Print "*"); k) (shift (fun k -> k k)) in 72 | yin yang);; 73 | *) 74 | -------------------------------------------------------------------------------- /src/05-backends/multicore-ocaml/syntax.mli: -------------------------------------------------------------------------------- 1 | open Language 2 | 3 | type variable = Term.Variable.t 4 | type effect = Effect.t 5 | type label = Type.Label.t 6 | type field = Type.Field.t 7 | 8 | (** Types used by MulticoreOcaml. *) 9 | type ty = 10 | | TyApply of TyName.t * ty list 11 | | TyParam of Type.TyParam.t 12 | | TyBasic of Const.ty 13 | | TyTuple of ty list 14 | | TyArrow of ty * ty 15 | 16 | type tydef = 17 | | TyDefRecord of ty Type.Field.Map.t 18 | | TyDefSum of ty option Type.Field.Map.t 19 | | TyDefInline of ty 20 | 21 | (** Patterns *) 22 | type pattern = 23 | | PVar of variable 24 | | PAnnotated of pattern * ty 25 | | PAs of pattern * variable 26 | | PTuple of pattern list 27 | | PRecord of pattern Type.Field.Map.t 28 | | PVariant of label * pattern option 29 | | PConst of Const.t 30 | | PNonbinding 31 | 32 | (** Pure expressions *) 33 | type term = 34 | | Var of variable 35 | | Const of Const.t 36 | | Annotated of term * ty 37 | | Tuple of term list 38 | | Record of term Type.Field.Map.t 39 | | Variant of label * term option 40 | | Lambda of abstraction 41 | | Function of match_case list 42 | | Effect of effect 43 | | Let of (pattern * term) list * term 44 | | LetRec of (variable * abstraction) list * term 45 | | Match of term * match_case list 46 | | Apply of term * term 47 | | Check of term 48 | 49 | and match_case = 50 | | ValueClause of abstraction 51 | | EffectClause of effect * abstraction2 52 | 53 | and abstraction = pattern * term 54 | (** Abstractions that take one argument. *) 55 | 56 | and abstraction2 = pattern * pattern * term 57 | (** Abstractions that take two arguments. *) 58 | 59 | type cmd = 60 | | Term of term 61 | | DefEffect of effect * (ty * ty) 62 | | TopLet of (pattern * term) list 63 | | TopLetRec of (variable * abstraction) list 64 | | RawSource of (variable * string) 65 | | TyDef of (label * (Type.TyParam.t list * tydef)) list 66 | 67 | val print_header : 68 | (effect * (ty * ty) * (string * string * string)) list -> 69 | Format.formatter -> 70 | unit 71 | 72 | val print_cmd : cmd -> Format.formatter -> unit 73 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy_fun50.eff: -------------------------------------------------------------------------------- 1 | let f49 = fun x -> x in 2 | 3 | let f48 = fun x -> (f49 x) in 4 | 5 | let f47 = fun x -> (f48 x) in 6 | 7 | let f46 = fun x -> (f47 x) in 8 | 9 | let f45 = fun x -> (f46 x) in 10 | 11 | let f44 = fun x -> (f45 x) in 12 | 13 | let f43 = fun x -> (f44 x) in 14 | 15 | let f42 = fun x -> (f43 x) in 16 | 17 | let f41 = fun x -> (f42 x) in 18 | 19 | let f40 = fun x -> (f41 x) in 20 | 21 | let f39 = fun x -> (f40 x) in 22 | 23 | let f38 = fun x -> (f39 x) in 24 | 25 | let f37 = fun x -> (f38 x) in 26 | 27 | let f36 = fun x -> (f37 x) in 28 | 29 | let f35 = fun x -> (f36 x) in 30 | 31 | let f34 = fun x -> (f35 x) in 32 | 33 | let f33 = fun x -> (f34 x) in 34 | 35 | let f32 = fun x -> (f33 x) in 36 | 37 | let f31 = fun x -> (f32 x) in 38 | 39 | let f30 = fun x -> (f31 x) in 40 | 41 | let f29 = fun x -> (f30 x) in 42 | 43 | let f28 = fun x -> (f29 x) in 44 | 45 | let f27 = fun x -> (f28 x) in 46 | 47 | let f26 = fun x -> (f27 x) in 48 | 49 | let f25 = fun x -> (f26 x) in 50 | 51 | let f24 = fun x -> (f25 x) in 52 | 53 | let f23 = fun x -> (f24 x) in 54 | 55 | let f22 = fun x -> (f23 x) in 56 | 57 | let f21 = fun x -> (f22 x) in 58 | 59 | let f20 = fun x -> (f21 x) in 60 | 61 | let f19 = fun x -> (f20 x) in 62 | 63 | let f18 = fun x -> (f19 x) in 64 | 65 | let f17 = fun x -> (f18 x) in 66 | 67 | let f16 = fun x -> (f17 x) in 68 | 69 | let f15 = fun x -> (f16 x) in 70 | 71 | let f14 = fun x -> (f15 x) in 72 | 73 | let f13 = fun x -> (f14 x) in 74 | 75 | let f12 = fun x -> (f13 x) in 76 | 77 | let f11 = fun x -> (f12 x) in 78 | 79 | let f10 = fun x -> (f11 x) in 80 | 81 | let f9 = fun x -> (f10 x) in 82 | 83 | let f8 = fun x -> (f9 x) in 84 | 85 | let f7 = fun x -> (f8 x) in 86 | 87 | let f6 = fun x -> (f7 x) in 88 | 89 | let f5 = fun x -> (f6 x) in 90 | 91 | let f4 = fun x -> (f5 x) in 92 | 93 | let f3 = fun x -> (f4 x) in 94 | 95 | let f2 = fun x -> (f3 x) in 96 | 97 | let f1 = fun x -> (f2 x) in 98 | 99 | (f1 3) 100 | -------------------------------------------------------------------------------- /src/01-language/skeleton.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module TyParam = TyParam.TyParam 3 | 4 | (** skeleton parameters *) 5 | module Param = Symbol.Make (Symbol.Parameter (struct 6 | let ascii_symbol = "skl" 7 | let utf8_symbol = "ς" 8 | end)) 9 | 10 | type t = 11 | | Param of Param.t 12 | | Basic of Const.ty 13 | | Arrow of t * t 14 | | Apply of { ty_name : TyName.t; skel_args : t TyParam.Map.t } 15 | | Handler of t * t 16 | | Tuple of t list 17 | 18 | let rec print ?max_level skel ppf = 19 | let print_at ?at_level = Print.print ?max_level ?at_level ppf in 20 | match skel with 21 | | Param s -> Param.print s ppf 22 | | Basic b -> print_at "%t" (Const.print_ty b) 23 | | Arrow (skel1, skel2) -> print_at "%t → %t" (print skel1) (print skel2) 24 | | Apply { ty_name; skel_args } -> ( 25 | match TyParam.Map.values skel_args with 26 | | [] -> print_at "%t" (TyName.print ty_name) 27 | | [ s ] -> 28 | print_at ~at_level:1 "%t %t" (print ~max_level:1 s) 29 | (TyName.print ty_name) 30 | | ts -> 31 | print_at ~at_level:1 "(%t) %t" 32 | (Print.sequence ", " print ts) 33 | (TyName.print ty_name)) 34 | | Tuple [] -> print_at "𝟙" 35 | | Tuple skels -> 36 | print_at ~at_level:2 "%t" (Print.sequence "×" (print ~max_level:1) skels) 37 | | Handler (skel1, skel2) -> print_at "%t ⇛ %t" (print skel1) (print skel2) 38 | 39 | let rec equal skel1 skel2 = 40 | match (skel1, skel2) with 41 | | Param s1, Param s2 -> s1 = s2 42 | | Arrow (ttya1, dirtya1), Arrow (ttyb1, dirtyb1) -> 43 | equal ttya1 ttyb1 && equal dirtya1 dirtyb1 44 | | Tuple tys1, Tuple tys2 -> 45 | List.length tys1 = List.length tys2 && List.for_all2 equal tys1 tys2 46 | | ( Apply { ty_name = ty_name1; skel_args = tys1 }, 47 | Apply { ty_name = ty_name2; skel_args = tys2 } ) -> 48 | ty_name1 = ty_name2 49 | && TyParam.Map.equal (fun t1 t2 -> equal t1 t2) tys1 tys2 50 | | Handler (dirtya1, dirtya2), Handler (dirtyb1, dirtyb2) -> 51 | equal dirtya1 dirtyb1 && equal dirtya2 dirtyb2 52 | | Basic ptya, Basic ptyb -> ptya = ptyb 53 | | _, _ -> false 54 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/loop.eff: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | 3 | let rec loop_pure n = 4 | if n = 0 then 5 | () 6 | else 7 | loop_pure (n - 1) 8 | 9 | let test_pure n = 10 | loop_pure n 11 | 12 | (******************************************************************************) 13 | 14 | 15 | effect Fail : unit -> empty 16 | 17 | let rec loop_latent n = 18 | if n = 0 then 19 | () 20 | else if n < 0 then 21 | ( match (perform (Fail ())) with) 22 | else 23 | loop_latent (n - 1) 24 | 25 | let test_latent n = 26 | loop_latent n 27 | 28 | (******************************************************************************) 29 | 30 | effect Incr : unit -> unit 31 | 32 | let rec loop_incr n = 33 | if n = 0 then 34 | () 35 | else 36 | (perform (Incr ()); loop_incr (n - 1)) 37 | 38 | let test_incr n = 39 | let incr_handler = handler 40 | | y -> (fun x -> x) 41 | | effect (Incr ()) k -> (fun x -> k () (x + 1)) 42 | in 43 | (with incr_handler handle loop_incr n) 0 44 | 45 | (******************************************************************************) 46 | 47 | let rec loop_incr' n = 48 | if n = 0 then 49 | () 50 | else 51 | (loop_incr' (n - 1); perform (Incr ())) 52 | 53 | let test_incr' n = 54 | let incr_handler = handler 55 | | y -> (fun x -> x) 56 | | effect (Incr ()) k -> (fun x -> k () (x + 1)) 57 | in 58 | (with incr_handler handle loop_incr' n) 0 59 | 60 | (******************************************************************************) 61 | 62 | effect Get: unit -> int 63 | effect Put: int -> unit 64 | 65 | let rec loop_state n = 66 | if n = 0 then 67 | () 68 | else 69 | (perform (Put ((perform (Get ())) + 1)); loop_state (n - 1)) 70 | 71 | let test_state n = 72 | let state_handler = handler 73 | | y -> (fun x -> x) 74 | | effect (Get ()) k -> (fun s -> k s s) 75 | | effect (Put s') k -> (fun _ -> k () s') 76 | in 77 | (with state_handler handle loop_state n) 0 78 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/timing.txt: -------------------------------------------------------------------------------- 1 | 490.099; 198 2 | 477.39500000000004; 198 3 | 470.46900000000005; 198 4 | 471.676; 198 5 | 471.266; 198 6 | 468.482; 198 7 | 469.48; 198 8 | 468.051; 198 9 | 469.949; 198 10 | 469.057; 198 11 | 469.109; 198 12 | 468.483; 198 13 | 470.64; 198 14 | 469.719; 198 15 | 469.17199999999997; 198 16 | 468.203; 198 17 | 470.345; 198 18 | 470.08299999999997; 198 19 | 468.422; 198 20 | 469.588; 198 21 | 472.588; 198 22 | 480.65799999999996; 198 23 | 469.255; 198 24 | 469.657; 198 25 | 469.10699999999997; 198 26 | 470.48699999999997; 198 27 | 478.63800000000003; 198 28 | 494.969; 198 29 | 503.12999999999994; 198 30 | 469.62100000000004; 198 31 | 468.085; 198 32 | 471.399; 198 33 | 467.837; 198 34 | 471.019; 198 35 | 469.18; 198 36 | 469.98400000000004; 198 37 | 471.715; 198 38 | 469.053; 198 39 | 469.692; 198 40 | 468.736; 198 41 | 468.54699999999997; 198 42 | 470.277; 198 43 | 470.188; 198 44 | 469.993; 198 45 | 468.707; 198 46 | 470.428; 198 47 | 469.349; 198 48 | 470.315; 198 49 | 468.747; 198 50 | 467.481; 198 51 | 467.218; 198 52 | 470.97; 198 53 | 467.279; 198 54 | 470.277; 198 55 | 469.529; 198 56 | 467.643; 198 57 | 467.223; 198 58 | 468.177; 198 59 | 467.399; 198 60 | 467.255; 198 61 | 469.271; 198 62 | 468.98699999999997; 198 63 | 466.67900000000003; 198 64 | 479.883; 198 65 | 470.47; 198 66 | 466.601; 198 67 | 470.169; 198 68 | 467.565; 198 69 | 467.581; 198 70 | 468.348; 198 71 | 468.39300000000003; 198 72 | 469.39300000000003; 198 73 | 468.971; 198 74 | 468.382; 198 75 | 467.23199999999997; 198 76 | 468.058; 198 77 | 466.95599999999996; 198 78 | 470.85900000000004; 198 79 | 468.18; 198 80 | 468.703; 198 81 | 468.277; 198 82 | 469.253; 198 83 | 466.86699999999996; 198 84 | 469.30100000000004; 198 85 | 476.267; 198 86 | 470.43600000000004; 198 87 | 469.676; 198 88 | 469.144; 198 89 | 469.442; 198 90 | 469.685; 198 91 | 470.101; 198 92 | 468.433; 198 93 | 470.009; 198 94 | 468.864; 198 95 | 468.92699999999996; 198 96 | 467.955; 198 97 | 469.27299999999997; 198 98 | 469.452; 198 99 | 468.022; 198 100 | 466.902; 198 101 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/100dummy_fun_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 490.099; 198 2 | 477.39500000000004; 198 3 | 470.46900000000005; 198 4 | 471.676; 198 5 | 471.266; 198 6 | 468.482; 198 7 | 469.48; 198 8 | 468.051; 198 9 | 469.949; 198 10 | 469.057; 198 11 | 469.109; 198 12 | 468.483; 198 13 | 470.64; 198 14 | 469.719; 198 15 | 469.17199999999997; 198 16 | 468.203; 198 17 | 470.345; 198 18 | 470.08299999999997; 198 19 | 468.422; 198 20 | 469.588; 198 21 | 472.588; 198 22 | 480.65799999999996; 198 23 | 469.255; 198 24 | 469.657; 198 25 | 469.10699999999997; 198 26 | 470.48699999999997; 198 27 | 478.63800000000003; 198 28 | 494.969; 198 29 | 503.12999999999994; 198 30 | 469.62100000000004; 198 31 | 468.085; 198 32 | 471.399; 198 33 | 467.837; 198 34 | 471.019; 198 35 | 469.18; 198 36 | 469.98400000000004; 198 37 | 471.715; 198 38 | 469.053; 198 39 | 469.692; 198 40 | 468.736; 198 41 | 468.54699999999997; 198 42 | 470.277; 198 43 | 470.188; 198 44 | 469.993; 198 45 | 468.707; 198 46 | 470.428; 198 47 | 469.349; 198 48 | 470.315; 198 49 | 468.747; 198 50 | 467.481; 198 51 | 467.218; 198 52 | 470.97; 198 53 | 467.279; 198 54 | 470.277; 198 55 | 469.529; 198 56 | 467.643; 198 57 | 467.223; 198 58 | 468.177; 198 59 | 467.399; 198 60 | 467.255; 198 61 | 469.271; 198 62 | 468.98699999999997; 198 63 | 466.67900000000003; 198 64 | 479.883; 198 65 | 470.47; 198 66 | 466.601; 198 67 | 470.169; 198 68 | 467.565; 198 69 | 467.581; 198 70 | 468.348; 198 71 | 468.39300000000003; 198 72 | 469.39300000000003; 198 73 | 468.971; 198 74 | 468.382; 198 75 | 467.23199999999997; 198 76 | 468.058; 198 77 | 466.95599999999996; 198 78 | 470.85900000000004; 198 79 | 468.18; 198 80 | 468.703; 198 81 | 468.277; 198 82 | 469.253; 198 83 | 466.86699999999996; 198 84 | 469.30100000000004; 198 85 | 476.267; 198 86 | 470.43600000000004; 198 87 | 469.676; 198 88 | 469.144; 198 89 | 469.442; 198 90 | 469.685; 198 91 | 470.101; 198 92 | 468.433; 198 93 | 470.009; 198 94 | 468.864; 198 95 | 468.92699999999996; 198 96 | 467.955; 198 97 | 469.27299999999997; 198 98 | 469.452; 198 99 | 468.022; 198 100 | 466.902; 198 101 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy20.eff: -------------------------------------------------------------------------------- 1 | effect Dummy : unit -> int;; 2 | 3 | let h19 = handler 4 | | effect (Dummy _) k -> 3 5 | | x -> x 6 | in 7 | 8 | let h18 = handler 9 | | effect (Dummy _) k -> with h19 handle 3 10 | | x -> x 11 | in 12 | 13 | let h17 = handler 14 | | effect (Dummy _) k -> with h18 handle 3 15 | | x -> x 16 | in 17 | 18 | let h16 = handler 19 | | effect (Dummy _) k -> with h17 handle 3 20 | | x -> x 21 | in 22 | 23 | let h15 = handler 24 | | effect (Dummy _) k -> with h16 handle 3 25 | | x -> x 26 | in 27 | 28 | let h14 = handler 29 | | effect (Dummy _) k -> with h15 handle 3 30 | | x -> x 31 | in 32 | 33 | let h13 = handler 34 | | effect (Dummy _) k -> with h14 handle 3 35 | | x -> x 36 | in 37 | 38 | let h12 = handler 39 | | effect (Dummy _) k -> with h13 handle 3 40 | | x -> x 41 | in 42 | 43 | let h11 = handler 44 | | effect (Dummy _) k -> with h12 handle 3 45 | | x -> x 46 | in 47 | 48 | let h10 = handler 49 | | effect (Dummy _) k -> with h11 handle 3 50 | | x -> x 51 | in 52 | 53 | let h9 = handler 54 | | effect (Dummy _) k -> with h10 handle 3 55 | | x -> x 56 | in 57 | 58 | let h8 = handler 59 | | effect (Dummy _) k -> with h9 handle 3 60 | | x -> x 61 | in 62 | 63 | let h7 = handler 64 | | effect (Dummy _) k -> with h8 handle 3 65 | | x -> x 66 | in 67 | 68 | let h6 = handler 69 | | effect (Dummy _) k -> with h7 handle 3 70 | | x -> x 71 | in 72 | 73 | let h5 = handler 74 | | effect (Dummy _) k -> with h6 handle 3 75 | | x -> x 76 | in 77 | 78 | let h4 = handler 79 | | effect (Dummy _) k -> with h5 handle 3 80 | | x -> x 81 | in 82 | 83 | let h3 = handler 84 | | effect (Dummy _) k -> with h4 handle 3 85 | | x -> x 86 | in 87 | 88 | let h2 = handler 89 | | effect (Dummy _) k -> with h3 handle 3 90 | | x -> x 91 | in 92 | 93 | let h1 = handler 94 | | effect (Dummy _) k -> with h2 handle 3 95 | | x -> x 96 | 97 | in (with h1 handle (perform (Dummy ()))) 98 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/100dummy_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 1694.857; 299 2 | 1684.203; 299 3 | 1676.308; 299 4 | 1654.146; 299 5 | 1647.3739999999998; 299 6 | 1645.435; 299 7 | 1653.1480000000001; 299 8 | 1665.651; 299 9 | 1650.0030000000002; 299 10 | 1643.861; 299 11 | 1648.336; 299 12 | 1649.149; 299 13 | 1652.394; 299 14 | 1654.536; 299 15 | 1660.3429999999998; 299 16 | 1652.318; 299 17 | 1647.3210000000001; 299 18 | 1645.972; 299 19 | 1664.757; 299 20 | 1686.94; 299 21 | 1673.484; 299 22 | 1650.399; 299 23 | 1645.642; 299 24 | 1652.648; 299 25 | 1660.337; 299 26 | 1676.262; 299 27 | 1668.5; 299 28 | 1776.9219999999998; 299 29 | 1723.135; 299 30 | 1694.4850000000001; 299 31 | 1704.951; 299 32 | 1755.42; 299 33 | 1711.512; 299 34 | 1725.873; 299 35 | 1740.562; 299 36 | 1706.828; 299 37 | 1706.171; 299 38 | 1743.654; 299 39 | 1745.646; 299 40 | 1787.357; 299 41 | 1703.009; 299 42 | 1671.391; 299 43 | 1658.2440000000001; 299 44 | 1663.012; 299 45 | 1754.57; 299 46 | 1755.438; 299 47 | 1739.253; 299 48 | 1697.5439999999999; 299 49 | 1708.1; 299 50 | 1675.847; 299 51 | 1681.003; 299 52 | 1668.607; 299 53 | 1672.415; 299 54 | 1650.8890000000001; 299 55 | 1769.081; 299 56 | 1720.342; 299 57 | 1716.0539999999999; 299 58 | 1705.7199999999998; 299 59 | 1735.9089999999999; 299 60 | 1705.7359999999999; 299 61 | 1674.209; 299 62 | 1731.7530000000002; 299 63 | 1713.2320000000002; 299 64 | 1694.952; 299 65 | 1804.111; 299 66 | 1801.2440000000001; 299 67 | 1838.927; 299 68 | 1809.333; 299 69 | 1820.684; 299 70 | 1821.143; 299 71 | 1756.5610000000001; 299 72 | 1763.208; 299 73 | 1890.7369999999999; 299 74 | 1826.503; 299 75 | 1727.58; 299 76 | 1753.126; 299 77 | 1713.905; 299 78 | 1727.647; 299 79 | 1760.644; 299 80 | 1680.3; 299 81 | 1658.799; 299 82 | 1672.0459999999998; 299 83 | 1666.93; 299 84 | 1674.2459999999999; 299 85 | 1681.133; 299 86 | 1665.293; 299 87 | 1666.0140000000001; 299 88 | 1668.3609999999999; 299 89 | 1698.739; 299 90 | 1665.595; 299 91 | 1661.866; 299 92 | 1658.394; 299 93 | 1669.5629999999999; 299 94 | 1704.3870000000002; 299 95 | 1711.33; 299 96 | 1702.624; 299 97 | 1711.32; 299 98 | 1687.8999999999999; 299 99 | 1668.095; 299 100 | 1691.275; 299 101 | -------------------------------------------------------------------------------- /src/00-utils/assoc.ml: -------------------------------------------------------------------------------- 1 | type ('key, 'value) t = ('key * 'value) list 2 | (** Association lists *) 3 | 4 | let empty = [] 5 | let is_empty = function [] -> true | _ :: _ -> false 6 | 7 | (* Finding elements. *) 8 | let rec lookup x = function 9 | | [] -> None 10 | | (k, v) :: tl -> if x = k then Some v else lookup x tl 11 | 12 | let pop = function [] -> None | hd :: tl -> Some (hd, tl) 13 | 14 | (* Changing the list. *) 15 | let update k v assoc = (k, v) :: assoc 16 | 17 | let rec replace k v = function 18 | | [] -> [] 19 | | (k', v') :: tl -> 20 | if k = k' then (k, v) :: tl else (k', v') :: replace k v tl 21 | 22 | let rec remove x = function 23 | | [] -> [] 24 | | (k, v) :: tl -> if x = k then tl else (k, v) :: remove x tl 25 | 26 | (* Iters, maps, folds. *) 27 | let iter = List.iter 28 | 29 | let rec map f = function 30 | | [] -> [] 31 | | (k, v) :: tl -> 32 | let v' = f v in 33 | let tl' = map f tl in 34 | (k, v') :: tl' 35 | 36 | let rec kmap f = function 37 | | [] -> [] 38 | | hd :: tl -> 39 | let hd' = f hd in 40 | let tl' = kmap f tl in 41 | hd' :: tl' 42 | 43 | let rec map_of_list f = function 44 | | [] -> [] 45 | | x :: tl -> 46 | let k, v = f x in 47 | let tl' = map_of_list f tl in 48 | (k, v) :: tl' 49 | 50 | let fold_left = List.fold 51 | let fold_right = List.fold_right 52 | 53 | let fold_map f st assoc = 54 | let aux (st, reversed_assoc) (k, v) = 55 | let st', v' = f st v in 56 | (st', (k, v') :: reversed_assoc) 57 | in 58 | let st', reversed_assoc = fold_left aux (st, []) assoc in 59 | (st', List.rev reversed_assoc) 60 | 61 | let kfold_map f st xs = 62 | let aux (st, reversed_ys) x = 63 | let st', y = f st x in 64 | (st', y :: reversed_ys) 65 | in 66 | let st', reversed_ys = fold_left aux (st, []) xs in 67 | (st', List.rev reversed_ys) 68 | 69 | (* Other useful stuff. *) 70 | let length assoc = List.length assoc 71 | let rec values_of = function [] -> [] | (_k, v) :: tl -> v :: values_of tl 72 | let rec keys_of = function [] -> [] | (k, _v) :: tl -> k :: keys_of tl 73 | let rev = List.rev 74 | let concat assoc1 assoc2 = assoc1 @ assoc2 75 | 76 | (* Type casting *) 77 | let of_list lst = lst 78 | let to_list assoc = assoc 79 | -------------------------------------------------------------------------------- /tests/valid/choice.eff: -------------------------------------------------------------------------------- 1 | effect Decide: unit -> bool;; 2 | effect Decide2 : unit -> bool;; 3 | 4 | handle 5 | let x = (if (perform (Decide ())) then 10 else 20) in 6 | let y = (if (perform (Decide ())) then 0 else 5) in 7 | x - y 8 | with 9 | | effect (Decide ()) k -> k true;; 10 | 11 | let choose_all = handler 12 | | effect (Decide ()) k -> k true @ k false 13 | | x -> [x];; 14 | 15 | with choose_all handle 16 | let x = (if perform (Decide ()) then 10 else 20) in 17 | let y = (if perform (Decide ()) then 0 else 5) in 18 | x - y;; 19 | 20 | let choose_all2 = handler 21 | | effect (Decide2 ()) k -> k true @ k false 22 | | x -> [x];; 23 | 24 | with choose_all handle 25 | with choose_all2 handle 26 | let x = (if perform (Decide ()) then 10 else 20) in 27 | let y = (if perform (Decide2 ()) then 0 else 5) in 28 | x - y;; 29 | 30 | with choose_all2 handle 31 | with choose_all handle 32 | let y = (if perform (Decide2 ()) then 0 else 5) in 33 | let x = (if perform (Decide ()) then 10 else 20) in 34 | x - y;; 35 | 36 | with choose_all2 handle 37 | with choose_all handle 38 | let x = (if perform (Decide ()) then 10 else 20) in 39 | let y = (if perform (Decide2 ()) then 0 else 5) in 40 | x - y;; 41 | 42 | 43 | effect Fail : unit -> empty;; 44 | 45 | let rec choose_int m n = 46 | if m > n then 47 | absurd (perform (Fail ())) 48 | else if perform (Decide ()) then 49 | m 50 | else 51 | choose_int (m + 1) n 52 | 53 | let sqrt n = 54 | let rec find_root m = 55 | if m ** 2 > n then 56 | None 57 | else if m ** 2 = n then 58 | Some m 59 | else 60 | find_root (m + 1) 61 | in 62 | find_root 0 63 | 64 | let pythagorean m n = 65 | let a = choose_int m (n - 1) in 66 | let b = choose_int a n in 67 | let a2b2 = a ** 2 + b ** 2 in 68 | match sqrt (a ** 2 + b ** 2) with 69 | | Some c -> (a, b, c) 70 | | None -> absurd (perform (Fail ())) 71 | 72 | let backtrack = handler 73 | | effect (Decide ()) k -> 74 | handle k false with 75 | | effect (Fail ()) _ -> k true 76 | 77 | let choose_all = 78 | handler 79 | | x -> [x] 80 | | effect (Decide ()) k -> (k true) @ (k false) 81 | | effect (Fail _) _ -> [] 82 | 83 | ;; 84 | 85 | with choose_all handle 86 | pythagorean 4 15 87 | -------------------------------------------------------------------------------- /examples/modulus.eff: -------------------------------------------------------------------------------- 1 | (* In this example we pretend that int is the type of natural numbers. *) 2 | 3 | type nat = int 4 | 5 | (* A modulus-of-continuity functional is a function mu which accepts a 6 | functional f : (nat -> nat) -> nat and a sequence a : nat -> nat 7 | and returns a number m such that the value (f a) depends on at most 8 | the first m terms of a. In other words, if a and b agree up to the 9 | m-th term, then f a = f b. *) 10 | 11 | (* We can implement modulus of continuity as usual with a reference. *) 12 | 13 | effect Get : int 14 | effect Set : int -> unit 15 | 16 | let state initial = handler 17 | | effect Get k -> (fun m -> k m m) 18 | | effect (Set n) k -> (fun m -> k () n) 19 | | x -> (fun _ -> x) 20 | | finally g -> g initial 21 | ;; 22 | 23 | let unhandled_ref_mu f a = 24 | perform (Set 0); 25 | (* The sequence "b" behaves the same as "a", except that it first 26 | saves the largest i for which a lookup was made. *) 27 | let b i = 28 | let current = perform Get in 29 | let new_i = max current i in 30 | perform (Set new_i); 31 | a i 32 | in 33 | ignore (f b); perform Get 34 | ;; 35 | 36 | (* Handle it with the state handler. *) 37 | let ref_mu f a = 38 | with state 0 handle 39 | unhandled_ref_mu f a 40 | ;; 41 | 42 | (* We can also modify the sequence itself, by wrapping it in a handler. 43 | We transform the sequence "a" into a sequence of operations "Call", 44 | where the transformed sequence also modifies the state. *) 45 | 46 | effect Call : int -> nat 47 | 48 | let sequence_transformer sequence = handler 49 | (* (Call i) is the same as sequence i with state adjusting. *) 50 | | effect (Call n) k -> 51 | (fun i -> 52 | let j = max i n in 53 | (* Here j represents the largest seen lookup index. *) 54 | k (sequence n) j) 55 | | x -> (fun n -> n) (* We want the final state, not the result. *) 56 | | finally g -> g 0 57 | ;; 58 | 59 | let mu f a = 60 | with sequence_transformer a handle 61 | f (fun x -> perform (Call x)) 62 | ;; 63 | 64 | (* A couple of examples. *) 65 | let f a = 0 * a 10;; 66 | let g a = a (a 5);; 67 | 68 | ref_mu f (fun i -> 30 + i * i);; 69 | mu f (fun i -> 30 + i * i);; 70 | ref_mu g (fun i -> 30 + i * i);; 71 | mu g (fun i -> 30 + i * i);; 72 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/generate_benchmark_rules.ml: -------------------------------------------------------------------------------- 1 | let names = 2 | [ "loop"; "queens"; "interp"; "range"; "tree"; "capability_benchmarks" ] 3 | 4 | let invalid = [] (* ("loop", "NoOptImpure") ] *) 5 | let default_args = "--no-stdlib --compile-plain-ocaml" 6 | let modes = [ ("", "Opt") ] 7 | 8 | let benchmark_case_stanza in_filename args out_filename = 9 | Printf.printf "(rule\n"; 10 | Printf.printf " (deps\n"; 11 | Printf.printf " %%{bin:eff}\n"; 12 | Printf.printf " (source_tree .))\n"; 13 | Printf.printf " (target \"%s.out\")\n" out_filename; 14 | Printf.printf " (action\n"; 15 | Printf.printf " (with-outputs-to \"%%{target}\"\n"; 16 | Printf.printf " (with-accepted-exit-codes\n"; 17 | (* Just for now, ignore exit codes *) 18 | Printf.printf " (or 0 1 2)\n"; 19 | Printf.printf " (run eff %s %s \"./%s\")))))\n\n" default_args args 20 | in_filename 21 | 22 | let format_stanza out_filename = 23 | Printf.printf "(rule\n"; 24 | Printf.printf " (deps \"%s.out\")\n" out_filename; 25 | Printf.printf " (target \"%s.formatted\")\n" out_filename; 26 | Printf.printf " (action\n"; 27 | Printf.printf " (with-outputs-to \"%s.formatted\"\n" out_filename; 28 | Printf.printf " (with-accepted-exit-codes (or 0 1 2)\n"; 29 | Printf.printf " (run ocamlformat %s.out)))))\n\n" out_filename 30 | 31 | let benchmark_case_alias_stanza out_filename out_filename_full = 32 | Printf.printf "(rule\n"; 33 | Printf.printf " (deps %s.formatted)\n" out_filename; 34 | Printf.printf " (alias generate_benchmarks)\n"; 35 | Printf.printf " (action\n"; 36 | Printf.printf " (diff \"%s.ml\" \"%s.formatted\")))\n\n" out_filename_full 37 | out_filename 38 | 39 | let main () = 40 | List.iter 41 | (fun in_file_name -> 42 | List.iter 43 | (fun (args, name) -> 44 | if not (List.mem (in_file_name, name) invalid) then ( 45 | let out_filename = in_file_name ^ name in 46 | let target_filename = in_file_name ^ name in 47 | benchmark_case_stanza (in_file_name ^ ".eff") args target_filename; 48 | 49 | format_stanza target_filename; 50 | benchmark_case_alias_stanza target_filename out_filename)) 51 | modes) 52 | names 53 | 54 | let () = main () 55 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/queensMulticoreTranslated.ml: -------------------------------------------------------------------------------- 1 | (* Taken varbatim from 2 | https://github.com/ocaml-multicore/effects-examples/blob/68f16120873f1ade4536ab3916ccce47fd424f9e/queens.ml 3 | *) 4 | 5 | let absurd x = failwith "error" 6 | 7 | effect Decide : unit -> bool 8 | effect Fail : unit -> unit 9 | 10 | 11 | let no_attack (x,y) (x', y') = 12 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 13 | 14 | let rec not_attacked x' qs = 15 | match qs with 16 | | [] -> true 17 | | x:: xs -> 18 | if no_attack x' x then not_attacked x' xs else false 19 | 20 | let available number_of_queens x qs = 21 | let rec loop (possible, y) = 22 | if y < 1 then possible 23 | else if not_attacked ((x, y)) qs then 24 | loop ( (y:: possible), y - 1) 25 | else loop (possible, y - 1) 26 | in 27 | loop ([], number_of_queens) 28 | 29 | let rec choose xs = 30 | match xs with 31 | | [] -> (absurd (perform (Fail ()))) 32 | | (x:: xs') -> if perform (Decide ()) then x else choose xs' 33 | 34 | let queens number_of_queens = 35 | let rec place (x, qs) = 36 | if x > number_of_queens then qs 37 | else 38 | let y = choose (available number_of_queens x qs) in 39 | place (x + 1, ((x, y):: qs)) 40 | in 41 | place (1, []) 42 | 43 | let queens_one_option number_of_queens = 44 | match queens number_of_queens 45 | with 46 | | effect (Decide _) k -> ( 47 | let k' = Obj.clone_continuation k in 48 | match (continue k true) with 49 | | Some x -> Some x 50 | | None -> (continue k' false) 51 | ) 52 | | effect (Fail _) _k -> None 53 | | y -> (Some y) 54 | 55 | let queens_all number_of_queens = 56 | match queens number_of_queens 57 | with 58 | | effect (Decide _) k -> 59 | let k' = Obj.clone_continuation k in 60 | (continue k true) @ (continue k' false) 61 | | effect (Fail _) _k -> [] 62 | | x -> [x] 63 | 64 | let queens_one_cps number_of_queens = 65 | (match queens number_of_queens with 66 | | effect (Decide _) k -> 67 | let k' = Obj.clone_continuation k in 68 | (fun kf -> (continue k true (fun _ -> (continue k' false kf)) )) 69 | | effect (Fail _) _k -> (fun kf -> kf ()) 70 | | y -> (fun _ -> y)) 71 | (fun () -> (absurd (perform (Fail ())))) 72 | 73 | -------------------------------------------------------------------------------- /misc/old-benchmarks-for-other-systems/multicoreQueens.ml: -------------------------------------------------------------------------------- 1 | type empty;; 2 | 3 | let absurd void = match void with | _ -> assert false;; 4 | 5 | let no_attack (x, y) (x', y') = 6 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 7 | 8 | let rec not_attacked x' = function 9 | | [] -> true 10 | | x :: xs -> if no_attack x' x then not_attacked x' xs else false 11 | 12 | let available (number_of_queens, x, qs) = 13 | let rec loop (possible, y) = 14 | if y < 1 then 15 | possible 16 | else if not_attacked (x, y) qs then 17 | loop ((y :: possible), (y - 1)) 18 | else 19 | loop (possible, (y - 1)) 20 | in 21 | loop ([], number_of_queens) 22 | 23 | (******************************************************************************) 24 | 25 | effect Decide : unit -> bool 26 | effect Fail : unit -> empty 27 | 28 | type 'a option = None | Some of 'a 29 | 30 | let rec choose = function 31 | | [] -> absurd (perform @@ Fail ()) 32 | | x::xs -> if (perform @@ Decide ()) then x else choose xs 33 | 34 | (******************************************************************************) 35 | 36 | let queens number_of_queens = 37 | let rec place (x, qs) = 38 | if x > number_of_queens then qs else 39 | let y = choose (available (number_of_queens, x, qs)) in 40 | place ((x + 1), ((x, y) :: qs)) 41 | in 42 | place (1, []) 43 | 44 | let queens_one_option number_of_queens = 45 | match (queens number_of_queens) 46 | with 47 | | effect (Decide _) k -> (match continue (Obj.clone_continuation k) true with Some x -> Some x | None -> continue (Obj.clone_continuation k) false) 48 | | effect (Fail _) k -> None 49 | | x -> (Some x) 50 | 51 | let queens_one_cps number_of_queens = 52 | ( 53 | match (queens number_of_queens) 54 | with 55 | | effect (Decide _) k -> (fun kf -> continue (Obj.clone_continuation k) true (fun () -> continue (Obj.clone_continuation k) false kf) ) 56 | | effect (Fail _) k -> (fun kf -> kf ()) 57 | | x -> (fun _ -> x) 58 | ) 59 | (fun () -> (absurd (perform @@ Fail ()))) 60 | 61 | let queens_all number_of_queens = 62 | match (queens number_of_queens) 63 | with 64 | | effect (Decide _) k -> continue (Obj.clone_continuation k) true @ continue (Obj.clone_continuation k) false 65 | | effect (Fail _) k -> [] 66 | | x -> [x] 67 | -------------------------------------------------------------------------------- /docs/try/examples/probability.eff: -------------------------------------------------------------------------------- 1 | (** Probability *) 2 | 3 | (* As seen in non-determinism examples, effects can be used to simulate choice. 4 | In order to use randomness we also need to use effects, for instance 5 | RandomInt and RandomFloat. We can also use handlers to compute some 6 | properties, for instance the expected value of a discrete random variable. *) 7 | 8 | (* We define an operation Toss to use as a random coin toss. *) 9 | effect Toss : float -> bool 10 | 11 | (* Using the operation Toss we can define other distributions as well. *) 12 | let rec uniform = function 13 | | [x] -> x 14 | | x :: xs -> 15 | let n = length xs + 1 in 16 | let p = 1.0 /. float_of_int n in 17 | if perform (Toss p) then x else uniform xs 18 | ;; 19 | 20 | let random_value = handler 21 | | v -> v 22 | | effect (Toss p) k -> 23 | let toss = perform (RandomFloat 1.) < p in 24 | continue k toss 25 | ;; 26 | 27 | let expectation = handler 28 | | v -> v 29 | | effect (Toss p) k -> 30 | p *. (continue k true) +. (1.0 -. p) *. (continue k false) 31 | ;; 32 | 33 | with expectation handle 34 | let x = uniform [1.; 2.; 3.; 4.; 5.; 6.] in 35 | let y = uniform [1.; 2.; 3.; 4.; 5.; 6.] in 36 | x +. y 37 | ;; 38 | 39 | (* We can also compute the distribution of outcomes for a probabilisitic 40 | computation. *) 41 | 42 | (* We first write a function that combines two outcome distributions where 43 | the first outcome distribution is chosen with the probability p and the second 44 | with probability 1-p. *) 45 | 46 | let combine p dist1 dist2 = 47 | let scale p dist = map (fun (x, q) -> (x, p *. q)) dist in 48 | let rec add (x, p) = function 49 | | [] -> [(x, p)] 50 | | (y, q) :: dist -> 51 | if x = y then (x, p +. q) :: dist else (y, q) :: add (x, p) dist 52 | in 53 | let dist1 = scale p dist1 in 54 | let dist2 = scale (1.0 -. p) dist2 in 55 | fold_right add dist1 dist2 56 | ;; 57 | 58 | let distribution = handler 59 | (* Distribution of only one value. *) 60 | | v -> [(v, 1.0)] 61 | (* Combine possible distributions. *) 62 | | effect (Toss p) k -> combine p (continue k true) (continue k false) 63 | ;; 64 | 65 | with distribution handle 66 | let x = uniform [1; 2; 3; 4; 5; 6] in 67 | let y = uniform [1; 2; 3; 4; 5; 6] in 68 | x + y 69 | ;; 70 | -------------------------------------------------------------------------------- /src/05-backends/multicore-ocaml/primitives.ml: -------------------------------------------------------------------------------- 1 | module Primitives = Language.Primitives 2 | 3 | let primitive_source = function 4 | | Primitives.CompareEq -> "( = )" 5 | | Primitives.CompareGe -> "( >= )" 6 | | Primitives.CompareGt -> "( > )" 7 | | Primitives.CompareLe -> "( <= )" 8 | | Primitives.CompareLt -> "( < )" 9 | | Primitives.CompareNe -> "( <> )" 10 | | Primitives.FloatAcos -> "acos" 11 | | Primitives.FloatAdd -> "( +. )" 12 | | Primitives.FloatAsin -> "asin" 13 | | Primitives.FloatAtan -> "atan" 14 | | Primitives.FloatCos -> "cos" 15 | | Primitives.FloatDiv -> "( /. )" 16 | | Primitives.FloatExp -> "exp" 17 | | Primitives.FloatExpm1 -> "expm1" 18 | | Primitives.FloatInfinity -> "infinity" 19 | | Primitives.FloatLog -> "log" 20 | | Primitives.FloatLog1p -> "log1p" 21 | | Primitives.FloatMul -> "( *. )" 22 | | Primitives.FloatNaN -> "nan" 23 | | Primitives.FloatNeg -> "( ~-. )" 24 | | Primitives.FloatNegInfinity -> "neg_infinity" 25 | | Primitives.FloatOfInt -> "float_of_int" 26 | | Primitives.FloatSin -> "sin" 27 | | Primitives.FloatSqrt -> "sqrt" 28 | | Primitives.FloatSub -> "( -. )" 29 | | Primitives.FloatTan -> "tan" 30 | | Primitives.IntegerAdd -> "( + )" 31 | | Primitives.IntegerDiv -> "( / )" 32 | | Primitives.IntegerMod -> "( mod )" 33 | | Primitives.IntegerMul -> "( * )" 34 | | Primitives.IntegerNeg -> "( ~- )" 35 | | Primitives.IntegerAbs -> "abs" 36 | | Primitives.IntegerPow -> "( ** )" 37 | | Primitives.IntegerSub -> "( - )" 38 | | Primitives.IntOfFloat -> "int_of_float" 39 | | Primitives.StringConcat -> "( ^ )" 40 | | Primitives.StringLength -> "String.length" 41 | | Primitives.StringOfFloat -> "string_of_float" 42 | | Primitives.StringOfInt -> "string_of_int" 43 | | Primitives.StringSub -> "String.sub" 44 | | Primitives.ToString -> "fun _ -> \"\"" 45 | 46 | let top_level_handler_source = function 47 | | Primitives.Print -> ("s", "k", "print_string s; continue k ()") 48 | | Primitives.RandomInt -> ("i", "k", "continue k (Random.int i)") 49 | | Primitives.RandomFloat -> ("f", "k", "continue k (Random.float f)") 50 | | Primitives.Read -> ("()", "k", "continue k (read_line ())") 51 | | Primitives.Raise -> ("_", "_", "failwith \"Not supported\"") 52 | | Primitives.Write -> ("_", "_", "failwith \"Not supported\"") 53 | -------------------------------------------------------------------------------- /docs/try/examples/threads.eff: -------------------------------------------------------------------------------- 1 | (** Multi-threading *) 2 | 3 | effect Yield : unit 4 | effect Spawn : (unit -> unit) -> unit 5 | 6 | (* We will need a queue to keep track of inactive threads. *) 7 | 8 | effect Get_next : (unit -> unit) option 9 | effect Add_to_queue : (unit -> unit) -> unit 10 | 11 | let queue initial = handler 12 | | effect Get_next k -> 13 | ( fun queue -> match queue with 14 | | [] -> (continue k None) [] 15 | | hd::tl -> (continue k (Some hd)) tl ) 16 | | effect (Add_to_queue y) k -> ( fun queue -> (continue k ()) (queue @ [y])) 17 | | x -> ( fun _ -> x) 18 | | finally x -> x initial 19 | ;; 20 | 21 | let round_robin = 22 | let enqueue t = 23 | perform (Add_to_queue t) 24 | in 25 | let dequeue () = 26 | match perform Get_next with 27 | | None -> () 28 | | Some t -> t () 29 | in 30 | let rec rr_handler () = handler (*Needs to be defined recursively.*) 31 | | effect Yield k -> enqueue k; dequeue () 32 | | effect (Spawn t) k -> enqueue k; with rr_handler () handle t () 33 | | () -> dequeue () 34 | in 35 | rr_handler () 36 | ;; 37 | 38 | (* Because the round_robin handler uses our queue, we must nest the handlers. *) 39 | 40 | with queue [] handle 41 | with round_robin handle 42 | perform (Spawn (fun _ -> 43 | iter (fun x -> perform (Print x); perform Yield) ["a"; "b"; "c"; "d"; "e"] 44 | )); 45 | perform (Spawn (fun _ -> 46 | iter (fun x -> perform (Print x); perform Yield) ["A"; "B"; "C"; "D"; "E"] 47 | )) 48 | ;; 49 | 50 | (* We can run an unbounded amount of threads. The following example enumerates all 51 | reduced positive fractions less than 1 by spawning a thread for each denominator 52 | between d and e. *) 53 | 54 | let rec fractions d e = 55 | let rec find_fractions n = 56 | (* If the fraction is reduced, print it and yield *) 57 | if gcd n d = 1 then 58 | perform (Print (to_string n ^ "/" ^ to_string d ^ ", ")); perform Yield 59 | else (); 60 | if d > n then 61 | find_fractions (n+1) 62 | else () 63 | in 64 | (* Spawn a thread for the next denominator *) 65 | (if d < e then 66 | perform (Spawn (fun _ -> perform Yield; fractions (d + 1) e)) else ()) ; 67 | (* List all the fractions with the current denominator *) 68 | find_fractions 1 69 | ;; 70 | 71 | with queue [] handle 72 | with round_robin handle 73 | fractions 1 10 74 | ;; 75 | -------------------------------------------------------------------------------- /examples/threads.eff: -------------------------------------------------------------------------------- 1 | (* This example is described in Section 6.10 of "Programming with Algebraic Effects and 2 | Handlers" by A. Bauer and M. Pretnar. *) 3 | 4 | 5 | effect Yield : unit 6 | effect Spawn : (unit -> unit) -> unit 7 | 8 | (* We will need a queue to keep track of inactive threads. *) 9 | 10 | effect Get_next : (unit -> unit) option 11 | effect Add_to_queue : (unit -> unit) -> unit 12 | 13 | let queue initial = handler 14 | | effect Get_next k -> 15 | ( fun queue -> match queue with 16 | | [] -> (k None) [] 17 | | hd::tl -> (k (Some hd)) tl ) 18 | | effect (Add_to_queue y) k -> ( fun queue -> (k ()) (queue @ [y])) 19 | | x -> ( fun _ -> x) 20 | | finally x -> x initial 21 | ;; 22 | 23 | let round_robin = 24 | let enqueue t = 25 | perform (Add_to_queue t) 26 | in 27 | let dequeue () = 28 | match perform Get_next with 29 | | None -> () 30 | | Some t -> t () 31 | in 32 | let rec rr_handler () = handler (*Needs to be defined recursively.*) 33 | | effect Yield k -> enqueue k; dequeue () 34 | | effect (Spawn t) k -> enqueue k; with rr_handler () handle t () 35 | | () -> dequeue () 36 | in 37 | rr_handler () 38 | ;; 39 | 40 | (* An example of nested multithreading. We have a thread which prints 41 | the letter a and another one which has two sub-threads printing x and y. *) 42 | 43 | with queue [] handle 44 | with round_robin handle 45 | perform (Spawn (fun _ -> 46 | iter (fun x -> perform (Print x); perform Yield) ["a"; "b"; "c"; "d"; "e"] 47 | )); 48 | perform (Spawn (fun _ -> 49 | iter (fun x -> perform (Print x); perform Yield) ["A"; "B"; "C"; "D"; "E"] 50 | )) 51 | ;; 52 | 53 | 54 | (* We can run an unbounded amount of threads. The following example enumerates all 55 | reduced positive fractions less than 1 by spawning a thread for each denominator 56 | between d and e. *) 57 | 58 | let rec fractions d e = 59 | let rec find_fractions n = 60 | (* If the fraction is reduced, print it and yield *) 61 | if gcd n d = 1 then 62 | perform (Print (string_of_int n ^ "/" ^ string_of_int d ^ ", ")); perform Yield 63 | else (); 64 | if d > n then 65 | find_fractions (n+1) 66 | else () 67 | in 68 | (* Spawn a thread for the next denominator *) 69 | (if d < e then 70 | perform (Spawn (fun _ -> perform Yield; fractions (d + 1) e)) else ()) ; 71 | (* List all the fractions with the current denominator *) 72 | find_fractions 1 73 | ;; 74 | 75 | with queue [] handle 76 | with round_robin handle 77 | fractions 1 10 78 | ;; 79 | -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/code/dummy_fun60.eff: -------------------------------------------------------------------------------- 1 | let f59 = fun x -> x in 2 | 3 | let f58 = fun x -> (f59 x) in 4 | 5 | let f57 = fun x -> (f58 x) in 6 | 7 | let f56 = fun x -> (f57 x) in 8 | 9 | let f55 = fun x -> (f56 x) in 10 | 11 | let f54 = fun x -> (f55 x) in 12 | 13 | let f53 = fun x -> (f54 x) in 14 | 15 | let f52 = fun x -> (f53 x) in 16 | 17 | let f51 = fun x -> (f52 x) in 18 | 19 | let f50 = fun x -> (f51 x) in 20 | 21 | let f49 = fun x -> (f50 x) in 22 | 23 | let f48 = fun x -> (f49 x) in 24 | 25 | let f47 = fun x -> (f48 x) in 26 | 27 | let f46 = fun x -> (f47 x) in 28 | 29 | let f45 = fun x -> (f46 x) in 30 | 31 | let f44 = fun x -> (f45 x) in 32 | 33 | let f43 = fun x -> (f44 x) in 34 | 35 | let f42 = fun x -> (f43 x) in 36 | 37 | let f41 = fun x -> (f42 x) in 38 | 39 | let f40 = fun x -> (f41 x) in 40 | 41 | let f39 = fun x -> (f40 x) in 42 | 43 | let f38 = fun x -> (f39 x) in 44 | 45 | let f37 = fun x -> (f38 x) in 46 | 47 | let f36 = fun x -> (f37 x) in 48 | 49 | let f35 = fun x -> (f36 x) in 50 | 51 | let f34 = fun x -> (f35 x) in 52 | 53 | let f33 = fun x -> (f34 x) in 54 | 55 | let f32 = fun x -> (f33 x) in 56 | 57 | let f31 = fun x -> (f32 x) in 58 | 59 | let f30 = fun x -> (f31 x) in 60 | 61 | let f29 = fun x -> (f30 x) in 62 | 63 | let f28 = fun x -> (f29 x) in 64 | 65 | let f27 = fun x -> (f28 x) in 66 | 67 | let f26 = fun x -> (f27 x) in 68 | 69 | let f25 = fun x -> (f26 x) in 70 | 71 | let f24 = fun x -> (f25 x) in 72 | 73 | let f23 = fun x -> (f24 x) in 74 | 75 | let f22 = fun x -> (f23 x) in 76 | 77 | let f21 = fun x -> (f22 x) in 78 | 79 | let f20 = fun x -> (f21 x) in 80 | 81 | let f19 = fun x -> (f20 x) in 82 | 83 | let f18 = fun x -> (f19 x) in 84 | 85 | let f17 = fun x -> (f18 x) in 86 | 87 | let f16 = fun x -> (f17 x) in 88 | 89 | let f15 = fun x -> (f16 x) in 90 | 91 | let f14 = fun x -> (f15 x) in 92 | 93 | let f13 = fun x -> (f14 x) in 94 | 95 | let f12 = fun x -> (f13 x) in 96 | 97 | let f11 = fun x -> (f12 x) in 98 | 99 | let f10 = fun x -> (f11 x) in 100 | 101 | let f9 = fun x -> (f10 x) in 102 | 103 | let f8 = fun x -> (f9 x) in 104 | 105 | let f7 = fun x -> (f8 x) in 106 | 107 | let f6 = fun x -> (f7 x) in 108 | 109 | let f5 = fun x -> (f6 x) in 110 | 111 | let f4 = fun x -> (f5 x) in 112 | 113 | let f3 = fun x -> (f4 x) in 114 | 115 | let f2 = fun x -> (f3 x) in 116 | 117 | let f1 = fun x -> (f2 x) in 118 | 119 | (f1 3) 120 | -------------------------------------------------------------------------------- /src/00-utils/print.ml: -------------------------------------------------------------------------------- 1 | (** Pretty-printing functions *) 2 | 3 | let () = 4 | Format.pp_set_max_indent !Config.error_formatter 1000; 5 | Format.pp_set_margin !Config.error_formatter 1000 6 | 7 | let message ~verbosity ?loc ~header fmt = 8 | if verbosity <= !Config.verbosity then 9 | match loc with 10 | | Some loc -> 11 | Format.fprintf !Config.error_formatter 12 | ("%s (%t):@," ^^ fmt ^^ "@.") 13 | header (Location.print loc) 14 | | None -> 15 | Format.fprintf !Config.error_formatter ("%s: " ^^ fmt ^^ "@.") header 16 | else Format.ifprintf !Config.error_formatter fmt 17 | 18 | let error ?loc err_kind fmt = message ~verbosity:1 ?loc ~header:err_kind fmt 19 | let check ?loc fmt = message ~verbosity:2 ?loc ~header:"Check" fmt 20 | let warning ?loc fmt = message ~verbosity:3 ?loc ~header:"Warning" fmt 21 | 22 | let print ?(at_level = min_int) ?(max_level = max_int) ppf = 23 | if at_level <= max_level then Format.fprintf ppf 24 | else fun fmt -> Format.fprintf ppf ("(" ^^ fmt ^^ ")") 25 | 26 | let sequence sep pp vs ppf = 27 | let i = String.length sep - 1 in 28 | let space = sep.[i] = ' ' in 29 | let sep = if space then String.sub sep 0 i else sep in 30 | let rec aux vs ppf = 31 | match vs with 32 | | [] -> () 33 | | [ v ] -> pp v ppf 34 | | v :: vs when space -> Format.fprintf ppf "%t%s@ %t" (pp v) sep (aux vs) 35 | | v :: vs -> Format.fprintf ppf "%t%s@ %t" (pp v) sep (aux vs) 36 | in 37 | aux vs ppf 38 | 39 | let printer_sequence sep printers ppf = 40 | sequence sep (fun printer ppf -> printer ppf) printers ppf 41 | 42 | let field fpp vpp (f, v) ppf = print ppf "%t = %t" (fpp f) (vpp v) 43 | 44 | let tuple pp lst ppf = 45 | match lst with 46 | | [] -> print ppf "()" 47 | | lst -> print ppf "(@[%t@])" (sequence ", " pp lst) 48 | 49 | let record fpp vpp lst ppf = 50 | print ppf "{@[%t@]}" (sequence "; " (field fpp vpp) lst) 51 | 52 | let debug_stack = ref [] 53 | let debug_depth = ref 0 54 | 55 | let debug ?loc fmt = 56 | message ~verbosity:4 ?loc 57 | ~header:("Debug " ^ String.make (2 * !debug_depth) ' ') 58 | fmt 59 | 60 | let open_scope fmt = 61 | Format.kfprintf 62 | (fun _ -> 63 | let scope = Format.flush_str_formatter () in 64 | debug "%s {" scope; 65 | debug_stack := scope :: !debug_stack; 66 | incr debug_depth) 67 | Format.str_formatter 68 | ("@[" ^^ fmt ^^ "@]") 69 | 70 | let close_scope () = 71 | match !debug_stack with 72 | | [] -> assert false 73 | | scope :: scopes -> 74 | debug_stack := scopes; 75 | decr debug_depth; 76 | debug "%s }" scope 77 | -------------------------------------------------------------------------------- /src/05-backends/runtime/value.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | open Language 3 | 4 | type value = 5 | | Const of Const.t 6 | | Tuple of value list 7 | | Record of value Type.Field.Map.t 8 | | Variant of Type.Label.t * value option 9 | | Closure of closure 10 | | TypeCoercionClosure of (Type.ct_ty -> value) 11 | | DirtCoercionClosure of (Type.ct_dirt -> value) 12 | | Handler of (result -> result) 13 | 14 | and result = Value of value | Call of Effect.t * value * closure 15 | and closure = value -> result 16 | 17 | let unit_value = Tuple [] 18 | let unit_result = Value unit_value 19 | 20 | let to_bool = function 21 | | Const (Const.Boolean b) -> b 22 | | _ -> Error.runtime "A boolean value expected." 23 | 24 | let to_int = function 25 | | Const (Const.Integer n) -> n 26 | | _ -> Error.runtime "An integer value expected." 27 | 28 | let to_float = function 29 | | Const (Const.Float f) -> f 30 | | _ -> Error.runtime "A floating-point value expected." 31 | 32 | let to_str = function 33 | | Const (Const.String s) -> s 34 | | _ -> Error.runtime "A string value expected." 35 | 36 | let to_handler = function 37 | | Handler h -> h 38 | | _ -> Error.runtime "A handler expected." 39 | 40 | let print_effect eff ppf = Format.fprintf ppf "%t" (Effect.print eff) 41 | 42 | let rec print_value ?max_level v ppf = 43 | let print ?at_level = Print.print ?max_level ?at_level ppf in 44 | match to_list v with 45 | | Some vs -> print "[@[%t@]]" (Print.sequence "; " print_value vs) 46 | | None -> ( 47 | match v with 48 | | Const c -> Const.print c ppf 49 | | Tuple lst -> Print.tuple print_value lst ppf 50 | | Record assoc -> 51 | Print.record Type.Field.print print_value 52 | (Type.Field.Map.bindings assoc) 53 | ppf 54 | | Variant (lbl, None) -> print ~at_level:1 "%t" (Type.Label.print lbl) 55 | | Variant (lbl, Some v) -> 56 | print ~at_level:1 "%t @[%t@]" (Type.Label.print lbl) 57 | (print_value v) 58 | | Closure _ -> print "" 59 | | Handler _ -> print "" 60 | | TypeCoercionClosure _ -> print "" 61 | | DirtCoercionClosure _ -> print "") 62 | 63 | and to_list = function 64 | | Variant (lbl, None) when lbl = Type.nil -> Some [] 65 | | Variant (lbl, Some (Tuple [ hd; tl ])) when lbl = Type.cons -> 66 | Option.bind (to_list tl) (fun vs -> Some (hd :: vs)) 67 | | _ -> None 68 | 69 | let print_result r ppf = 70 | match r with 71 | | Value v -> print_value v ppf 72 | | Call (eff, v, _) -> 73 | Format.fprintf ppf "Call %t %t" (print_effect eff) (print_value v) 74 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/queensNative.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | 3 | let no_attack (x, y) (x', y') = 4 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 5 | 6 | let rec not_attacked x' = function 7 | | [] -> true 8 | | x :: xs -> if no_attack x' x then not_attacked x' xs else false 9 | 10 | let available (number_of_queens, x, qs) = 11 | let rec loop (possible, y) = 12 | if y < 1 then possible 13 | else if not_attacked (x, y) qs then loop (y :: possible, y - 1) 14 | else loop (possible, y - 1) 15 | in 16 | loop ([], number_of_queens) 17 | 18 | (******************************************************************************) 19 | 20 | exception Fail 21 | 22 | let queens_one_exceptions number_of_queens = 23 | let rec place (x, qs) = 24 | if x > number_of_queens then qs 25 | else 26 | let rec choose = function 27 | | [] -> raise Fail 28 | | y :: ys -> ( try place (x + 1, (x, y) :: qs) with Fail -> choose ys) 29 | in 30 | choose (available (number_of_queens, x, qs)) 31 | in 32 | place (1, []) 33 | 34 | (******************************************************************************) 35 | 36 | let queens_one_option number_of_queens = 37 | let rec place (x, qs) = 38 | if x > number_of_queens then Some qs 39 | else 40 | let rec choose = function 41 | | [] -> None 42 | | y :: ys -> ( 43 | match place (x + 1, (x, y) :: qs) with 44 | | Some qs -> Some qs 45 | | None -> choose ys) 46 | in 47 | choose (available (number_of_queens, x, qs)) 48 | in 49 | place (1, []) 50 | 51 | (******************************************************************************) 52 | 53 | let queens_one_cps number_of_queens = 54 | let rec place (x, qs) = 55 | if x > number_of_queens then fun _ -> qs 56 | else 57 | let rec choose = function 58 | | [] -> fun k -> k () 59 | | y :: ys -> 60 | fun k -> 61 | place (x + 1, (x, y) :: qs) (fun () -> choose ys (fun () -> k ())) 62 | in 63 | fun a -> choose (available (number_of_queens, x, qs)) a 64 | in 65 | place (1, []) (fun () -> []) 66 | 67 | (******************************************************************************) 68 | 69 | let queens_all number_of_queens = 70 | let rec place (x, qs) = 71 | if x > number_of_queens then [ qs ] 72 | else 73 | let rec choose = function 74 | | [] -> [] 75 | | y :: ys -> place (x + 1, (x, y) :: qs) @ choose ys 76 | in 77 | choose (available (number_of_queens, x, qs)) 78 | in 79 | place (1, []) 80 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/queens.eff: -------------------------------------------------------------------------------- 1 | (* A n-queens implementation without top-level bindings and no polymorphism *) 2 | 3 | effect Decide : unit -> bool 4 | effect Fail : unit -> empty 5 | 6 | (*type 'a option = None | Some of 'a;; *) 7 | type queen = int * int 8 | type rows = RowsEmpty | RowsCons of int * rows 9 | type solution = SolutionEmpty | SolutionPlace of queen * solution 10 | type solutions = SolutionsNil | SolutionsCons of solution * solutions 11 | type optional_solution = None | Some of solution 12 | type void = Void 13 | 14 | let absurd void = (match void with) 15 | ;; 16 | let rec ( @ ) xs ys = 17 | match xs with 18 | | SolutionsNil -> ys 19 | | SolutionsCons (x, xs) -> SolutionsCons (x, xs @ ys) 20 | 21 | let no_attack ( (x, y)) ( (x', y')) = 22 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 23 | 24 | let rec not_attacked x' qs = 25 | match qs with 26 | | SolutionEmpty -> true 27 | | SolutionPlace (x, xs) -> 28 | (no_attack x' x) && (not_attacked x' xs) 29 | 30 | let available number_of_queens x qs = 31 | let rec loop (possible, y) = 32 | if y < 1 then possible 33 | else if not_attacked ( (x, y)) qs then 34 | loop (RowsCons (y, possible), y - 1) 35 | else loop (possible, y - 1) 36 | in 37 | loop (RowsEmpty, number_of_queens) 38 | 39 | let rec choose xs = 40 | match xs with 41 | | RowsEmpty -> (match (perform (Fail ())) with) 42 | | RowsCons (x, xs') -> if perform (Decide ()) then x else choose xs' 43 | 44 | let queens number_of_queens = 45 | let rec place (x, qs) = 46 | if x > number_of_queens then qs 47 | else 48 | let y = choose (available number_of_queens x qs) in 49 | place (x + 1, SolutionPlace ( (x, y), qs)) 50 | in 51 | place (1, SolutionEmpty) 52 | 53 | let queens_one_option number_of_queens = 54 | let optionalize = handler 55 | | effect (Decide _) k -> ( 56 | match k true with 57 | | Some x -> Some x 58 | | None -> k false 59 | ) 60 | | effect (Fail _) _k -> None 61 | | y -> (Some y) 62 | in 63 | with optionalize handle queens number_of_queens 64 | 65 | let queens_all number_of_queens = 66 | let choose_all = handler 67 | | effect (Decide _) k -> k true @ k false 68 | | effect (Fail _) _k -> SolutionsNil 69 | | x -> SolutionsCons (x, SolutionsNil) 70 | in 71 | with choose_all handle queens number_of_queens 72 | 73 | let queens_one_cps number_of_queens = 74 | let absurd void = (match void with) in 75 | let backtrack = handler 76 | | effect (Decide _) k -> 77 | (fun kf -> k true (fun _ -> k false kf) ) 78 | | effect (Fail _) _k -> (fun kf -> kf ()) 79 | | y -> (fun _ -> y) 80 | in 81 | (with backtrack handle queens number_of_queens) (fun () -> (absurd (perform (Fail ())))) -------------------------------------------------------------------------------- /misc/type-inference-time-complexity/stat/loop_timing_100_runs.txt: -------------------------------------------------------------------------------- 1 | 57.358129999999996; 34 2 | 57.60991100000001; 34 3 | 55.86655799999998; 34 4 | 56.32081399999997; 34 5 | 57.38850600000001; 34 6 | 54.40637600000004; 34 7 | 58.115043000000036; 34 8 | 53.39508300000001; 34 9 | 56.57364499999995; 34 10 | 56.37895000000004; 34 11 | 55.350735999999955; 34 12 | 55.65162800000001; 34 13 | 55.67813200000005; 34 14 | 56.698576999999915; 34 15 | 55.82493900000007; 34 16 | 56.383066999999954; 34 17 | 56.65029399999999; 34 18 | 55.9636; 34 19 | 55.21073799999998; 34 20 | 55.56972699999996; 34 21 | 55.82037100000004; 34 22 | 56.294128; 34 23 | 57.11900599999997; 34 24 | 58.36057699999997; 34 25 | 57.90835299999997; 34 26 | 57.852911999999975; 34 27 | 58.038475000000034; 34 28 | 56.40413300000002; 34 29 | 56.64323400000004; 34 30 | 58.24132399999993; 34 31 | 56.26786700000008; 34 32 | 57.4057349999999; 34 33 | 55.80738500000004; 34 34 | 56.655436; 34 35 | 54.745448999999894; 34 36 | 54.37619100000024; 34 37 | 57.85982499999997; 34 38 | 55.66524799999995; 34 39 | 58.23479300000001; 34 40 | 57.982957999999755; 34 41 | 57.44311300000015; 34 42 | 57.98749599999997; 34 43 | 55.736879999999985; 34 44 | 58.691987; 34 45 | 55.48608399999999; 34 46 | 57.098230999999885; 34 47 | 59.2766720000002; 34 48 | 59.18902199999998; 34 49 | 57.948405000000314; 34 50 | 55.58520599999994; 34 51 | 58.98911299999998; 34 52 | 56.7426649999998; 34 53 | 56.21340399999974; 34 54 | 61.94944499999977; 34 55 | 56.66790499999985; 34 56 | 56.29633399999978; 34 57 | 62.274780000000085; 34 58 | 56.93223000000014; 34 59 | 57.27895400000005; 34 60 | 59.78381499999985; 34 61 | 56.386875999999916; 34 62 | 54.95916600000017; 34 63 | 54.28937699999992; 34 64 | 57.52588700000017; 34 65 | 58.58793099999993; 34 66 | 57.40522199999987; 34 67 | 57.879352000000054; 34 68 | 59.83703000000018; 34 69 | 57.614900999999996; 34 70 | 55.83696500000013; 34 71 | 54.18049800000002; 34 72 | 55.52306900000037; 34 73 | 55.55746799999994; 34 74 | 55.19035199999944; 34 75 | 55.58939699999943; 34 76 | 55.89814599999965; 34 77 | 53.91781900000048; 34 78 | 55.79440700000049; 34 79 | 55.99079699999976; 34 80 | 57.38772900000022; 34 81 | 55.14808100000046; 34 82 | 56.96747999999996; 34 83 | 55.98735399999999; 34 84 | 56.245983000000166; 34 85 | 55.808307999999585; 34 86 | 55.25963399999956; 34 87 | 55.975895999999636; 34 88 | 56.690715000000225; 34 89 | 53.97498000000045; 34 90 | 56.477311000000086; 34 91 | 55.750140999999864; 34 92 | 56.70628000000022; 34 93 | 56.86355199999937; 34 94 | 56.69189499999927; 34 95 | 54.40429199999919; 34 96 | 55.942122999999455; 34 97 | 56.8252290000002; 34 98 | 59.42792699999977; 34 99 | 57.74054000000017; 34 100 | 55.774229999999925; 34 101 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/loopOpt.ml: -------------------------------------------------------------------------------- 1 | open OcamlHeader 2 | 3 | let rec _loop_pure_42 _x_48 = if _x_48 = 0 then () else _loop_pure_42 (_x_48 - 1) 4 | let loop_pure = _loop_pure_42 5 | let _test_pure_54 (_n_55 : int) = _loop_pure_42 _n_55 6 | let test_pure = _test_pure_54 7 | 8 | type (_, _) eff_internal_effect += Fail : (unit, empty) eff_internal_effect 9 | 10 | let rec _loop_latent_56 _x_67 = 11 | if _x_67 = 0 then Value () 12 | else if _x_67 < 0 then 13 | Call 14 | ( Fail, 15 | (), 16 | fun (_y_76 : empty) -> Value (match _y_76 with _ -> assert false) ) 17 | else _loop_latent_56 (_x_67 - 1) 18 | 19 | let loop_latent = _loop_latent_56 20 | let _test_latent_79 (_n_80 : int) = _loop_latent_56 _n_80 21 | let test_latent = _test_latent_79 22 | 23 | type (_, _) eff_internal_effect += Incr : (unit, unit) eff_internal_effect 24 | 25 | let rec _loop_incr_81 _x_89 = 26 | if _x_89 = 0 then Value () 27 | else Call (Incr, (), fun (_y_95 : unit) -> _loop_incr_81 (_x_89 - 1)) 28 | 29 | let loop_incr = _loop_incr_81 30 | 31 | let _test_incr_98 (_n_99 : int) = 32 | let rec _loop_incr_114 _x_89 (_x_0 : int) = 33 | if _x_89 = 0 then _x_0 else _loop_incr_114 (_x_89 - 1) (_x_0 + 1) 34 | in 35 | _loop_incr_114 _n_99 0 36 | 37 | let test_incr = _test_incr_98 38 | 39 | let rec _loop_incr'_148 _x_156 = 40 | if _x_156 = 0 then Value () 41 | else 42 | _loop_incr'_148 (_x_156 - 1) >>= fun _ -> 43 | Call (Incr, (), fun (_y_164 : unit) -> Value _y_164) 44 | 45 | let loop_incr' = _loop_incr'_148 46 | 47 | let _test_incr'_165 (_n_166 : int) = 48 | let rec _loop_incr'_200 (_x_156, _k_203) = 49 | if _x_156 = 0 then _k_203 () 50 | else 51 | _loop_incr'_200 52 | (_x_156 - 1, fun (_ : unit) (_x_260 : int) -> _k_203 () (_x_260 + 1)) 53 | and _loop_incr_201 _x_89 (_x_1 : int) = 54 | if _x_89 = 0 then _x_1 else _loop_incr_201 (_x_89 - 1) (_x_1 + 1) 55 | in 56 | _loop_incr'_200 (_n_166, fun (_x_173 : unit) (_x_175 : int) -> _x_175) 0 57 | 58 | let test_incr' = _test_incr'_165 59 | 60 | type (_, _) eff_internal_effect += Get : (unit, int) eff_internal_effect 61 | type (_, _) eff_internal_effect += Put : (int, unit) eff_internal_effect 62 | 63 | let rec _loop_state_281 _x_294 = 64 | if _x_294 = 0 then Value () 65 | else 66 | Call 67 | ( Get, 68 | (), 69 | fun (_y_303 : int) -> 70 | Call 71 | ( Put, 72 | _y_303 + 1, 73 | fun (_y_306 : unit) -> _loop_state_281 (_x_294 - 1) ) ) 74 | 75 | let loop_state = _loop_state_281 76 | 77 | let _test_state_309 (_n_310 : int) = 78 | let rec _loop_state_327 _x_294 (_x_2 : int) = 79 | if _x_294 = 0 then _x_2 else _loop_state_327 (_x_294 - 1) (_x_2 + 1) 80 | in 81 | _loop_state_327 _n_310 0 82 | 83 | let test_state = _test_state_309 84 | -------------------------------------------------------------------------------- /examples/amb.eff: -------------------------------------------------------------------------------- 1 | (* This example is described in Section 6.7 of "Programming with Algebraic Effects and 2 | Handlers" by A. Bauer and M. Pretnar. *) 3 | 4 | type result = Failure | Success of (int*int) list 5 | 6 | effect Select : bool 7 | 8 | let amb = handler 9 | | effect Select k -> 10 | (match k true with 11 | | Success y -> Success y 12 | | Failure -> k false) 13 | ;; 14 | 15 | (* The 8 queens problem. *) 16 | 17 | let rec select_from = function 18 | | [] -> None 19 | | x::xs -> if perform Select then Some x else select_from xs 20 | 21 | let no_attack (x,y) (x',y') = 22 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 23 | 24 | let available x qs = 25 | filter (fun y -> forall (no_attack (x,y)) qs) [1;2;3;4;5;6;7;8] 26 | ;; 27 | 28 | (* This one finds [(8, 4); (7, 2); (6, 7); (5, 3); (4, 6); (3, 8); (2, 5); (1, 1)]. *) 29 | with amb handle 30 | let rec place x qs = 31 | if x = 9 then Success qs else 32 | match select_from (available x qs) with 33 | | Some y -> place (x+1) ((x, y) :: qs) 34 | | None -> Failure 35 | in place 1 [] 36 | ;; 37 | 38 | (* Breadth-first search. *) 39 | 40 | (* We add a state handler to use as a queue. *) 41 | 42 | effect Get_next : ((bool -> result)*bool) option 43 | effect Add_to_queue : ((bool -> result)*bool) -> unit 44 | 45 | let queue initial = handler 46 | | effect Get_next k -> 47 | ( fun queue -> match queue with 48 | | [] -> k None [] 49 | | hd::tl -> k (Some hd) tl ) 50 | | effect (Add_to_queue y) k -> ( fun queue -> k () (queue @ [y])) 51 | | x -> ( fun _ -> x) 52 | | finally x -> x initial 53 | ;; 54 | 55 | 56 | let bfs = 57 | (* Auxilary function that runs the next choice. *) 58 | let run_next () = 59 | match perform Get_next with 60 | | None -> Failure 61 | | Some (k,x) -> k x 62 | in 63 | handler (* Handler definition. *) 64 | | effect Select k -> 65 | perform (Add_to_queue (k, true)); 66 | perform (Add_to_queue (k, false)); 67 | run_next () 68 | (* When the computation fails, run the next choice. Final Failure 69 | comes from run_next when the queue is empty. *) 70 | | Success x -> Success x 71 | | Failure -> run_next () 72 | ;; 73 | 74 | (* We repeat 8-queen example with breadth-first-search. It is much slower 75 | than amb, which is not surprising. It still finds the same solution 76 | (which is what we would expect in this case). *) 77 | with queue [] handle 78 | with bfs handle 79 | let rec place x qs = 80 | if x = 9 then Success qs else 81 | match select_from (available x qs) with 82 | | Some y -> place (x+1) ((x, y) :: qs) 83 | | None -> Failure 84 | in place 1 [] 85 | ;; 86 | 87 | (* In this case using BFS is both slower and requires more code because we need 88 | to have a queue, but it is an example of how neatly handlers can be nested. *) 89 | -------------------------------------------------------------------------------- /misc/code-generation-benchmarks/benchmark-suite/native_multicore/capabilityBenchmarks.ml: -------------------------------------------------------------------------------- 1 | (* Triple -> Unknown *) 2 | 3 | (* Queens *) 4 | 5 | (* Taken verbatim from 6 | https://github.com/ocaml-multicore/effects-examples/blob/68f16120873f1ade4536ab3916ccce47fd424f9e/queens.ml 7 | *) 8 | 9 | effect Select : 'a list -> 'a 10 | 11 | let rec filter p = function 12 | | [] -> [] 13 | | x :: xs -> 14 | if p x then (x :: filter p xs) else filter p xs 15 | 16 | let rec forall p = function 17 | | [] -> true 18 | | x :: xs -> if p x then forall p xs else false 19 | 20 | let no_attack (x,y) (x',y') = 21 | x <> x' && y <> y' && abs (x - x') <> abs (y - y') 22 | 23 | let available x qs l = 24 | filter (fun y -> forall (no_attack (x,y)) qs) l 25 | 26 | let find_solution n = 27 | try 28 | let l = ref [] in 29 | for i = n downto 1 do 30 | l := i::!l; 31 | done; 32 | let rec place x qs = 33 | if x = n+1 then Some qs else 34 | let y = perform @@ Select (available x qs !l) in 35 | place (x+1) ((x, y) :: qs) 36 | in place 1 [] 37 | with 38 | | effect (Select lst) k -> 39 | let rec loop = function 40 | | [] -> None 41 | | x::xs -> 42 | match continue (Obj.clone_continuation k) x with 43 | | None -> loop xs 44 | | Some x -> Some x 45 | in loop lst 46 | 47 | let queens_all number_of_queens = 48 | find_solution number_of_queens 49 | 50 | (* Count *) 51 | 52 | effect CountPut: int -> unit 53 | effect CountGet: unit -> int 54 | ;; 55 | let rec count () = 56 | let i = perform (CountGet ()) in 57 | if i = 0 then i 58 | else( 59 | (perform (CountPut (i-1))); 60 | count () 61 | ) 62 | 63 | let testCount m = 64 | (match count () 65 | with 66 | | y -> (fun _ -> y) 67 | | effect (CountGet ()) k -> ( 68 | fun (s: int) -> (continue k s) s 69 | ) 70 | | effect (CountPut s) k -> ( 71 | fun (_: int) -> (continue k ()) s 72 | ) 73 | ) m 74 | 75 | (* Generator *) 76 | 77 | effect GeneratorPut: int -> unit 78 | effect GeneratorGet: unit -> int 79 | effect GeneratorYield: int -> unit 80 | ;; 81 | 82 | let testGenerator n = 83 | let rec generateFromTo l u = 84 | if (l > u) 85 | then () 86 | else ( 87 | perform (GeneratorYield l); 88 | generateFromTo (l + 1) u 89 | ) 90 | in 91 | let comp = 92 | match ( 93 | try (generateFromTo 1 n) with 94 | | effect (GeneratorYield e) k -> (perform (GeneratorPut (perform (GeneratorGet ()) + e)); continue k ()) 95 | ) with 96 | | x -> (fun s -> s) 97 | | effect (GeneratorPut s') k -> (fun s -> continue k () s') 98 | | effect (GeneratorGet _) k -> (fun s -> continue k s s) 99 | in comp 0 100 | 101 | -------------------------------------------------------------------------------- /examples/choice.eff: -------------------------------------------------------------------------------- 1 | (* This example is described in Section 6.1 of "Programming with Algebraic Effects and 2 | Handlers" by A. Bauer and M. Pretnar. *) 3 | 4 | (* An operation which makes a binary choice. *) 5 | 6 | effect Decide : bool;; 7 | 8 | (* The following piece of code chooses 10 or 20 for x and 0 or 5 for y, 9 | but since it is not wrapped in a handler it just produces a runtime 10 | error about an uncought operation: 11 | 12 | let x = (if perform (Decide ()) then 10 else 20) in 13 | let y = (if perform (Decide ()) then 0 else 5) in 14 | x - y;; 15 | *) 16 | 17 | (* If we wrap it in a handler which handles #Decide by 18 | passing true to the continuation, then x gets 10 and 19 | y gets 0. *) 20 | 21 | handle 22 | let x = (if perform Decide then 10 else 20) in 23 | let y = (if perform Decide then 0 else 5) in 24 | x - y 25 | with 26 | | effect Decide k -> k true;; 27 | 28 | match 29 | let x = (if perform Decide then 10 else 20) in 30 | let y = (if perform Decide then 0 else 5) in 31 | Some (x - y) 32 | with 33 | | effect Decide k -> k true 34 | | Some v -> v 35 | | None -> 0 36 | ;; 37 | 38 | (* This handler collects all results that we can get by making different choices. *) 39 | 40 | let choose_all = handler 41 | | effect Decide k -> k true @ k false 42 | | x -> [x];; 43 | 44 | (* This returns a list of four possibilities [10; 5; 20; 15] *) 45 | 46 | with choose_all handle 47 | let x = (if perform Decide then 10 else 20) in 48 | let y = (if perform Decide then 0 else 5) in 49 | x - y;; 50 | 51 | effect Decide2 : bool;; 52 | 53 | let choose_all2 = handler 54 | | effect Decide2 k -> k true @ k false 55 | | x -> [x];; 56 | 57 | (* We can create two instances and handle each one separately. The inner handler produces 58 | two results in a list, and the outer handler then produces a list of two lists of two 59 | results, so the answer is [[10; 5]; [20; 15]]. *) 60 | 61 | with choose_all handle 62 | with choose_all2 handle 63 | let x = (if perform Decide then 10 else 20) in 64 | let y = (if perform Decide2 then 0 else 5) in 65 | x - y;; 66 | 67 | (* If we switch the order of handlers and operations we also get a list of two lists of 68 | two results, but in a different order: [[10; 20]; [5; 15]] *) 69 | 70 | with choose_all2 handle 71 | with choose_all handle 72 | let y = (if perform Decide2 then 0 else 5) in 73 | let x = (if perform Decide then 10 else 20) in 74 | x - y;; 75 | 76 | (* However, switching around only the handler but not the operations, produces a list of 77 | _four_ lists of two elements each: [[10; 20]; [10; 15]; [5; 20]; [5; 15]] 78 | Exercise: explain this. *) 79 | 80 | with choose_all2 handle 81 | with choose_all handle 82 | let x = (if perform Decide then 10 else 20) in 83 | let y = (if perform Decide2 then 0 else 5) in 84 | x - y;; 85 | -------------------------------------------------------------------------------- /docs/try/examples/printing.eff: -------------------------------------------------------------------------------- 1 | (** Printing to the standard output *) 2 | 3 | (* The main premise of algebraic effects, which is what Eff is based on, 4 | is that each effect (manipulating memory, exceptions, ...) arises from 5 | a set of basic operations, for example lookup & update or raise. 6 | For example, we print out messages by performing the operation 7 | "Print". *) 8 | 9 | (* To recap: you print out messages by performing "Print". For example: *) 10 | 11 | perform (Print "Hello, world!\n") ;; 12 | 13 | (* Where Eff really differs from OCaml is that you can handle such calls. 14 | For example, the program inside the handler would print "A", "B", "C" and "D", 15 | but the handler overrides it just as an exception handler would override an 16 | exception. Thus, the program should output just: 17 | 18 | "I see you tried to print A. Not so fast!" *) 19 | 20 | handle 21 | perform (Print "A"); 22 | perform (Print "B"); 23 | perform (Print "C"); 24 | perform (Print "D") 25 | with 26 | | effect (Print msg) k -> 27 | perform (Print ("I see you tried to print " ^ msg ^ ". Not so fast!\n")) 28 | ;; 29 | 30 | (* You may be wondering what the second parameter "k" in the handling clause 31 | for Print is. It stands for the continuation, i.e. the part of the program 32 | that is waiting for the result of print. The difference between exception 33 | handlers and general effect handlers is that we may call this continuation. 34 | For example, instead of stopping after the first print like above, we may 35 | handle it and then resume the continuation by passing it "()", the unit 36 | result expected from the call of Print. Continuations should be called with 37 | "continue k ..." to be more easily distinguished from regular functions. *) 38 | 39 | handle 40 | perform (Print "A"); 41 | perform (Print "B"); 42 | perform (Print "C"); 43 | perform (Print "D") 44 | with 45 | | effect (Print msg) k -> 46 | perform (Print ("I see you tried to print " ^ msg ^ ". Okay, you may.\n")); 47 | continue k () 48 | ;; 49 | 50 | (* The handlers may be even more complex. For example, we may create a handler 51 | to collect all Print calls, and instead of printing the strings separately, 52 | the handler returns a combined string of all prints. *) 53 | 54 | let collect = handler 55 | (* We return the value of the computation and a string. *) 56 | | x -> (x, "") 57 | | effect (Print msg) k -> 58 | (* First see what the rest of the computation returns and prints... *) 59 | let (result, msgs) = continue k () in 60 | (* Add the string that we want to print at the begining. *) 61 | (result, msg ^ msgs) 62 | ;; 63 | 64 | with collect handle 65 | perform (Print "A"); 66 | perform (Print "B"); 67 | perform (Print "C"); 68 | perform (Print "D") 69 | ;; 70 | --------------------------------------------------------------------------------