Parser combinator 和正则表达式引擎的一些改进

注:普通的正则引擎的实现原理, parser combinator 实现原理, 用户级线程实现原理为此文前置知识,不做说明。

缘起

在用 fiber 来做服务端程序时。我需要同时服务大量的用户,对收到的数据做一些解析。这些数据都是符合一些网络协议。于是我便在找了些已有的 parser combinator 来用。在使用过程中,我发现这些库都不能直接对接网络的 I/O channel. 原因是

  1. 缺乏处理未知长度输入的能力。
  2. 通过网络来的数据都不是即时的,大多处理流都是处于等待 IO 完成的状态。若用系统级线程来实现分析流的话,会有大量的线程处于睡眠状态占用系统资源(操作系统需为每个线程记录上下文,特别是每个线程的栈会占用几十 KB 或者以 MB 为单位的空间),无法应付大量并发的场景。所以需将分析的控制流 fiber 化。

于是写了一个拥有上述能力的新的 parser combinator. 在引入正则表达式处理能力时又发现了问题。因为当时不存在符合上述要求的正则表达式引擎,所以不能直接嵌入一个现有的到 parser combinator 库里。于是也顺便写了一个拥有上述能力的正则表达式引擎。

ok-parsec

普遍的处理方法

  1. 对于前置长度的数据。接收完指定长度的数据后再进行解析。
  2. 对于后置分隔符的数据。扫描所有输入,直到遇到分隔符为止。再进行解析。
  3. 其他,无法处理。

情况1的话, 计算能力的闲置和内存空间闲置都是必须且合适的。因此没有影响。

情况2的话,对所有输入数据都有无必要的通过内存的访问,以做分隔符检测。然后再次解析时的计算能力和空间占用才是有价值的。

情况3的话,则是上述处理方法的缺陷。交换的数据不能是递归地符合文法的连续的输入。

改进

处理未知长度的输入

在处理过程中不断会有新数据到达时,需将其加入到输入流里。因为可能有后续的数据到达,所以不能直接根据当前的已接收到的数据长度做判断是否遇到输入结束。

在分析过程中当输入指针超出当前缓冲区时需主动提出要求,等待新数据到达或者遇到输入结束。

以上逻辑只需实现在最基础的 parser 里面即可。依赖于基础 parser 构建的 parser 则无需考虑此逻辑。
基础的 parser 为

  1. char
  2. regexp
  3. string

string parser 的话其实可以以 char parser 来构建。不过为了提升下性能,所以也为其加入了处理逻辑。

fiber 化

选用了一个成熟的用户级线程库 Lwt 作为基础。

parser 类型的声明如下:

type 'a parser= state -> 'a reply Lwt.t

对于有 Lwt 库或者 Jane Street 的 Async 库使用经验的人。或者读过之前博客上介绍 fiber 实现原理的话。此类型声明已经说明原理了。

能力

解决情况2和情况3的问题。情况1的话,两种方式的算力和空间消耗是同样的。

每次数据的到达都直接推动分析过流的进行。当数据暂为到达时分析逻辑流睡眠。因为 parser 控制流作为 fiber 实现, 所以可以巨量并发,以适应 I/O bound 的场景。

示例

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
open Ok_parsec
open Parsec

type elm=
  | Num of string
  | Var of string
  | Add | Sub | Mul | Div
  | Ast of ast
  | Eof

and op= | OpAdd | OpSub | OpMul | OpDiv

and ast=
  | StNum of string
  | StVar of string
  | StAdd of ast * ast
  | StSub of ast * ast
  | StMul of ast * ast
  | StDiv of ast * ast
  | StAssign of string * ast
  | StApp of string * ast list

module OpPrecedence = Map.Make(
  struct
    type t= op
    let compare= compare
  end)

(* precedence table *)
let opPrecedence=
  let open OpPrecedence in
  empty
  |> add OpAdd 3
  |> add OpSub 3
  |> add OpMul 4
  |> add OpDiv 4

let rec string_of_ast= fun ast->
  match ast with
  | StNum n-> n
  | StVar n-> n
  | StAdd (a1, a2)->
    Printf.sprintf "(+ %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StSub (a1, a2)->
    Printf.sprintf "(- %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StMul (a1, a2)->
    Printf.sprintf "(* %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StDiv (a1, a2)->
    Printf.sprintf "(/ %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StAssign (name, ast)-> Printf.sprintf "(= %s %s)"
      name (string_of_ast ast)
  | StApp (name, asts)-> Printf.sprintf "(%s %s)"
      name (List.map string_of_ast asts |> String.concat " ")

