Commit d4aae8b6 authored by POTTIER Francois's avatar POTTIER Francois

The environment record in the table back-end is now immutable.

Surprisingly, this SPEEDS things up. Now, table / code = 2.0.
parent a55fb859
...@@ -93,7 +93,7 @@ module Make (T : TABLE) = struct ...@@ -93,7 +93,7 @@ module Make (T : TABLE) = struct
and discard env = and discard env =
let lexbuf = env.lexbuf in let lexbuf = env.lexbuf in
let token = env.lexer lexbuf in let token = env.lexer lexbuf in
env.token <- token; let env = { env with token } in
Log.lookahead_token lexbuf (T.token2terminal token); Log.lookahead_token lexbuf (T.token2terminal token);
check_for_default_reduction env check_for_default_reduction env
...@@ -171,17 +171,18 @@ module Make (T : TABLE) = struct ...@@ -171,17 +171,18 @@ module Make (T : TABLE) = struct
state that we are leaving. *) state that we are leaving. *)
let lexbuf = env.lexbuf in let lexbuf = env.lexbuf in
env.stack <- { let stack = {
state = env.current; state = env.current;
semv = value; semv = value;
startp = lexbuf.Lexing.lex_start_p; startp = lexbuf.Lexing.lex_start_p;
endp = lexbuf.Lexing.lex_curr_p; endp = lexbuf.Lexing.lex_curr_p;
next = env.stack; next = env.stack;
}; } in
(* Switch to state [s']. *) (* Switch to state [s']. *)
env.current <- s'; let current = s' in
let env = { env with stack; current } in
run env please_discard run env please_discard
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
...@@ -195,12 +196,11 @@ module Make (T : TABLE) = struct ...@@ -195,12 +196,11 @@ module Make (T : TABLE) = struct
Log.reduce_or_accept prod; Log.reduce_or_accept prod;
(* Invoke the semantic action. The semantic action is responsible for (* Invoke the semantic action. The semantic action is responsible for
truncating the stack, updating the current state, producing a cell that truncating the stack and pushing a new cell onto the stack, which
contains a new semantic value, and raising [Accept] or [Error] if contains a new semantic value. It can raise [Accept] or [Error]. *)
appropriate. *)
(* If the semantic action terminates normally, it returns a new stack, (* If the semantic action terminates normally, it returns a new stack,
which we write into [env.stack]. *) which becomes the current stack. *)
(* If the semantic action raises [Error], we catch it immediately and (* If the semantic action raises [Error], we catch it immediately and
initiate error handling. *) initiate error handling. *)
...@@ -208,28 +208,29 @@ module Make (T : TABLE) = struct ...@@ -208,28 +208,29 @@ module Make (T : TABLE) = struct
(* The apparently weird idiom used here is an encoding for a (* The apparently weird idiom used here is an encoding for a
[let/unless] construct, which does not exist in ocaml. *) [let/unless] construct, which does not exist in ocaml. *)
if ( let success =
try try
env.stack <- T.semantic_action prod env; Some (T.semantic_action prod env)
true
with Error -> with Error ->
false None
) then begin in
match success with
| Some stack ->
(* By our convention, the semantic action is responsible for updating (* By our convention, the semantic action has produced an updated
the stack. The state now found in the top stack cell is the return stack. The state now found in the top stack cell is the return
state. *) state. *)
(* Perform a goto transition. The target state is determined (* Perform a goto transition. The target state is determined
by consulting the goto table at the return state and at by consulting the goto table at the return state and at
production [prod]. *) production [prod]. *)
env.current <- T.goto env.stack.state prod; let current = T.goto stack.state prod in
run env false let env = { env with stack; current } in
run env false
end | None ->
else initiate env
initiate env
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
...@@ -241,7 +242,7 @@ module Make (T : TABLE) = struct ...@@ -241,7 +242,7 @@ module Make (T : TABLE) = struct
and initiate env : void = and initiate env : void =
assert (env.token != error_token); assert (env.token != error_token);
Log.initiating_error_handling(); Log.initiating_error_handling();
env.token <- error_token; let env = { env with token = error_token } in
error env error env
(* [error] handles errors. *) (* [error] handles errors. *)
...@@ -297,8 +298,10 @@ module Make (T : TABLE) = struct ...@@ -297,8 +298,10 @@ module Make (T : TABLE) = struct
(* The stack is nonempty. Pop a cell, updating the current state (* The stack is nonempty. Pop a cell, updating the current state
with that found in the popped cell, and try again. *) with that found in the popped cell, and try again. *)
env.stack <- next; let env = { env with
env.current <- cell.state; stack = next;
current = cell.state
} in
error env error env
end end
......
...@@ -44,7 +44,8 @@ type ('state, 'semantic_value) stack = { ...@@ -44,7 +44,8 @@ type ('state, 'semantic_value) stack = {
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
(* A parsing environment contains basically all of the automaton's state. *) (* A parsing environment contains almost all of the automaton's state.
(It contains everything except the current program point.) *)
type ('state, 'semantic_value, 'token) env = { type ('state, 'semantic_value, 'token) env = {
...@@ -57,22 +58,22 @@ type ('state, 'semantic_value, 'token) env = { ...@@ -57,22 +58,22 @@ type ('state, 'semantic_value, 'token) env = {
lexbuf: Lexing.lexbuf; lexbuf: Lexing.lexbuf;
(* The last token that was obtained from the lexer. In principe, this should (* The last token that was obtained from the lexer. In principle, this
be a legit token, but the engine disguises the [error] pseudo-token as an should be a legit token, but the engine disguises the [error]
illegal inhabitant of this type. Do not use this field unless you know pseudo-token as an illegal inhabitant of this type. Do not read this
what are doing! *) field unless you know what are doing! *)
mutable token: 'token; token: 'token;
(* The stack. In [CodeBackend], it is passed around on its own, (* The stack. In [CodeBackend], it is passed around on its own,
whereas, here, it is accessed via the environment. *) whereas, here, it is accessed via the environment. *)
mutable stack: ('state, 'semantic_value) stack; stack: ('state, 'semantic_value) stack;
(* The current state. In [CodeBackend], it is passed around on its (* The current state. In [CodeBackend], it is passed around on its
own, whereas, here, it is accessed via the environment. *) own, whereas, here, it is accessed via the environment. *)
mutable current: 'state; current: 'state;
} }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment