Plumbing for the TDFA rewrite: Copy op, inline records, accept field, parallel moves

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 { 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. *)
@@ -172,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
@@ -185,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
@@ -194,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
@@ -204,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
@@ -242,16 +245,16 @@ 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)
-      | Set_position _ -> ())
+            | _ -> Hashtbl.replace dominated dst value)
+      | Set_position _ | Copy _ -> ())
     tags;
   List.filter
     (function
-      | Set_value (cell, value) -> Hashtbl.find dominated cell = value
-      | Set_position _ -> true)
+      | Set_value { dst; value } -> Hashtbl.find dominated dst = value
+      | Set_position _ | Copy _ -> true)
     tags
 
 (* [transition state] computes all outgoing DFA transitions from a DFA state.
@@ -299,14 +302,31 @@ 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 }
 
+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]. *)
+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
@@ -326,8 +346,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
@@ -587,6 +611,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
@@ -596,27 +626,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 t -> "t" ^ string_of_int t
-            | Set_value (c, v) -> "d" ^ string_of_int c ^ "=" ^ string_of_int v
-          in
           let label =
             if tags = [] then label
             else

src/compiler/sedlex.mli

@@ -59,12 +59,19 @@ 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). *)
+  | 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. *)
+
+(** [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
@@ -92,12 +99,25 @@ 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]. *)
+          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. *)
 }
 
 (** DFA states, indexed by state number. State 0 is the initial state. *)

src/lib/sedlexing.ml

@@ -304,6 +304,17 @@ 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)
+
+(* 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
 

src/lib/sedlexing.mli

@@ -261,6 +261,21 @@ 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_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