+14

lib/combin.ml

View file Reviewed

··· 61 61 in 62 62 Printf.sprintf "parse error at %s%s: expected %s" 63 63 pos_str context (String.concat " or " e.expected) 64 64 + 65 65 + module Memo : sig 66 66 + type 'a table 67 67 + val create : unit -> 'a table 68 68 + val find : 'a table -> string -> int -> 'a option 69 69 + val add : 'a table -> string -> int -> 'a -> unit 70 70 + end = struct 71 71 + type 'a table = (string * int, 'a) Hashtbl.t 72 72 + let create () = Hashtbl.create 64 73 73 + let find tbl name pos = Hashtbl.find_opt tbl (name, pos) 74 74 + let add tbl name pos v = Hashtbl.replace tbl (name, pos) v 75 75 + end 76 76 + 77 77 + type 'a memo_table = ('a * Char_input.t, error) result Memo.table

+3

src/check.ml

View file Reviewed

··· 42 42 | ChainR1 { p; _ } -> nullable p 43 43 | Choice { ps; _ } -> List.exists nullable ps 44 44 | Label { p; _ } -> nullable p 45 45 + | Memo { p; _ } -> nullable p 45 46 | Fix _ -> false 46 47 | Var { name; _ } -> 47 48 (match List.assoc_opt name env with ··· 93 94 | ChainR { p; _ } -> check path p 94 95 | ChainR1 { p; _ } -> check path p 95 96 | Choice { ps; _ } -> List.find_map (check path) ps 97 97 + | Memo { p; _ } -> check path p 96 98 | Fix _ -> None 97 99 | Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _ 98 100 | OneOf _ | NoneOf _ | Cut _ -> None ··· 146 148 | ChainR1 { p; op; _ } -> check_expr env p @ check_expr env op 147 149 | Choice { ps; _ } -> List.concat_map (check_expr env) ps 148 150 | Label { p; _ } -> check_expr env p 151 151 + | Memo { p; _ } -> check_expr env p 149 152 | Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _ 150 153 | OneOf _ | NoneOf _ | Cut _ | Fix _ | Var _ -> [] 151 154

+13 -1

src/codegen.ml

View file Reviewed

··· 379 379 | Ok _ as r -> r 380 380 | Error e -> Error { e with Combin.expected = [[%e estring ~loc label]] }] 381 381 382 382 + | Memo { name; p; loc } -> 383 383 + let p_code = compile ~loc env p in 384 384 + let name_expr = estring ~loc name in 385 385 + [%expr 386 386 + let pos = I.position input in 387 387 + match Combin.Memo.find _memo [%e name_expr] pos with 388 388 + | Some r -> r 389 389 + | None -> 390 390 + let r = [%e p_code] in 391 391 + Combin.Memo.add _memo [%e name_expr] pos r; 392 392 + r] 393 393 + 382 394 | Fix { body; _ } -> 383 395 [%expr 384 396 let rec parser_fix = [%e body] in 385 397 parser_fix input] 386 398 387 399 | Var { name; loc } -> 388 388 - [%expr [%e evar ~loc name] (module I) input] 400 400 + [%expr [%e evar ~loc name] (module I) _memo input] 389 401 390 402 and compile_committed_alt ~loc env p q p_first q_first = 391 403 let p_code = compile ~loc env p in

+1

src/first_set.ml

View file Reviewed

··· 70 70 | ChainR1 { p; _ } -> compute env p 71 71 | Choice { ps; _ } -> List.fold_left (fun acc p -> union acc (compute env p)) empty ps 72 72 | Label { p; _ } -> compute env p 73 73 + | Memo { p; _ } -> compute env p 73 74 | Fix { names; _ } -> 74 75 List.fold_left (fun acc name -> 75 76 match List.assoc_opt name env with

+2

src/ir.ml

View file Reviewed

··· 37 37 | ChainR1 of { loc : loc; p : expr; op : expr } 38 38 | Choice of { loc : loc; ps : expr list; label : string option } 39 39 | Label of { loc : loc; p : expr; label : string } 40 40 + | Memo of { loc : loc; name : string; p : expr } 40 41 | Fix of { loc : loc; arity : int; names : string list; body : Ppxlib.expression } 41 42 | Var of { loc : loc; name : string } 42 43 ··· 89 90 | ChainR1 { loc; _ } -> loc 90 91 | Choice { loc; _ } -> loc 91 92 | Label { loc; _ } -> loc 93 93 + | Memo { loc; _ } -> loc 92 94 | Fix { loc; _ } -> loc 93 95 | Var { loc; _ } -> loc

+9 -4

src/ppx_combin.ml

View file Reviewed

··· 117 117 Ir.Map { loc; f; p = expr_to_ir ~loc p } 118 118 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<?>"; _ }; _ }, [(Nolabel, p); (Nolabel, { pexp_desc = Pexp_constant (Pconst_string (label, _, _)); _ })]) -> 119 119 Ir.Label { loc; p = expr_to_ir ~loc p; label } 120 120 + | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "memo"; _ }; _ }, [(Nolabel, { pexp_desc = Pexp_constant (Pconst_string (name, _, _)); _ }); (Nolabel, p)]) -> 121 121 + Ir.Memo { loc; name; p = expr_to_ir ~loc p } 120 122 121 123 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fix"; _ }; _ }, [(Nolabel, fn)]) -> 122 124 let (pats, body) = extract_fun_params fn in ··· 157 159 Location.raise_errorf ~loc:err_loc "%s" msg 158 160 ) errors; 159 161 let body = Codegen.compile ~loc [] ir in 160 160 - [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> [%e body]] 162 162 + [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> 163 163 + let _memo = Combin.Memo.create () in 164 164 + [%e body]] 161 165 162 166 let parser_extension = 163 167 Extension.V3.declare ··· 183 187 let bindings = extract_let_bindings str_items in 184 188 let compiled = List.map (fun (name, expr, binding_loc) -> 185 189 let ir = expr_to_ir ~loc:binding_loc expr in 186 186 - let errors = Check.check_expr [] ir in 190 190 + let memoized_ir = Ir.Memo { loc = binding_loc; name; p = ir } in 191 191 + let errors = Check.check_expr [] memoized_ir in 187 192 List.iter (fun e -> 188 193 let err_loc = Check.error_loc e in 189 194 let msg = Check.format_error e in 190 195 Location.raise_errorf ~loc:err_loc "%s" msg 191 196 ) errors; 192 192 - let body = Codegen.compile ~loc:binding_loc [] ir in 193 193 - let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> [%e body]] in 197 197 + let body = Codegen.compile ~loc:binding_loc [] memoized_ir in 198 198 + let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) _memo (input : inp) -> [%e body]] in 194 199 Ast_builder.Default.value_binding ~loc:binding_loc 195 200 ~pat:(Ast_builder.Default.pvar ~loc:binding_loc name) 196 201 ~expr:func