├── .gitignore ├── _tags ├── lib ├── genletrec.mli ├── attr_support_530.ml ├── letrec.mli ├── letrec.ml └── genletrec.ml ├── Changes ├── lib_test ├── recursive_values.ml ├── ackermann.ml ├── even_odd.ml ├── residuals.ml ├── nested.ml ├── test_types.ml ├── polymorphic.ml ├── custom_eq.ml └── tests.ml ├── META ├── myocamlbuild.ml ├── opam ├── Makefile ├── LICENSE ├── .github └── workflows │ └── test.yml ├── ppx └── ppx_letrec.ml └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *~ 3 | *.byte 4 | *.native 5 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | "lib": include 2 | "lib_test": include 3 | "ppx": include 4 | 5 | : ppx(../ppx_letrec.byte), open_print_code 6 | : package(compiler-libs), open_print_code 7 | : open_print_code 8 | : package(compiler-libs), open_print_code 9 | : package(compiler-libs) 10 | -------------------------------------------------------------------------------- /lib/genletrec.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** Low-level interface for let-rec generation *) 9 | 10 | type locus_t 11 | val genletrec_locus: (locus_t -> 'a code) -> 'a code 12 | val genletrec : locus_t -> ('a code -> 'a code) -> 'a code 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | ## letrec 0.3.0 2 | 3 | - Support only BER n153 4 | 5 | ## letrec 0.2.1 6 | 7 | - Add support for BER n114 8 | 9 | ## letrec 0.2.0 10 | 11 | - Add support for custom equality in the syntax extension: 12 | 13 | ``` 14 | let%staged[@eq p] rec f x = ... 15 | ``` 16 | 17 | ## letrec 0.1.1 18 | 19 | - Add support for BER n111 20 | 21 | ## letrec 0.1 22 | 23 | Initial release 24 | -------------------------------------------------------------------------------- /lib_test/recursive_values.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Generating mutually-recursive values *) 9 | let values n = 10 | let%staged rec vals i = 11 | if i = n then .< n :: .~(vals 0) >. 12 | else .< i :: .~(vals (succ i)) >. 13 | in vals 0 14 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | version = "0.3.0" 2 | description = "let rec generation for MetaOCaml" 3 | requires = "compiler-libs" 4 | archive(byte) = "letrec.cma" 5 | archive(native) = "letrec.cmxa" 6 | exists_if = "letrec.cma" 7 | 8 | package "ppx" ( 9 | version = "dev" 10 | description = "let rec generation for MetaOCaml: syntax extension" 11 | requires(ppx_driver) = "letrec compiler-libs" 12 | ppx = "./ppx_letrec.byte" 13 | ) 14 | -------------------------------------------------------------------------------- /lib_test/ackermann.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | let ack x = 9 | let%staged rec ack m = 10 | .< fun n -> .~(if m = 0 then .. 11 | else .< if n = 0 then .~(ack (m - 1)) 1 12 | else .~(ack (m - 1)) (.~(ack m) (n - 1)) >.)>. 13 | in ack x 14 | -------------------------------------------------------------------------------- /lib_test/even_odd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | type eo = Even | Odd 9 | 10 | let evenp_oddp = 11 | let%staged rec eo = function 12 | | Even -> .< fun x -> x = 0 || .~(eo Odd) (x - 1) >. 13 | | Odd -> .< fun x -> x <> 0 && .~(eo Even) (x - 1) >. 14 | in .< (.~(eo Even), .~(eo Odd)) >. 15 | -------------------------------------------------------------------------------- /lib_test/residuals.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Generalization of even/odd to residuals mod n *) 9 | let residuals n = 10 | let%staged rec res i = 11 | if i = 0 then .< fun x -> x = 0 || .~(res (n - 1)) (x - 1) >. 12 | else .< fun x -> x <> 0 && .~(res (i - 1)) (x - 1) >. 13 | in res (n - 1) 14 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin;; 2 | open Ocamlbuild_pack;; 3 | 4 | dispatch begin 5 | function 6 | | After_rules -> 7 | begin match Sys.ocaml_version with 8 | | "5.3.0" -> 9 | copy_rule "attr_support" "lib/attr_support_530.ml" "lib/attr_support.ml"; 10 | flag ["ocaml"; "compile"; "open_print_code"] & S[A"-open"; A"Codelib"]; 11 | | version -> 12 | Printf.ksprintf failwith "Unsupported OCaml version %s" version 13 | end 14 | | _ -> () 15 | end;; 16 | 17 | -------------------------------------------------------------------------------- /lib_test/nested.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Generating nested let-rec bindings *) 9 | let mul = 10 | let%staged rec mul () = 11 | let add = 12 | let%staged rec add () = 13 | .< fun x y -> if x = 0 then y else (.~(mul ()) 1 1) + (.~(add ()) (x - 1) y) >. 14 | in add () 15 | in .< fun x y -> if x = 1 then y else .~add y (.~(mul ()) (x - 1) y) >. 16 | in mul () 17 | -------------------------------------------------------------------------------- /lib_test/test_types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Letrec 9 | 10 | type 'a ntree = 11 | EmptyN 12 | | TreeN of 'a * ('a * 'a) ntree 13 | 14 | type swiv = { swiv: 'a. ('a -> 'a) -> 'a ntree -> 'a ntree } [@@unboxed] 15 | 16 | module Sym_swiv = struct 17 | type _ t = Swiv : swiv t 18 | let eql : type a b. a t -> b t -> (a, b) eql option = 19 | fun Swiv Swiv -> Some Refl 20 | end 21 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "letrec" 3 | synopsis: "Flexible 'let rec' generation for MetaOCaml" 4 | maintainer: "Jeremy Yallop " 5 | authors: "Jeremy Yallop " 6 | homepage: "https://github.com/yallop/metaocaml-letrec" 7 | dev-repo: "git+https://github.com/yallop/metaocaml-letrec.git" 8 | bug-reports: "https://github.com/yallop/metaocaml-letrec/issues" 9 | license: "MIT" 10 | build: [ 11 | [make] 12 | [make "all" "test"] {with-test} 13 | ] 14 | install: [make "install"] 15 | remove: ["ocamlfind" "remove" "letrec"] 16 | depends: [ 17 | "ocamlfind" {build} 18 | "ocamlbuild" {build} 19 | "ocaml-variants" 20 | {= "5.3.0+BER" } 21 | ] 22 | -------------------------------------------------------------------------------- /lib_test/polymorphic.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Test_types 9 | open Sym_swiv 10 | 11 | (* Polymorphic recursion over nested data types *) 12 | 13 | module R = Letrec.Make(Sym_swiv) 14 | 15 | let swiv = 16 | let rhs : type a. R.resolve -> a R.sym -> a code = 17 | fun {R.resolve=swiv} Swiv -> 18 | .< { swiv = fun f -> function 19 | | EmptyN -> 20 | EmptyN 21 | | TreeN (v, t) -> 22 | TreeN (f v, (.~(swiv Swiv)).swiv (fun (x, y) -> (f y, f x)) t)} >. 23 | in 24 | R.letrec {R.rhs} (fun {R.resolve=swiv} -> swiv Swiv) 25 | -------------------------------------------------------------------------------- /lib_test/custom_eq.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2022 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* An artificial example with an index type that doesn't support 9 | OCaml's built-in equality (=) *) 10 | 11 | (* functional representation of 12 | type eo = Even | Odd *) 13 | type eo = { eo: 'a. 'a -> 'a -> 'a } 14 | let eo_eq {eo=l} {eo=r} = l 0 1 = r 0 1 15 | let even = { eo = fun e _ -> e } 16 | and odd = { eo = fun _ o -> o } 17 | 18 | let evenp_oddp = 19 | let%staged[@eq eo_eq] rec eo = fun {eo=i} -> 20 | i (.< fun x -> x = 0 || .~(eo odd) (x - 1) >.) 21 | (.< fun x -> x <> 0 && .~(eo even) (x - 1) >.) 22 | in .< (.~(eo even), .~(eo odd)) >. 23 | -------------------------------------------------------------------------------- /lib/attr_support_530.ml: -------------------------------------------------------------------------------- 1 | let add_attr (type a) s (c : a code) : a code = 2 | let h, e = Obj.magic c in 3 | Obj.magic (h, Ast_helper.Exp.attr e {attr_name = Location.mknoloc s; attr_loc = Location.none; 4 | attr_payload = Parsetree.PStr [];}) 5 | 6 | 7 | let find_attr name attrs = 8 | match List.find (fun {Parsetree.attr_name = {Asttypes.txt}} -> txt = name) attrs with 9 | | { Parsetree.attr_payload = p } -> Some p 10 | | exception Not_found -> None 11 | 12 | let has_attr name attrs = 13 | List.exists (fun {Parsetree.attr_name} -> attr_name.txt = name) attrs 14 | 15 | let remove_attr name attrs = 16 | snd (List.partition (fun {Parsetree.attr_name} -> attr_name.txt = name) attrs) 17 | 18 | let mkletrec binds e = 19 | let open Parsetree in 20 | { pexp_desc = Pexp_let (Recursive, binds, e); 21 | pexp_loc = Location.none; 22 | pexp_loc_stack = []; 23 | pexp_attributes = [] } 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OCAMLBUILD=ocamlbuild -use-ocamlfind -ocamlc '-toolchain metaocaml ocamlc' \ 2 | -ocamlopt '-toolchain metaocaml ocamlopt' 3 | 4 | all: letrec.cma letrec.cmxa ppx_letrec.byte 5 | 6 | test: tests.byte 7 | ./tests.byte 8 | 9 | install: 10 | ocamlfind install letrec META \ 11 | _build/lib/*.cma \ 12 | _build/lib/*.cmx \ 13 | _build/lib/*.cmxa \ 14 | _build/lib/*.a \ 15 | _build/lib/*.cmi \ 16 | _build/lib/*.mli \ 17 | _build/ppx/ppx_letrec.byte 18 | 19 | uninstall: 20 | ocamlfind remove letrec 21 | 22 | clean: 23 | $(OCAMLBUILD) -clean 24 | 25 | %.cma: 26 | $(OCAMLBUILD) -use-ocamlfind $@ 27 | 28 | %.cmxa: 29 | $(OCAMLBUILD) -use-ocamlfind $@ 30 | 31 | %.native: 32 | $(OCAMLBUILD) -use-ocamlfind $@ 33 | 34 | %.byte: 35 | $(OCAMLBUILD) -use-ocamlfind $@ 36 | 37 | tests.byte: letrec.cma lib_test/tests.ml 38 | 39 | .PHONY: all clean test 40 | -------------------------------------------------------------------------------- /lib_test/tests.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** NB: print_code is imported from a command-line '-open' option: 9 | see _tags / myocamlbuild.ml *) 10 | 11 | let () = begin 12 | let pr fmt = Format.fprintf Format.std_formatter fmt in 13 | 14 | pr "(* Ackermann function (4) *)@\n"; 15 | pr "%a@." print_code (Ackermann.ack 4); 16 | 17 | pr "(* Even/odd *)@\n"; 18 | pr "%a@." print_code Even_odd.evenp_oddp; 19 | 20 | pr "(* Residuals modulo n *)@\n"; 21 | pr "%a@." print_code (Residuals.residuals 4); 22 | 23 | pr "(* Polymorphic recursion over nested types *)@\n"; 24 | pr "%a@." print_code Polymorphic.swiv; 25 | 26 | pr "(* Nested let-rec generation *)@\n"; 27 | pr "%a@." print_code Nested.mul; 28 | 29 | pr "(* Mutual recursion with non-functions *)@\n"; 30 | pr "%a@." print_code Recursive_values.(values 4); 31 | 32 | pr "(* Custom equality for indexes *)@\n"; 33 | pr "%a@." print_code Custom_eq.evenp_oddp; 34 | end 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Jeremy Yallop 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: MetaOCaml 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | workflow_dispatch: 8 | 9 | jobs: 10 | install: 11 | name: Install 12 | runs-on: ${{ matrix.os }} 13 | env: 14 | ACTIONS_ALLOW_UNSECURE_COMMANDS: 'true' 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | ocaml-compiler: ["ocaml-variants.5.3.0+BER"] 19 | os: [ubuntu-latest] 20 | steps: 21 | 22 | - name: Checkout code 23 | uses: actions/checkout@v2 24 | 25 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 26 | uses: ocaml/setup-ocaml@v3 27 | if: steps.cache-dependencies.outputs.cache-hit != 'true' 28 | with: 29 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 30 | dune-cache: true 31 | opam-repositories: | 32 | default: https://github.com/ocaml/opam-repository.git 33 | metaocaml: https://github.com/metaocaml/metaocaml-opam.git 34 | beta: https://github.com/ocaml/ocaml-beta-repository.git 35 | 36 | - name: Deps 37 | run: | 38 | opam install --yes ocamlfind ocamlbuild 39 | 40 | - name: Build 41 | run: | 42 | opam exec -- make 43 | 44 | - name: Test 45 | run: | 46 | opam exec -- make test 47 | -------------------------------------------------------------------------------- /lib/letrec.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | 9 | (** Simple interface for generating mutually-recursive functions, for 10 | the case where recursion is monomorphic, all the functions have 11 | the same type, and indexes support polymorphic equality. *) 12 | val letrec : ?equal:('a -> 'a -> bool) -> 13 | (('a -> 'b code) -> 'a -> 'b code) -> 14 | (('a -> 'b code) -> 'c code) -> 'c code 15 | 16 | 17 | (** More elaborate interface for generating mutually-recursive 18 | functions. Supports polymorphic recursion, mutually-recursive 19 | functions of different types, and non-standard definitions of 20 | equality. *) 21 | 22 | (** The equality GADT *) 23 | type (_,_) eql = Refl : ('a,'a) eql 24 | 25 | 26 | (** The SYMBOL interface to parameterized types with equality *) 27 | module type SYMBOL = sig 28 | type _ t 29 | val eql : 'a t -> 'b t -> ('a, 'b) eql option 30 | end 31 | 32 | (** The general let-rec interface *) 33 | module type S = sig 34 | type 'a sym 35 | type resolve = { resolve: 'a.'a sym -> 'a code } 36 | type rhs = { rhs: 'a.resolve -> 'a sym -> 'a code } 37 | 38 | val letrec : rhs -> (resolve -> 'b code) -> 'b code 39 | end 40 | 41 | (** Build an instance of S from an instance of SYMBOL *) 42 | module Make(Sym: SYMBOL) : S with type 'a sym = 'a Sym.t 43 | -------------------------------------------------------------------------------- /ppx/ppx_letrec.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Lightweight syntactic sugar for the staged 'let rec'. 3 | 4 | let rec%staged f = e in e' 5 | ~> 6 | Letrec.letrec (fun f -> e) (fun f -> e') 7 | 8 | let rec%staged[@eq p] f = e in e' 9 | ~> 10 | Letrec.letrec ~equal:p (fun f -> e) (fun f -> e') 11 | 12 | *) 13 | 14 | (* TODO: support for the fancier polymorphic letrec *) 15 | 16 | open Ast_mapper 17 | open Ast_helper 18 | open Asttypes 19 | open Parsetree 20 | 21 | let rec filter_map f = function 22 | | [] -> [] 23 | | x :: xs -> match f x with None -> filter_map f xs | Some y -> y :: filter_map f xs 24 | 25 | (* TODO: more careful handling of locations *) 26 | let map_let mapper = function 27 | | { pexp_desc = Pexp_extension ({txt = "staged"; loc}, str) ; pexp_attributes } -> 28 | let str = default_mapper.payload mapper str in 29 | begin match str with 30 | | PStr [ {pstr_desc = 31 | Pstr_eval ({pexp_desc = Pexp_let (Recursive, vbs, body)} as e,_)} ] -> 32 | begin match vbs with 33 | | [{ pvb_pat=({ppat_desc=Ppat_var _} as x); 34 | pvb_expr = rhs; pvb_attributes }] -> 35 | let eq = match Attr_support.find_attr "eq" pvb_attributes with 36 | | None -> [] 37 | | Some (PStr [{pstr_desc = Pstr_eval (eq,_)}]) -> [Labelled "equal", eq] 38 | | Some _ -> failwith "the attribute [@eq e] is of the wrong form" 39 | in 40 | let params = [{ pparam_loc = Location.none; 41 | pparam_desc = Pparam_val (Nolabel, None, x) } ] in 42 | let id = Location.mknoloc 43 | (Option.get (Longident.unflatten ["Letrec";"letrec"])) in 44 | {e with pexp_attributes ; pexp_desc = 45 | Pexp_apply ({e with pexp_desc = Pexp_ident id}, 46 | eq @ 47 | [(Nolabel, {rhs with pexp_desc = 48 | Pexp_function (params, None, Pfunction_body rhs)}); 49 | (Nolabel, {rhs with pexp_desc = 50 | Pexp_function (params, None, Pfunction_body body)})])} 51 | | [_] -> 52 | failwith "let%staged requires a binding of the form: let%staged rec f = ..." 53 | | _ -> 54 | failwith "let%staged must be given exactly one binding" 55 | end 56 | | str -> 57 | failwith "let%staged requires a let binding" 58 | 59 | end 60 | | e -> default_mapper.expr mapper e 61 | 62 | let () = register "staged" (fun _ -> { default_mapper with expr = map_let }) 63 | -------------------------------------------------------------------------------- /lib/letrec.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* TODO: compute cliques so that 'ack 3' generates 9 | 10 | let f4 n = n + 1 in 11 | let rec f3 n = if n = 0 then f4 1 else f4 (f3 (n - 1)) in 12 | let rec f2 n = if n = 0 then f3 1 else f3 (f2 (n - 1)) in 13 | let rec f1 n = if n = 0 then f2 1 else f2 (f1 (n - 1)) in 14 | in f1 15 | *) 16 | 17 | type (_,_) eql = Refl : ('a,'a) eql 18 | 19 | module type SYMBOL = sig 20 | type _ t 21 | val eql : 'a t -> 'b t -> ('a, 'b) eql option 22 | end 23 | 24 | module type S = sig 25 | type 'a sym 26 | type resolve = { resolve: 'a. 'a sym -> 'a code } 27 | type rhs = { rhs: 'a.resolve -> 'a sym -> 'a code } 28 | 29 | val letrec : rhs -> (resolve -> 'b code) -> 'b code 30 | end 31 | 32 | module Make(Sym: SYMBOL) : S with type 'a sym = 'a Sym.t = 33 | struct 34 | type 'a sym = 'a Sym.t 35 | type resolve = { resolve: 'a. 'a sym -> 'a code } 36 | type rhs = { rhs: 'a.resolve -> 'a sym -> 'a code } 37 | 38 | type table = 39 | Nil : table 40 | | Cons : 'a sym * 'a code * table -> table 41 | 42 | let rec assoc : type a. a sym -> table -> a code = 43 | fun sym table -> match table with 44 | Nil -> raise Not_found 45 | | Cons (k, v, xs) -> 46 | begin match Sym.eql k sym with 47 | Some Refl -> v 48 | | None -> assoc sym xs 49 | end 50 | 51 | let push sym code table = table := Cons (sym, code, !table) 52 | 53 | let letrec {rhs} body = 54 | let table = ref Nil in 55 | Genletrec.genletrec_locus @@ fun locus -> 56 | let rec resolver = 57 | { resolve = fun symbol -> 58 | try assoc symbol !table with 59 | Not_found -> 60 | Genletrec.genletrec locus 61 | (fun x -> 62 | push symbol x table; 63 | rhs resolver symbol) } 64 | in 65 | body resolver 66 | end 67 | 68 | (* Define a simple 'letrec' for monomorphic recursion 69 | in terms of the more general implementation *) 70 | let letrec : type a b c. 71 | ?equal:(a -> a -> bool) -> 72 | ((a -> b code) -> a -> b code) -> 73 | ((a -> b code) -> c code) -> c code = 74 | fun ?(equal=(=)) rhs body -> 75 | let module N = struct type _ t = T : a -> b t end in 76 | let module Sym : SYMBOL with type 'a t = 'a N.t = 77 | struct 78 | type 'a t = 'a N.t 79 | let eql : type a b. a t -> b t -> (a, b) eql option = 80 | fun (N.T x) (N.T y) -> match equal x y with 81 | | true -> Some Refl 82 | | false -> None 83 | end in 84 | let module R = Make(Sym) in 85 | let resolve r sym = r.R.resolve (N.T sym) in 86 | let rhs (type d) r (N.T (sym : a) : d R.sym) : d code = 87 | rhs (resolve r) sym in 88 | R.letrec {R.rhs} (fun r -> body (resolve r)) 89 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # metaocaml-letrec: flexible 'let rec' generation 2 | 3 | ![GitHub Actions status](https://github.com/yallop/metaocaml-letrec/workflows/test/badge.svg) 4 | 5 | In typed MetaML-based systems such as MetaOCaml it is difficult or impossible to generate mutually-recursive binding groups whose size is not known in advance. For example, suppose (following an example of Neil Jones expounded by [Oleg][oleg]) that you want to [specialize the Ackermann function][oleg-ltu-ackermann-comment] 6 | 7 | ```ocaml 8 | let rec ack m n = 9 | if m = 0 then n+1 else 10 | if n = 0 then ack (m-1) 1 else 11 | ack (m-1) (ack m (n-1)) 12 | ``` 13 | 14 | with the first argument equal to `2`. Ideally, you might like to generate the following code, with three mutually recursive bindings and all the recursive calls specialized: 15 | 16 | ```ocaml 17 | let rec ack_2 n = if n = 0 then ack_1 1 else ack_1 (ack_2 (n-1)) 18 | and ack_1 n = if n = 0 then ack_0 1 else ack_0 (ack_1 (n-1)) 19 | and ack_0 n = n+1 20 | ``` 21 | 22 | With `metaocaml-letrec` you can generate exactly that code, modulo naming, by [annotating the original definition of `ack` as follows](lib_test/ackermann.ml) (and passing the argument `2`): 23 | 24 | ```ocaml 25 | let%staged rec ack m = 26 | .< fun n -> .~(if m = 0 then .. else 27 | .< if n = 0 then .~(ack (m-1)) 1 else 28 | .~(ack (m-1)) (.~(ack m) (n-1)) >.)>. 29 | ``` 30 | 31 | and, in general, `ack n` will generate a `let rec` group of `n+1` bindings. 32 | 33 | More generally, `metocaml-letrec` treats a `let rec` binding as an indexed family, where the argument to the generating function is the index. In the `ack` example, the index `m` is a simple integer; in general it may be a richer object, making it possible to generate arbitrary patterns of recursion, including 34 | 35 | * [nested let rec bindings](lib_test/nested.ml) 36 | * [polymorphic recursion](lib_test/polymorphic.ml) 37 | * [recursion with non-function values](lib_test/recursive_values.ml) 38 | * recursion where the bindings have different types 39 | 40 | and many more examples. 41 | 42 | ### Installation 43 | 44 | `metaocaml-letrec` works on various versions of [BER MetaOCaml][ber-metaocaml], which are [available via `OPAM`][metaocaml-switch]: 45 | 46 | ``` 47 | opam switch install 4.14.1+BER 48 | eval $(opam env) 49 | ``` 50 | 51 | Within this `4.14.1+BER` switch the `metaocaml-letrec` package can be installed as follows: 52 | 53 | ``` 54 | opam remote add metaocaml git+https://github.com/metaocaml/metaocaml-opam.git 55 | opam install letrec 56 | ``` 57 | 58 | ### Further reading 59 | 60 | The following paper has more details about the design and implementation of `metaocaml-letrec`: 61 | 62 |    [Generating mutually recursive definitions][pepm19-paper] 63 |    Jeremy Yallop and Oleg Kiselyov 64 |    [PEPM 2019][pepm-2019] 65 | 66 | [oleg-ltu-ackermann-comment]: http://lambda-the-ultimate.org/node/4039#comment-61431 67 | [oleg]: http://okmij.org/ftp/ 68 | [ber-metaocaml]: http://okmij.org/ftp/ML/MetaOCaml.html 69 | [metaocaml-switch]: https://github.com/ocaml/opam-repository/blob/master/packages/ocaml-variants/ocaml-variants.4.14.1+BER/opam 70 | [pepm-2019]: https://popl19.sigplan.org/track/pepm-2019-papers 71 | [pepm19-paper]: https://www.cl.cam.ac.uk/~jdy22/papers/generating-mutually-recursive-definitions-short-paper.pdf 72 | -------------------------------------------------------------------------------- /lib/genletrec.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module Rewrite : sig 9 | val typed : 'a code -> 'a code 10 | end = 11 | struct 12 | open Ast_mapper 13 | open Asttypes 14 | open Parsetree 15 | 16 | let letrec : (string * expression) list -> expression -> expression = 17 | fun bindings e -> 18 | let binding (x, e) = 19 | { pvb_pat = Ast_helper.Pat.var (Location.mknoloc x); 20 | pvb_constraint = None; 21 | pvb_expr = e; 22 | pvb_attributes = []; 23 | pvb_loc = Location.none } in 24 | match bindings with 25 | | [] -> e 26 | | _ -> Attr_support.mkletrec (List.map binding bindings) e 27 | 28 | let underef : expression -> expression = 29 | let rec m = { default_mapper with 30 | expr = fun map e -> 31 | match e with 32 | | { pexp_desc = 33 | Pexp_apply (_, [_, ({pexp_desc=Pexp_ident _} as e)]); 34 | pexp_attributes=ats } 35 | when Attr_support.has_attr "letrec:deref" ats -> 36 | {e with pexp_attributes = Attr_support.remove_attr "letrec:deref" ats} 37 | | e -> default_mapper.expr map e 38 | } in 39 | m.expr m 40 | 41 | type letrec_expression = 42 | Init of expression (* let x = ref dummy in e *) 43 | | Set of string * expression * expression (* x := rhs; e *) 44 | | Body of expression 45 | 46 | let rec classify_expression : expression -> letrec_expression = function 47 | | { pexp_attributes=ats } as e 48 | when Attr_support.has_attr "letrec:body" ats -> 49 | Body {e with pexp_attributes = Attr_support.remove_attr "letrec:body" ats} 50 | 51 | | {pexp_desc=Pexp_let (_, [_], e'); pexp_attributes=ats} 52 | when Attr_support.has_attr "letrec:var" ats -> 53 | Init e' 54 | | {pexp_desc = 55 | Pexp_sequence ({pexp_desc=Pexp_apply 56 | (_, [(_,{pexp_desc=Pexp_ident 57 | {txt=Longident.Lident x}}); 58 | (_,rhs)]); 59 | pexp_attributes=ats}, 60 | e')} 61 | when Attr_support.has_attr "letrec:set" ats -> 62 | Set (x, rhs, e') 63 | | _ -> failwith "translation failure" 64 | 65 | let rec untyped' : (string * expression) list -> expression -> expression = 66 | fun binds exp -> match classify_expression exp with 67 | Init e -> untyped' binds e 68 | | Set (x, rhs, e) -> untyped' ((x,underef rhs) :: binds) e 69 | | Body e -> letrec binds (underef e) 70 | 71 | let untyped : expression -> expression = 72 | fun e -> untyped' [] e 73 | 74 | let typed : type a. a code -> a code = 75 | fun c -> let x, y = Obj.magic c in Obj.magic (x, untyped y) 76 | end 77 | 78 | type locus_t = int 79 | let counter = ref 0 80 | let new_locus () = incr counter; !counter 81 | 82 | type _ Effect.t += 83 | MakeSlot : locus_t -> ('a ref code * 'a code) Effect.t 84 | | SetSlot : (locus_t * 'a ref code * 'a code) -> unit Effect.t 85 | 86 | let genletrec_locus : type a. (locus_t -> a code) -> a code 87 | = fun body -> 88 | let loc = new_locus () in 89 | Rewrite.typed @@ match body loc with 90 | | effect MakeSlot loc', k when loc = loc' -> 91 | Attr_support.add_attr "letrec:var" 92 | .< let x = Obj.magic () (* ref (fun _ -> assert false) *) 93 | in .~(Effect.Deep.continue k (.< x >., 94 | Attr_support.add_attr "letrec:deref" ..)) >. 95 | | effect SetSlot (loc', lhs, rhs), k when loc = loc' -> 96 | let set = Attr_support.add_attr "letrec:set" .< .~lhs := .~rhs >. in 97 | .< (.~set ; .~(Effect.Deep.continue k ())) >. 98 | | e -> 99 | Attr_support.add_attr "letrec:body" e 100 | 101 | let genletrec : type a b. locus_t -> (a code -> a code) -> a code 102 | = fun locus f -> 103 | let lhs, use = Effect.perform (MakeSlot locus) in 104 | let () = Effect.perform (SetSlot (locus, lhs, f use)) in 105 | use 106 | --------------------------------------------------------------------------------