├── .gitignore ├── .merlin ├── LICENSE ├── Makefile ├── README.md ├── src └── ppx_rule.ml └── tests └── test_ppx_rule.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src 2 | B _buil 3 | PKG compiler-libs.common 4 | 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Rizo Isrof 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | default: build 3 | 4 | help: 5 | @echo "make help - this help message" 6 | @echo "make build - build the syntax extension" 7 | @echo "make test - run the tests" 8 | @echo "make code - show the processed code of the tests" 9 | @echo "make tree - show the syntax tree of the tests" 10 | @echo "make clean - remove the binaries and build artifacts" 11 | 12 | build: 13 | ocamlbuild -package compiler-libs.bytecomp src/ppx_rule.native 14 | 15 | test: build 16 | ocamlopt -ppx ./ppx_rule.native ./tests/test_ppx_rule.ml -o ./test_ppx_rule.native 17 | 18 | code: build 19 | ocamlc -dsource -ppx ./ppx_rule.native ./tests/test_ppx_rule.ml 20 | 21 | tree: build 22 | ocamlc -dparsetree -ppx ./ppx_rule.native ./tests/test_ppx_rule.ml 23 | 24 | clean: 25 | ocamlbuild -clean 26 | rm -rf *.native 27 | 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Compile-time optimization rules 3 | 4 | This syntax extension implements compile-time rewrite rules to offer a powerful and flexible way to optimise your programs. 5 | 6 | Consider the following simple examples: 7 | 8 | ```ocaml 9 | (* Helper functions *) 10 | 11 | let sum x y = x + y 12 | let hello who = "Hello, " ^ who 13 | 14 | (* Rules *) 15 | 16 | let%rule sum 2 2 = 5 17 | let%rule hello "rule" = "rules rock!" 18 | let%rule sqrt 100000000000.0 = 316227.766017 19 | 20 | let replaced = (sum 2 2, hello "rule", sqrt 100000000000.0) 21 | let computed = (sum 1 1, hello "world", sqrt 99.0) 22 | ``` 23 | 24 | The syntax processor will replace the known patterns during the compilation time. 25 | After the application the resulting code will look like this: 26 | 27 | ```ocaml 28 | let sum x y = x + y 29 | let hello who = "Hello, " ^ who 30 | 31 | let replaced = (5, "rules rock!", 316227.766017) 32 | let computed = (sum 1 1, hello "world", sqrt 99.0) 33 | ``` 34 | 35 | Note that the rules disappear during the compliation, so no runtime overhead is added to the program. 36 | 37 | For more examples see the `tests` directory and for build options run `make help`. 38 | 39 | ## Known Limitations 40 | 41 | - Parametric rules are not implemented yet. 42 | - The visibility of the rules is limited to the module where they were declared. 43 | - Recursive rules may have unexpected results. 44 | 45 | ## Project Status 46 | 47 | This project is still in development and at this point should be considered a proof of concept, please use with care. 48 | 49 | This syntax extension was inspired by [Rule pragma](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/rewrite-rules.html) for Haskell. 50 | 51 | -------------------------------------------------------------------------------- /src/ppx_rule.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ast_mapper 3 | open Asttypes 4 | open Parsetree 5 | 6 | let log str = output_string stderr (str ^ "\n") 7 | 8 | (* TODO: Review this documentation, more combinations are possible. *) 9 | (* Recursively rocesses the value binding expression collecting patterns and 10 | values. Two types of bindings are possible: One and Many. 11 | 12 | The "One" binding results from Pexp_fun usage. In this case the return value 13 | will contain a list of consecutive lambda patterns and the final value: 14 | 15 | fun pat0 -> fun pat1 -> ... -> patN -> val 16 | 17 | `One ([pat0; pat1; ...; patN], val) 18 | 19 | The "Many" bindings are created with Pexp_function in which case several 20 | patterns and values are collected: 21 | 22 | function 23 | | pat0 -> val0 24 | | pat1 -> val1 25 | ... 26 | | patN -> valN 27 | 28 | `Many [(pat0, val0); (pat1, val1); ...; (patN, valN)] 29 | 30 | The Pexp_fun rules with labels and optional arguments are not supported. 31 | The Pexp_function rules with when conditions are not supported. 32 | *) 33 | let collect_bindings expr = 34 | let rec loop (pat_list, _) expr = 35 | match expr with 36 | | Pexp_fun ("", None, {ppat_desc = pat}, {pexp_desc = next}) -> 37 | loop (pat :: pat_list, None) next 38 | 39 | | Pexp_fun (label, None, {ppat_desc = pat}, next) -> 40 | failwith "[%%rule]: rules with labels are not currently supported" 41 | 42 | | Pexp_fun (_, Some default_arg, _, _) -> 43 | failwith "[%%rule]: rules with optional arguments are illegal" 44 | 45 | | Pexp_function case_list -> 46 | failwith "[%%rule]: rules with multiple cases are not currently supported" 47 | 48 | (* Everything else is expected to be a value. *) 49 | | value -> (pat_list, Some value) 50 | in 51 | match loop ([], None) expr with 52 | | pat_list, Some value -> pat_list, value 53 | | _ -> assert false 54 | 55 | let rule_of_binding {pvb_pat; pvb_expr} = 56 | match pvb_pat with 57 | | {ppat_desc = Ppat_var {txt = rule_name}} -> 58 | let (pat_list, value) = collect_bindings pvb_expr.pexp_desc in 59 | (rule_name, pat_list, value) 60 | | _ -> failwith "FIXME" 61 | 62 | let exp_to_pat_equiv exp = 63 | match exp with 64 | | Pexp_constant x -> Some (Ppat_constant x) 65 | | _ -> None 66 | 67 | let find_rule_for_call rules (func_name, arg_exp_list) = 68 | let pat_opt_list = List.map exp_to_pat_equiv arg_exp_list in 69 | let all_pat_ok = List.for_all 70 | (function Some _ -> true | None -> false) pat_opt_list in 71 | 72 | if not all_pat_ok then None 73 | else 74 | let pat_list = List.map 75 | (function Some x -> x | None -> assert false) pat_opt_list in 76 | if Hashtbl.mem rules (func_name, pat_list) then 77 | Some (Hashtbl.find rules (func_name, pat_list)) 78 | else None 79 | 80 | let rules_table = Hashtbl.create 100 81 | 82 | let rec structure mapper items = 83 | match items with 84 | (* 85 | * Register rewrite rule: `let%rule f x = value` 86 | *) 87 | | {pstr_desc = 88 | Pstr_extension (({txt = "rule"; loc}, PStr [{pstr_desc = 89 | Pstr_value (_rec_flag, value_binding_list)}]), _)} :: items -> 90 | (* - extract info from payload: rule name and args *) 91 | let rules = 92 | try List.map rule_of_binding value_binding_list 93 | with Failure msg -> 94 | log ("e: " ^ msg); 95 | [] in 96 | (* - register the rule in the hashtable with metadata (TODO: loc) *) 97 | let () = List.iter (fun (pat_name, pat_list, value) -> 98 | log ("i: saving rule " ^ pat_name); 99 | Hashtbl.add rules_table (pat_name, pat_list) value) rules in 100 | (* - skip this item, return items *) 101 | structure mapper items 102 | 103 | | item :: items -> 104 | mapper.structure_item mapper item :: structure mapper items 105 | 106 | | [] -> [] 107 | 108 | let expr this e = 109 | match e.pexp_desc with 110 | (* 111 | * Apply rewrite rule: `f x...` -> `value` 112 | *) 113 | | Pexp_apply ({pexp_desc = Pexp_ident {txt = Longident.Lident func_name}}, args) -> 114 | let arg_exp_list = List.map (fun (l, {pexp_desc = exp}) -> exp) args in 115 | begin match find_rule_for_call rules_table (func_name, arg_exp_list) with 116 | | Some value -> { e with pexp_desc = value } 117 | | None -> e 118 | end 119 | 120 | | _ -> default_mapper.expr this e 121 | 122 | let () = 123 | Ast_mapper.register "ppx_rule" (fun argv -> 124 | { default_mapper with structure; expr }) 125 | 126 | -------------------------------------------------------------------------------- /tests/test_ppx_rule.ml: -------------------------------------------------------------------------------- 1 | 2 | (* Helper functions *) 3 | 4 | let sum x y = x + y 5 | 6 | let hello ~name = "Hello, " ^ name 7 | 8 | let rec factorial n = 9 | if n = 0 then 1 else n * factorial (n - 1) 10 | 11 | (* Constant value rules. *) 12 | 13 | (* let%rule number = 42 *) 14 | 15 | (* Simple functions. *) 16 | 17 | let%rule sum 2 2 = 4 18 | let%rule sum' 2 = fun 2 -> 4 19 | let%rule sum'' = fun 2 -> fun 2 -> 4 20 | 21 | (* Labeled functions. *) 22 | 23 | let%rule hello ~name:"world" = "Good bye, world" 24 | 25 | (* Case functions. *) 26 | 27 | let%rule sin 1.0 = 0.841470984808 28 | let%rule sqrt = function 100.0 -> 10.0 | 10000.0 -> 100.0 29 | let%rule factorial = function 30 | | 24 -> 1388186055525531648 31 | | n when n > 24 -> raise (Failure "factorial: overflow") 32 | let%rule sum' = fun 2 -> function 2 -> 2 33 | | 3 -> 5 34 | 35 | let tests = begin 36 | (* number, *) 37 | sin 1.0, 38 | sin 0.5, 39 | sum 2 2, 40 | sqrt 100.0 41 | end 42 | 43 | --------------------------------------------------------------------------------