let reduce ops asts last newOp=
  let rec reduce ops asts newOp=
    match ops with
    | [] -> ([newOp], asts)
    | op::tail->
      let newOpPrecedence= OpPrecedence.find newOp opPrecedence
      and nextOpPrecedence= OpPrecedence.find op opPrecedence
      in
      if newOpPrecedence <= nextOpPrecedence then
        match op with
        | OpAdd-> (match asts with
          | n1::n2::rest-> reduce tail (StAdd (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpAdd")
        | OpSub-> (match asts with
          | n1::n2::rest-> reduce tail (StSub (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpSub")
        | OpMul-> (match asts with
          | n1::n2::rest-> reduce tail (StMul (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpMul")
        | OpDiv-> (match asts with
          | n1::n2::rest-> reduce tail (StDiv (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpDiv")
      else
        (newOp::ops, asts)
  in 
  let (ops, asts)= reduce ops asts newOp in
  (ops, asts, last)

let reduceAll ops asts=
  let rec reduceAll ops asts=
    match ops with
    | [] -> asts
    | op::tail->
      match op with
      | OpAdd-> (match asts with
        | n1::n2::rest-> reduceAll tail (StAdd (n2,n1)::rest)
        | _ -> failwith "ast stack is empty")
      | OpSub-> (match asts with
        | n1::n2::rest-> reduceAll tail (StSub (n2,n1)::rest)
        | _ -> failwith "ast stack is empty")
      | OpMul-> (match asts with
        | n1::n2::rest-> reduceAll tail (StMul (n2,n1)::rest)
        | _ -> failwith "ast stack is empty while reduceAll OpMul")
      | OpDiv-> (match asts with
        | n1::n2::rest-> reduceAll tail (StDiv (n2,n1)::rest)
        | _ -> failwith "ast stack is empty while reduceAll OpDiv")
  in List.hd (reduceAll ops asts)

let spaces= many ((char ' ') <|> (char '\t'))

let num=
  many1 num_dec |>> BatString.of_list

let ident=
  let%m head= lowercase <|> uppercase in
  let%m tail= many (lowercase <|> uppercase <|> num_dec)
  in return (head::tail |> BatString.of_list)

let rec element s= s |>
  let element=
    (char '+' >>$ Add) <|>
    (char '-' >>$ Sub) <|>
    (char '*' >>$ Mul) <|>
    (char '/' >>$ Div) <|>
    (num |>> fun num -> Num num) <|>
    ((char '(' >> spaces >> expr << spaces << char ')') <|>
      (assignment <|> application)
      |>> fun ast-> Ast ast)
    <|>
    (ident |>> fun name -> Var name) <|>
    (return Eof)
  in
  spaces >> element << spaces

and params s= s |> sepBy (spaces >> char ',' >> spaces) expr

and application s= s |>
  let%m name= ident in
  spaces >> char '(' >>
  let%m ps= params in
  char ')' >>
  return (StApp (name, ps));

and assignment s= s |>
  let%m v= ident in
  spaces >> char '=' >> spaces >>
  let%m exp= assignment <|> expr in
  return (StAssign (v, exp))

and expr s=
  let rec expr result=
    let (ops, asts, last)= result in
    let%m next= element in
    match next with
    | Num num-> return (ops, StNum num::asts, next) >>= expr
    | Var name-> return (ops, StVar name::asts, next) >>= expr
    | Ast ast-> return (ops, ast::asts, next) >>= expr
    | Add-> expr (reduce ops asts next OpAdd)
    | Sub->
      (match last with
      | Add | Sub | Mul | Div->
        let%m next= element in
        (match next with
        | Num num->
          let num= "-" ^ num in
          return (ops, StNum num::asts, Num num) >>= expr
        | _ -> fail "expecting num")
      | _ -> expr (reduce ops asts next OpSub))
    | Mul-> expr (reduce ops asts next OpMul)
    | Div-> expr (reduce ops asts next OpDiv)
    | Eof->
      try
        let ast= reduceAll ops asts in
        return ast
      with Failure "hd"->
        fail "empty"
  in (return ([], [], Eof) >>= expr) s

let test parser expr=
  let%m[@Lwt] result= parse_string parser expr in
  match result with
  | Ok (r, s)-> Lwt_io.printf "%s\n" (string_of_ast r)
  | Failed (p, s)-> Lwt_io.printf "at %d, %s\n" p s

let main ()=
  let open Lwt in
  begin%m
    Lwt_io.printf "parse sequently\n";
    test expr "res= tmp=bb+ 10 * show(1,me(2+3,4))";
    test expr "10-9 - 8 * 6 / 5 - 4";
    test expr "show(a=b=c(1,2))";
    test expr "(1--2*-3/-4)*3";
    Lwt_io.printl "";
    Lwt_io.printf "parse concurrently\n";
    join [
      test expr "res= tmp=bb+ 10 * show(1,me(2+3,4))";
      test expr "10-9 - 8 * 6 / 5 - 4";
      test expr "show(a=b=c(1,2))";
      test expr "(1--2*-3/-4)*3";
    ];
  end

let ()= Lwt_main.run @@ main ()

结果

kandu@bomb:~/t$ ocamlfind ocamlc -linkpkg -annot -package ok_parsec l.ml -o l && ./l
parse sequently
(= res (= tmp (+ bb (* 10 (show 1 (me (+ 2 3) 4))))))
(- (- (- 10 9) (/ (* 8 6) 5)) 4)
(show (= a (= b (c 1 2))))
(* (- 1 (/ (* -2 -3) -4)) 3)

parse concurrently
(* (- 1 (/ (* -2 -3) -4)) 3)
(show (= a (= b (c 1 2))))
(- (- (- 10 9) (/ (* 8 6) 5)) 4)
(= res (= tmp (+ bb (* 10 (show 1 (me (+ 2 3) 4))))))