From 55018aacc74b4ee59064e1b7faf93d5241bb8961 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 18 Sep 2026 11:21:45 +0200 Subject: [PATCH 1/4] Add Copy tag operation to runtime and PPX Copy (dst, src) copies the raw contents of one memory cell into another, preserving the position/value encoding. The Laurikari TDFA construction needs it to preserve a recorded position when a parallel NFA path is about to overwrite the source register. Not emitted by the compiler yet, so generated code is unchanged. (cherry picked from commit 8ab62944 without its oracle hunk) Co-Authored-By: Claude Fable 5.1 --- src/compiler/sedlex.ml | 11 ++++++++--- src/compiler/sedlex.mli | 4 ++++ src/lib/sedlexing.ml | 4 ++++ src/lib/sedlexing.mli | 5 +++++ src/syntax/ppx_sedlex.ml | 5 +++++ 5 files changed, 26 insertions(+), 3 deletions(-) diff --git a/src/compiler/sedlex.ml b/src/compiler/sedlex.ml index 7a28c66f..ae5b174b 100644 --- a/src/compiler/sedlex.ml +++ b/src/compiler/sedlex.ml @@ -74,7 +74,10 @@ module Cset = Cset (* NFA *) -type tag_op = Set_position of int | Set_value of int * int +type tag_op = + | Set_position of int + | Set_value of int * int + | Copy of int * int type node = { id : int; (** Unique identifier, used for sorting transitions by target. *) @@ -246,12 +249,12 @@ let dedup_tags tags = match Hashtbl.find_opt dominated cell with | Some v when v <= value -> () | _ -> Hashtbl.replace dominated cell value) - | Set_position _ -> ()) + | Set_position _ | Copy _ -> ()) tags; List.filter (function | Set_value (cell, value) -> Hashtbl.find dominated cell = value - | Set_position _ -> true) + | Set_position _ | Copy _ -> true) tags (* [transition state] computes all outgoing DFA transitions from a DFA state. @@ -616,6 +619,8 @@ let dfa_to_dot dfa = let tag_op_to_string = function | Set_position t -> "t" ^ string_of_int t | Set_value (c, v) -> "d" ^ string_of_int c ^ "=" ^ string_of_int v + | Copy (dst, src) -> + "t" ^ string_of_int dst ^ "<-t" ^ string_of_int src in let label = if tags = [] then label diff --git a/src/compiler/sedlex.mli b/src/compiler/sedlex.mli index 01ac04b8..94c649ee 100644 --- a/src/compiler/sedlex.mli +++ b/src/compiler/sedlex.mli @@ -65,6 +65,10 @@ type tag_op = | Set_value of int * int (** [Set_value (cell, v)]: record integer [v] in memory cell [cell] (used for or-pattern discriminators). *) + | Copy of int * int + (** [Copy (dst, src)]: copy the contents of cell [src] into cell [dst]. + Emitted when determinization must preserve a position that a parallel + NFA path is about to overwrite. *) (** [bind r] wraps [r] with start/end tag epsilon nodes. Returns [(wrapped_regexp, start_tag, end_tag)] where [start_tag] and [end_tag] are diff --git a/src/lib/sedlexing.ml b/src/lib/sedlexing.ml index 653a9555..6da2fc82 100644 --- a/src/lib/sedlexing.ml +++ b/src/lib/sedlexing.ml @@ -304,6 +304,10 @@ let __private__set_mem_value lexbuf i v = assert (v >= 0); lexbuf.__private__mem.(i) <- -(v + 2) +(* Copies the raw cell contents, preserving the position/value encoding. *) +let __private__copy_mem lexbuf dst src = + lexbuf.__private__mem.(dst) <- lexbuf.__private__mem.(src) + (* Returns position relative to token start, for use in sub_lexeme. *) let __private__mem_pos lexbuf i = lexbuf.__private__mem.(i) - lexbuf.start_pos diff --git a/src/lib/sedlexing.mli b/src/lib/sedlexing.mli index dcba7a6f..4f6ff87d 100644 --- a/src/lib/sedlexing.mli +++ b/src/lib/sedlexing.mli @@ -261,6 +261,11 @@ val __private__set_mem_pos : lexbuf -> int -> unit *) val __private__set_mem_value : lexbuf -> int -> int -> unit +(** [__private__copy_mem lexbuf dst src] copies the contents of cell [src] into + cell [dst], preserving the position/value encoding. Used by [Copy] tag + operations on DFA transitions. *) +val __private__copy_mem : lexbuf -> int -> int -> unit + (** [__private__mem_pos lexbuf i] returns the position stored in cell [i], as an offset relative to the start of the current token. *) val __private__mem_pos : lexbuf -> int -> int diff --git a/src/syntax/ppx_sedlex.ml b/src/syntax/ppx_sedlex.ml index 9fb85245..c0ffde8e 100644 --- a/src/syntax/ppx_sedlex.ml +++ b/src/syntax/ppx_sedlex.ml @@ -260,6 +260,11 @@ let gen_tag_ops lexbuf (ops : Sedlex.tag_op list) cont = [%expr Sedlexing.__private__set_mem_value [%e lexbuf] [%e eint ~loc cell] [%e eint ~loc value]; + [%e acc]] + | Copy (dst, src) -> + [%expr + Sedlexing.__private__copy_mem [%e lexbuf] [%e eint ~loc dst] + [%e eint ~loc src]; [%e acc]]) ops cont From 9e6ccdbf709165c21f842fd656a74722c5090f2c Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 18 Sep 2026 13:47:26 +0200 Subject: [PATCH 2/4] Use inline records for tag_op constructors Named fields instead of positional arguments: [Set_position {dst}], [Set_value {dst; value}], [Copy {dst; src}]. The determinization rewrite manipulates these in several places (allocation, register moves, renaming), where [dst] and [src] read better than tuple positions. No behavior change. (cherry picked from commit abf8efa, redone on the pre-rewrite code) Co-Authored-By: Claude Fable 5.1 --- src/compiler/sedlex.ml | 31 ++++++++++++++++--------------- src/compiler/sedlex.mli | 16 ++++++++-------- src/syntax/ppx_sedlex.ml | 16 ++++++++-------- 3 files changed, 32 insertions(+), 31 deletions(-) diff --git a/src/compiler/sedlex.ml b/src/compiler/sedlex.ml index ae5b174b..e02b6a12 100644 --- a/src/compiler/sedlex.ml +++ b/src/compiler/sedlex.ml @@ -75,9 +75,9 @@ module Cset = Cset (* NFA *) type tag_op = - | Set_position of int - | Set_value of int * int - | Copy of int * int + | Set_position of { dst : int } + | Set_value of { dst : int; value : int } + | Copy of { dst : int; src : int } type node = { id : int; (** Unique identifier, used for sorting transitions by target. *) @@ -175,10 +175,10 @@ let bind r = let start_tag = new_tag () in let end_tag = new_tag () in let wrapped succ = - let end_node = new_tagged_node (Set_position end_tag) in + let end_node = new_tagged_node (Set_position { dst = end_tag }) in end_node.eps <- [succ]; let inner = r end_node in - let start_node = new_tagged_node (Set_position start_tag) in + let start_node = new_tagged_node (Set_position { dst = start_tag }) in start_node.eps <- [inner]; start_node in @@ -188,7 +188,7 @@ let bind_start_only r = let start_tag = new_tag () in let wrapped succ = let inner = r succ in - let start_node = new_tagged_node (Set_position start_tag) in + let start_node = new_tagged_node (Set_position { dst = start_tag }) in start_node.eps <- [inner]; start_node in @@ -197,7 +197,7 @@ let bind_start_only r = let bind_end_only r = let end_tag = new_tag () in let wrapped succ = - let end_node = new_tagged_node (Set_position end_tag) in + let end_node = new_tagged_node (Set_position { dst = end_tag }) in end_node.eps <- [succ]; r end_node in @@ -207,7 +207,7 @@ let new_disc_cell () = new_tag () let bind_disc r cell value = let wrapped succ = - let disc_node = new_tagged_node (Set_value (cell, value)) in + let disc_node = new_tagged_node (Set_value { dst = cell; value }) in disc_node.eps <- [succ]; r disc_node in @@ -245,15 +245,15 @@ let dedup_tags tags = let dominated = Hashtbl.create 4 in List.iter (function - | Set_value (cell, value) -> ( - match Hashtbl.find_opt dominated cell with + | Set_value { dst; value } -> ( + match Hashtbl.find_opt dominated dst with | Some v when v <= value -> () - | _ -> Hashtbl.replace dominated cell value) + | _ -> Hashtbl.replace dominated dst value) | Set_position _ | Copy _ -> ()) tags; List.filter (function - | Set_value (cell, value) -> Hashtbl.find dominated cell = value + | Set_value { dst; value } -> Hashtbl.find dominated dst = value | Set_position _ | Copy _ -> true) tags @@ -617,9 +617,10 @@ let dfa_to_dot dfa = (fun (cset, target, tags) -> let label = cset_to_label cset in let tag_op_to_string = function - | Set_position t -> "t" ^ string_of_int t - | Set_value (c, v) -> "d" ^ string_of_int c ^ "=" ^ string_of_int v - | Copy (dst, src) -> + | Set_position { dst } -> "t" ^ string_of_int dst + | Set_value { dst; value } -> + "d" ^ string_of_int dst ^ "=" ^ string_of_int value + | Copy { dst; src } -> "t" ^ string_of_int dst ^ "<-t" ^ string_of_int src in let label = diff --git a/src/compiler/sedlex.mli b/src/compiler/sedlex.mli index 94c649ee..686454d0 100644 --- a/src/compiler/sedlex.mli +++ b/src/compiler/sedlex.mli @@ -59,14 +59,14 @@ val intersection : regexp -> regexp -> regexp option (** Tag operations emitted on DFA transitions. *) type tag_op = - | Set_position of int - (** [Set_position i]: record the current lexbuf position in memory cell - [i]. *) - | Set_value of int * int - (** [Set_value (cell, v)]: record integer [v] in memory cell [cell] (used - for or-pattern discriminators). *) - | Copy of int * int - (** [Copy (dst, src)]: copy the contents of cell [src] into cell [dst]. + | Set_position of { dst : int } + (** [Set_position {dst}]: record the current lexbuf position in memory + cell [dst]. *) + | Set_value of { dst : int; value : int } + (** [Set_value {dst; value}]: record integer [value] in memory cell [dst] + (used for or-pattern discriminators). *) + | Copy of { dst : int; src : int } + (** [Copy {dst; src}]: copy the contents of cell [src] into cell [dst]. Emitted when determinization must preserve a position that a parallel NFA path is about to overwrite. *) diff --git a/src/syntax/ppx_sedlex.ml b/src/syntax/ppx_sedlex.ml index c0ffde8e..add338d7 100644 --- a/src/syntax/ppx_sedlex.ml +++ b/src/syntax/ppx_sedlex.ml @@ -243,25 +243,25 @@ let call_state lexbuf (auto : Sedlex.dfa) state = else appfun (state_fun state) [lexbuf] (* [gen_tag_ops lexbuf ops cont] wraps [cont] in a sequence of tag - operation calls. Each [Set_position t] becomes a call to - [__private__set_mem_pos], and each [Set_value (cell, v)] becomes a call to - [__private__set_mem_value]. Operations are folded right so they execute + operation calls. Each [Set_position {dst}] becomes a call to + [__private__set_mem_pos], and each [Set_value {dst; value}] becomes a call + to [__private__set_mem_value]. Operations are folded right so they execute before [cont]. *) let gen_tag_ops lexbuf (ops : Sedlex.tag_op list) cont = let loc = default_loc in List.fold_right (fun (op : Sedlex.tag_op) acc -> match op with - | Set_position t -> + | Set_position { dst } -> [%expr - Sedlexing.__private__set_mem_pos [%e lexbuf] [%e eint ~loc t]; + Sedlexing.__private__set_mem_pos [%e lexbuf] [%e eint ~loc dst]; [%e acc]] - | Set_value (cell, value) -> + | Set_value { dst; value } -> [%expr - Sedlexing.__private__set_mem_value [%e lexbuf] [%e eint ~loc cell] + Sedlexing.__private__set_mem_value [%e lexbuf] [%e eint ~loc dst] [%e eint ~loc value]; [%e acc]] - | Copy (dst, src) -> + | Copy { dst; src } -> [%expr Sedlexing.__private__copy_mem [%e lexbuf] [%e eint ~loc dst] [%e eint ~loc src]; From 17618410f0f4fc01ba303a426f1259aa46f9c524 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 18 Sep 2026 13:49:31 +0200 Subject: [PATCH 3/4] Resolve rule priority in the compiler: accept replaces finals A DFA state's [finals : bool array] becomes [accept : accept option], with [accept = { rule; final_ops }]. For an accepting state it holds the lowest-numbered accepting rule, which the PPX used to recompute from [finals] in [best_final], and the tag operations to run on entry just before [Sedlexing.mark]. The TDFA construction will use those to copy the accepting path's working registers into the canonical cells read by the binding extraction code; the compiler sets the list to [] for now, so generated code is unchanged. Nothing driving the automaton needs the other accepting rules of a state, so [finals] goes away; [accepting_rule] finds the winning rule directly from the rules' final nodes. The DOT printer labels an accepting state with that rule only. No expect output listed more than one rule, so the graphs are unchanged. [call_state] moves below [gen_tag_ops], which it now uses, and the DOT printer shows final ops on accepting-state labels when there are any, with [tag_op_to_string] hoisted to top level. Co-Authored-By: Claude Fable 5.1 --- src/compiler/sedlex.ml | 63 +++++++++++++++++++++++++--------------- src/compiler/sedlex.mli | 15 ++++++++-- src/syntax/ppx_sedlex.ml | 61 ++++++++++++++++++-------------------- 3 files changed, 81 insertions(+), 58 deletions(-) diff --git a/src/compiler/sedlex.ml b/src/compiler/sedlex.ml index e02b6a12..c8c2fb38 100644 --- a/src/compiler/sedlex.ml +++ b/src/compiler/sedlex.ml @@ -302,14 +302,28 @@ let transition (state : state) = Array.sort (fun (c1, _, _) (c2, _, _) -> compare c1 c2) t; t +type accept = { rule : int; final_ops : tag_op list } + type dfa_state = { trans : (Cset.t * int * tag_op list) array; - finals : bool array; + accept : accept option; } type dfa = dfa_state array type compiled = { dfa : dfa; init_tags : tag_op list; num_tags : int } +(* [accepting_rule rules is_final] is the lowest-numbered rule whose final + node satisfies [is_final], i.e. the highest-priority accepting rule of a + state under the first-match semantics of [match%sedlex]. *) +let accepting_rule rules is_final = + let n = Array.length rules in + let rec aux i = + if i = n then None + else if is_final (snd rules.(i)) then Some i + else aux (i + 1) + in + aux 0 + (* [compile rs] determinizes the NFA for an array of regexp rules. Each rule is compiled to an NFA (entry node, final node) pair. The initial DFA state is the epsilon closure of all entry nodes. States are explored @@ -329,8 +343,12 @@ let compile rs = Hashtbl.add states state i; let trans = transition state in let trans = Array.map (fun (p, t, tags) -> (p, aux t, tags)) trans in - let finals = Array.map (fun (_, f) -> List.memq f state) rs in - Hashtbl.add states_def i { trans; finals }; + let accept = + Option.map + (fun rule -> { rule; final_ops = [] }) + (accepting_rule rs (fun f -> List.memq f state)) + in + Hashtbl.add states_def i { trans; accept }; i in let init = ref ([], []) in @@ -590,6 +608,12 @@ let cset_to_label cset = String.concat ", " (List.map format_interval (cset : Cset.t :> (int * int) list)) +let tag_op_to_string = function + | Set_position { dst } -> "t" ^ string_of_int dst + | Set_value { dst; value } -> + "d" ^ string_of_int dst ^ "=" ^ string_of_int value + | Copy { dst; src } -> "t" ^ string_of_int dst ^ "<-t" ^ string_of_int src + let dfa_to_dot dfa = let buf = Buffer.create 1024 in let bprintf = Printf.bprintf in @@ -599,30 +623,23 @@ let dfa_to_dot dfa = bprintf buf " _start [shape=point];\n"; bprintf buf " _start -> state0;\n\n"; Array.iteri - (fun i { trans; finals } -> - let accepted = - let acc = ref [] in - for r = Array.length finals - 1 downto 0 do - if finals.(r) then acc := r :: !acc - done; - !acc - in - (match accepted with - | [] -> bprintf buf " state%d [label=\"%d\"];\n" i i - | rules -> + (fun i { trans; accept } -> + (match accept with + | None -> bprintf buf " state%d [label=\"%d\"];\n" i i + | Some { rule; final_ops } -> + let ops = + if final_ops = [] then "" + else + "\\n{" + ^ String.concat "," (List.map tag_op_to_string final_ops) + ^ "}" + in bprintf buf - " state%d [label=\"%d\\n[rule %s]\", shape=doublecircle];\n" i i - (String.concat "," (List.map string_of_int rules))); + " state%d [label=\"%d\\n[rule %d]%s\", shape=doublecircle];\n" i + i rule ops); Array.iter (fun (cset, target, tags) -> let label = cset_to_label cset in - let tag_op_to_string = function - | Set_position { dst } -> "t" ^ string_of_int dst - | Set_value { dst; value } -> - "d" ^ string_of_int dst ^ "=" ^ string_of_int value - | Copy { dst; src } -> - "t" ^ string_of_int dst ^ "<-t" ^ string_of_int src - in let label = if tags = [] then label else diff --git a/src/compiler/sedlex.mli b/src/compiler/sedlex.mli index 686454d0..0a864c27 100644 --- a/src/compiler/sedlex.mli +++ b/src/compiler/sedlex.mli @@ -96,12 +96,23 @@ val reset_tags : unit -> unit (** {2 DFA compilation} *) +(** What an accepting state accepts. *) +type accept = { + rule : int; + (** The lowest-numbered, hence highest-priority, accepting rule, matching + the first-match semantics of [match%sedlex]. *) + final_ops : tag_op list; + (** Tag operations to execute when entering the state, just before + [Sedlexing.mark]. They materialize the accepting path's registers into + the cells read by the binding extraction code; the list is empty until + the compiler allocates working registers. *) +} + type dfa_state = { trans : (Cset.t * int * tag_op list) array; (** Each transition: (character set, target state, tag operations to execute when this transition fires). *) - finals : bool array; - (** [finals.(i)] is [true] if this state is accepting for rule [i]. *) + accept : accept option; (** [None] for non-accepting states. *) } (** DFA states, indexed by state number. State 0 is the initial state. *) diff --git a/src/syntax/ppx_sedlex.ml b/src/syntax/ppx_sedlex.ml index add338d7..66d86160 100644 --- a/src/syntax/ppx_sedlex.ml +++ b/src/syntax/ppx_sedlex.ml @@ -215,33 +215,8 @@ let partition (name, p) = (* Code generation for the automata *) -(* [best_final finals] returns the lowest-numbered accepting rule for this - state, or [None] if the state is not accepting. Lowest-numbered = highest - priority, matching the first-match semantics of [match%sedlex]. *) -let best_final final = - let fin = ref None in - for i = Array.length final - 1 downto 0 do - if final.(i) then fin := Some i - done; - !fin - let state_fun state = Printf.sprintf "__sedlex_state_%i" state -(* [call_state lexbuf auto state] generates the expression that transitions - into DFA [state]. If the state has no outgoing transitions (a sink), it - returns the accepting rule index directly; otherwise it emits a function - call to the generated state function. *) -let call_state lexbuf (auto : Sedlex.dfa) state = - let { Sedlex.trans; finals } = auto.(state) in - if Array.length trans = 0 then ( - match best_final finals with - | Some i -> eint ~loc:default_loc i - | None -> - (* A non-accepting sink would need a transition on an empty - character set, which [ir_of_pattern] rejects. *) - assert false) - else appfun (state_fun state) [lexbuf] - (* [gen_tag_ops lexbuf ops cont] wraps [cont] in a sequence of tag operation calls. Each [Set_position {dst}] becomes a call to [__private__set_mem_pos], and each [Set_value {dst; value}] becomes a call @@ -268,9 +243,28 @@ let gen_tag_ops lexbuf (ops : Sedlex.tag_op list) cont = [%e acc]]) ops cont -(* [gen_state (lexbuf_name, lexbuf) auto i {trans; finals}] generates the +(* [call_state lexbuf auto state] generates the expression that transitions + into DFA [state]. If the state has no outgoing transitions (a sink), it + executes the state's final tag operations and returns the accepting rule + index directly; otherwise it emits a function call to the generated state + function. *) +let call_state lexbuf (auto : Sedlex.dfa) state = + let { Sedlex.trans; accept } = auto.(state) in + if Array.length trans = 0 then ( + match accept with + | Some { Sedlex.rule; final_ops } -> + gen_tag_ops lexbuf final_ops (eint ~loc:default_loc rule) + | None -> + (* A non-accepting sink would need a transition on an empty + character set, which [ir_of_pattern] rejects. *) + assert false) + else appfun (state_fun state) [lexbuf] + +(* [gen_state (lexbuf_name, lexbuf) auto i {trans; accept}] generates the function [__sedlex_state_N] for DFA state [i]. The function: - 1. If the state is accepting, calls [mark] to save the current position. + 1. If the state is accepting ([accept = Some { rule; final_ops }]), executes + [final_ops] then calls [mark] to save the current position and a + snapshot of the memory cells. 2. Reads the next code point, maps it through the partition function to get an equivalence class index, then pattern-matches on that index. 3. Each transition arm executes its tag operations then calls the target @@ -278,7 +272,7 @@ let gen_tag_ops lexbuf (ops : Sedlex.tag_op list) cont = 4. The default arm calls [backtrack] to return the last accepted rule. Returns [] for accepting states with no outgoing transitions (sinks). *) let gen_state (lexbuf_name, lexbuf) (auto : Sedlex.dfa) i - { Sedlex.trans; finals } = + { Sedlex.trans; accept } = let loc = default_loc in let partition = Array.map (fun (cs, _, _) -> cs) trans in let cases = @@ -309,14 +303,15 @@ let gen_state (lexbuf_name, lexbuf) (auto : Sedlex.dfa) i ~expr:(Exp.fun_ ~loc Nolabel None lhs body); ] in - match best_final finals with + match accept with | None -> ret (body ()) | Some _ when Array.length trans = 0 -> [] - | Some i -> + | Some { Sedlex.rule; final_ops } -> ret - [%expr - Sedlexing.mark [%e lexbuf] [%e eint ~loc i]; - [%e body ()]] + (gen_tag_ops lexbuf final_ops + [%expr + Sedlexing.mark [%e lexbuf] [%e eint ~loc rule]; + [%e body ()]]) (* [gen_recflag auto] determines whether the generated state functions need [let rec]. If every transition leads to a sink state (no further From 988e77d0495130859981fcd7a2b6801b90c8cced Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 18 Sep 2026 13:50:01 +0200 Subject: [PATCH 4/4] Generate tag operations as a parallel move The TDFA construction emits register moves whose Copy operations must all read the pre-transition contents: a transition may both copy cell A into B and overwrite A. [gen_tag_ops] now let-binds every Copy source that the same list also writes, via the new raw accessors [__private__mem_get] / [__private__mem_set], and emits the writes in list order. [op_dest] is exported for it. No Copy is emitted yet, so generated code is unchanged. Co-Authored-By: Claude Fable 5.1 --- src/compiler/sedlex.ml | 3 ++ src/compiler/sedlex.mli | 7 +++- src/lib/sedlexing.ml | 7 ++++ src/lib/sedlexing.mli | 10 ++++++ src/syntax/ppx_sedlex.ml | 71 +++++++++++++++++++++++++++------------- 5 files changed, 75 insertions(+), 23 deletions(-) diff --git a/src/compiler/sedlex.ml b/src/compiler/sedlex.ml index c8c2fb38..62f36121 100644 --- a/src/compiler/sedlex.ml +++ b/src/compiler/sedlex.ml @@ -312,6 +312,9 @@ type dfa_state = { type dfa = dfa_state array type compiled = { dfa : dfa; init_tags : tag_op list; num_tags : int } +let op_dest = function + | Copy { dst; _ } | Set_position { dst } | Set_value { dst; _ } -> dst + (* [accepting_rule rules is_final] is the lowest-numbered rule whose final node satisfies [is_final], i.e. the highest-priority accepting rule of a state under the first-match semantics of [match%sedlex]. *) diff --git a/src/compiler/sedlex.mli b/src/compiler/sedlex.mli index 0a864c27..96c56288 100644 --- a/src/compiler/sedlex.mli +++ b/src/compiler/sedlex.mli @@ -70,6 +70,9 @@ type tag_op = Emitted when determinization must preserve a position that a parallel NFA path is about to overwrite. *) +(** [op_dest op] is the memory cell written by [op]. *) +val op_dest : tag_op -> int + (** [bind r] wraps [r] with start/end tag epsilon nodes. Returns [(wrapped_regexp, start_tag, end_tag)] where [start_tag] and [end_tag] are the allocated memory cell indices. *) @@ -111,7 +114,9 @@ type accept = { type dfa_state = { trans : (Cset.t * int * tag_op list) array; (** Each transition: (character set, target state, tag operations to - execute when this transition fires). *) + execute when this transition fires). The operations form a parallel + move: a [Copy] reads its source as it was before any operation of the + same list executed, and no two operations write the same cell. *) accept : accept option; (** [None] for non-accepting states. *) } diff --git a/src/lib/sedlexing.ml b/src/lib/sedlexing.ml index 6da2fc82..adb4868b 100644 --- a/src/lib/sedlexing.ml +++ b/src/lib/sedlexing.ml @@ -308,6 +308,13 @@ let __private__set_mem_value lexbuf i v = let __private__copy_mem lexbuf dst src = lexbuf.__private__mem.(dst) <- lexbuf.__private__mem.(src) +(* Raw cell access, used by generated code to save a cell in a local + variable when a parallel register move both reads and overwrites it. The + value is opaque (position/value encoding preserved); [__private__mem_set] + must only be given values obtained from [__private__mem_get]. *) +let __private__mem_get lexbuf i = lexbuf.__private__mem.(i) +let __private__mem_set lexbuf i v = lexbuf.__private__mem.(i) <- v + (* Returns position relative to token start, for use in sub_lexeme. *) let __private__mem_pos lexbuf i = lexbuf.__private__mem.(i) - lexbuf.start_pos diff --git a/src/lib/sedlexing.mli b/src/lib/sedlexing.mli index 4f6ff87d..e44ee61b 100644 --- a/src/lib/sedlexing.mli +++ b/src/lib/sedlexing.mli @@ -266,6 +266,16 @@ val __private__set_mem_value : lexbuf -> int -> int -> unit operations on DFA transitions. *) val __private__copy_mem : lexbuf -> int -> int -> unit +(** [__private__mem_get lexbuf i] returns the raw contents of cell [i]. Used by + generated code to save a cell in a local variable when a parallel register + move both reads and overwrites it. The returned value is opaque; only pass + it to {!__private__mem_set}. *) +val __private__mem_get : lexbuf -> int -> int + +(** [__private__mem_set lexbuf i v] stores [v], a value previously obtained from + {!__private__mem_get}, into cell [i]. *) +val __private__mem_set : lexbuf -> int -> int -> unit + (** [__private__mem_pos lexbuf i] returns the position stored in cell [i], as an offset relative to the start of the current token. *) val __private__mem_pos : lexbuf -> int -> int diff --git a/src/syntax/ppx_sedlex.ml b/src/syntax/ppx_sedlex.ml index 66d86160..beb208c2 100644 --- a/src/syntax/ppx_sedlex.ml +++ b/src/syntax/ppx_sedlex.ml @@ -217,31 +217,58 @@ let partition (name, p) = let state_fun state = Printf.sprintf "__sedlex_state_%i" state -(* [gen_tag_ops lexbuf ops cont] wraps [cont] in a sequence of tag - operation calls. Each [Set_position {dst}] becomes a call to - [__private__set_mem_pos], and each [Set_value {dst; value}] becomes a call - to [__private__set_mem_value]. Operations are folded right so they execute - before [cont]. *) +(* [gen_tag_ops lexbuf ops cont] wraps [cont] in the code performing the tag + operations [ops], which form a parallel move: every [Copy] must read its + source as it was before any operation of the list executed. Sources that + the list also writes are first saved in let-bound locals; everything else + compiles to direct [__private__set_mem_pos] / [__private__set_mem_value] / + [__private__copy_mem] calls in list order. *) let gen_tag_ops lexbuf (ops : Sedlex.tag_op list) cont = let loc = default_loc in + let dests = List.map Sedlex.op_dest ops in + let clobbered = + List.sort_uniq compare + (List.filter_map + (fun (op : Sedlex.tag_op) -> + match op with + | Copy { src; _ } when List.mem src dests -> Some src + | _ -> None) + ops) + in + let local s = Printf.sprintf "__sedlex_mem_%d" s in + let writes = + List.fold_right + (fun (op : Sedlex.tag_op) acc -> + match op with + | Set_position { dst } -> + [%expr + Sedlexing.__private__set_mem_pos [%e lexbuf] [%e eint ~loc dst]; + [%e acc]] + | Set_value { dst; value } -> + [%expr + Sedlexing.__private__set_mem_value [%e lexbuf] + [%e eint ~loc dst] [%e eint ~loc value]; + [%e acc]] + | Copy { dst; src } when List.mem src clobbered -> + [%expr + Sedlexing.__private__mem_set [%e lexbuf] [%e eint ~loc dst] + [%e evar ~loc (local src)]; + [%e acc]] + | Copy { dst; src } -> + [%expr + Sedlexing.__private__copy_mem [%e lexbuf] [%e eint ~loc dst] + [%e eint ~loc src]; + [%e acc]]) + ops cont + in List.fold_right - (fun (op : Sedlex.tag_op) acc -> - match op with - | Set_position { dst } -> - [%expr - Sedlexing.__private__set_mem_pos [%e lexbuf] [%e eint ~loc dst]; - [%e acc]] - | Set_value { dst; value } -> - [%expr - Sedlexing.__private__set_mem_value [%e lexbuf] [%e eint ~loc dst] - [%e eint ~loc value]; - [%e acc]] - | Copy { dst; src } -> - [%expr - Sedlexing.__private__copy_mem [%e lexbuf] [%e eint ~loc dst] - [%e eint ~loc src]; - [%e acc]]) - ops cont + (fun s acc -> + [%expr + let [%p pvar ~loc (local s)] = + Sedlexing.__private__mem_get [%e lexbuf] [%e eint ~loc s] + in + [%e acc]]) + clobbered writes (* [call_state lexbuf auto state] generates the expression that transitions into DFA [state]. If the state has no outgoing transitions (a sink), it