aboutsummaryrefslogtreecommitdiff
path: root/stm
diff options
context:
space:
mode:
Diffstat (limited to 'stm')
-rw-r--r--stm/spawned.ml4
-rw-r--r--stm/stm.ml233
-rw-r--r--stm/stm.mli2
-rw-r--r--stm/tQueue.ml2
-rw-r--r--stm/vcs.ml2
-rw-r--r--stm/vernac_classifier.ml2
-rw-r--r--stm/vio_checking.ml6
7 files changed, 130 insertions, 121 deletions
diff --git a/stm/spawned.ml b/stm/spawned.ml
index c5bd5f6f96..de19dd5352 100644
--- a/stm/spawned.ml
+++ b/stm/spawned.ml
@@ -46,7 +46,7 @@ let control_channel = ref None
let channels = ref None
let init_channels () =
- if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice");
+ if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice.");
let () = match !main_channel with
| None -> ()
| Some (Socket(mh,mpr,mpw)) ->
@@ -65,7 +65,7 @@ let init_channels () =
| Some (Socket (ch, cpr, cpw)) ->
controller ch cpr cpw
| Some AnonPipe ->
- CErrors.anomaly (Pp.str "control channel cannot be a pipe")
+ CErrors.anomaly (Pp.str "control channel cannot be a pipe.")
let get_channels () =
match !channels with
diff --git a/stm/stm.ml b/stm/stm.ml
index 84c8aa9a99..739bc01e6f 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -7,13 +7,14 @@
(************************************************************************)
(* enable in case of stm problems *)
-let stm_debug = false
+(* let stm_debug () = !Flags.debug *)
+let stm_debug () = !Flags.stm_debug
-let stm_pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
-let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n" (System.process_id ()) Pp.pp_with pp; flush stderr
+let stm_pr_err s = Format.eprintf "%s] %s\n%!" (System.process_id ()) s
+let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp_with pp
-let stm_prerr_endline s = if stm_debug then begin stm_pr_err (s ()) end else ()
-let stm_pperr_endline s = if stm_debug then begin stm_pp_err (s ()) end else ()
+let stm_prerr_endline s = if stm_debug () then begin stm_pr_err (s ()) end else ()
+let stm_pperr_endline s = if stm_debug () then begin stm_pp_err (s ()) end else ()
let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else ()
@@ -23,9 +24,9 @@ open Feedback
open Vernacexpr
open Vernac_classifier
-let execution_error state_id loc msg =
+let execution_error ?loc state_id msg =
feedback ~id:state_id
- (Message (Error, Some loc, msg))
+ (Message (Error, loc, msg))
module Hooks = struct
@@ -65,14 +66,14 @@ end
(* During interactive use we cache more states so that Undoing is fast *)
let interactive () =
- if !Flags.ide_slave || !Flags.print_emacs || not !Flags.batch_mode then `Yes
+ if !Flags.ide_slave || not !Flags.batch_mode then `Yes
else `No
let async_proofs_workers_extra_env = ref [||]
type aast = {
verbose : bool;
- loc : Loc.t;
+ loc : Loc.t option;
indentation : int;
strlen : int;
mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *)
@@ -126,8 +127,9 @@ type qed_t = {
brname : Vcs_.Branch.t;
brinfo : branch_type Vcs_.branch_info
}
-type seff_t = aast option
+type seff_t = ReplayCommand of aast | CherryPickEnv
type alias_t = Stateid.t * aast
+
type transaction =
| Cmd of cmd_t
| Fork of fork_t
@@ -139,7 +141,7 @@ type step =
[ `Cmd of cmd_t
| `Fork of fork_t * Stateid.t option
| `Qed of qed_t * Stateid.t
- | `Sideff of [ `Ast of aast * Stateid.t | `Id of Stateid.t ]
+ | `Sideff of seff_t * Stateid.t
| `Alias of alias_t ]
type visit = { step : step; next : Stateid.t }
@@ -217,7 +219,7 @@ end = struct (* {{{ *)
let find_proof_at_depth vcs pl =
try List.find (function
| _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl
- | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth")
+ | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth.")
| _ -> false)
(List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs))
with Not_found -> failwith "find_proof_at_depth"
@@ -225,9 +227,9 @@ end = struct (* {{{ *)
exception Expired
let visit vcs id =
if Stateid.equal id Stateid.initial then
- anomaly(Pp.str "Visiting the initial state id")
+ anomaly(Pp.str "Visiting the initial state id.")
else if Stateid.equal id Stateid.dummy then
- anomaly(Pp.str "Visiting the dummy state id")
+ anomaly(Pp.str "Visiting the dummy state id.")
else
try
match Vcs_.Dag.from_node (Vcs_.dag vcs) id with
@@ -238,12 +240,12 @@ end = struct (* {{{ *)
| [p, Noop; n, Fork x] -> { step = `Fork (x,Some p); next = n }
| [n, Qed x; p, Noop]
| [p, Noop; n, Qed x] -> { step = `Qed (x,p); next = n }
- | [n, Sideff None; p, Noop]
- | [p, Noop; n, Sideff None]-> { step = `Sideff (`Id p); next = n }
- | [n, Sideff (Some x); p, Noop]
- | [p, Noop; n, Sideff (Some x)]-> { step = `Sideff(`Ast (x,p)); next = n }
- | [n, Sideff (Some x)]-> {step = `Sideff(`Ast (x,Stateid.dummy)); next=n}
- | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id))
+ | [n, Sideff CherryPickEnv; p, Noop]
+ | [p, Noop; n, Sideff CherryPickEnv]-> { step = `Sideff (CherryPickEnv, p); next = n }
+ | [n, Sideff (ReplayCommand x); p, Noop]
+ | [p, Noop; n, Sideff (ReplayCommand x)]-> { step = `Sideff(ReplayCommand x,p); next = n }
+ | [n, Sideff (ReplayCommand x)]-> {step = `Sideff(ReplayCommand x, Stateid.dummy); next=n}
+ | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id^"."))
with Not_found -> raise Expired
end (* }}} *)
@@ -304,7 +306,7 @@ module VCS : sig
val proof_nesting : unit -> int
val checkout_shallowest_proof_branch : unit -> unit
- val propagate_sideff : replay:aast option -> unit
+ val propagate_sideff : action:seff_t -> unit
val gc : unit -> unit
@@ -330,17 +332,17 @@ end = struct (* {{{ *)
In case you are hitting the race enable stm_debug.
*)
- if stm_debug then Flags.we_are_parsing := false;
+ if stm_debug () then Flags.we_are_parsing := false;
let fname =
"stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in
let string_of_transaction = function
| Cmd { cast = t } | Fork (t, _,_,_) ->
(try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR")
- | Sideff (Some t) ->
+ | Sideff (ReplayCommand t) ->
sprintf "Sideff(%s)"
(try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR")
- | Sideff None -> "EnvChange"
+ | Sideff CherryPickEnv -> "EnvChange"
| Noop -> " "
| Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id)
| Qed { qast } -> Pp.string_of_ppcmds (pr_ast qast) in
@@ -472,10 +474,12 @@ end = struct (* {{{ *)
vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch
let reachable id = reachable !vcs id
let mk_branch_name { expr = x } = Branch.make
- (match x with
+ (let rec aux x = match x with
| VernacDefinition (_,((_,i),_),_) -> Names.string_of_id i
| VernacStartTheoremProof (_,[Some ((_,i),_),_],_) -> Names.string_of_id i
- | _ -> "branch")
+ | VernacTime (_, e)
+ | VernacTimeout (_, e) -> aux e
+ | _ -> "branch" in aux x)
let edit_branch = Branch.make "edit"
let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind
let get_info id =
@@ -513,11 +517,11 @@ end = struct (* {{{ *)
Proof_global.disactivate_current_proof_mode ()
(* copies the transaction on every open branch *)
- let propagate_sideff ~replay:t =
+ let propagate_sideff ~action =
List.iter (fun b ->
checkout b;
let id = new_node () in
- merge id ~ours:(Sideff t) ~into:b Branch.master)
+ merge id ~ours:(Sideff action) ~into:b Branch.master)
(List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ()))
let visit id = Vcs_aux.visit !vcs id
@@ -528,10 +532,10 @@ end = struct (* {{{ *)
match visit id with
| { next = n; step = `Cmd x } -> (id,Cmd x) :: aux n
| { next = n; step = `Alias x } -> (id,Alias x) :: aux n
- | { next = n; step = `Sideff (`Ast (x,_)) } ->
- (id,Sideff (Some x)) :: aux n
+ | { next = n; step = `Sideff (ReplayCommand x,_) } ->
+ (id,Sideff (ReplayCommand x)) :: aux n
| _ -> anomaly Pp.(str("Cannot slice from "^ Stateid.to_string block_start ^
- " to "^Stateid.to_string block_stop))
+ " to "^Stateid.to_string block_stop^"."))
in aux block_stop
let slice ~block_start ~block_stop =
@@ -583,11 +587,11 @@ end = struct (* {{{ *)
l
let create_proof_task_box l ~qed ~block_start:lemma =
- if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes");
+ if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes.");
vcs := create_property !vcs l (ProofTask { qed; lemma })
let create_proof_block ({ block_start; block_stop} as decl) name =
let l = nodes_in_slice ~block_start ~block_stop in
- if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes");
+ if not (topo_invariant l) then anomaly Pp.(str "overlapping boxes.");
vcs := create_property !vcs l (ProofBlock (decl, name))
let box_of id = List.map Dag.Property.data (property_of !vcs id)
let delete_boxes_of id =
@@ -598,7 +602,7 @@ end = struct (* {{{ *)
with
| [] -> None
| [x] -> Some x
- | _ -> anomaly Pp.(str "node with more than 1 proof task box")
+ | _ -> anomaly Pp.(str "node with more than 1 proof task box.")
let gc () =
let old_vcs = !vcs in
@@ -762,13 +766,13 @@ end = struct (* {{{ *)
| _ ->
(* coqc has a 1 slot cache and only for valid states *)
if interactive () = `No && Stateid.equal id !cur_id then ()
- else anomaly Pp.(str "installing a non cached state")
+ else anomaly Pp.(str "installing a non cached state.")
let get_cached id =
try match VCS.get_info id with
| { state = Valid s } -> s
- | _ -> anomaly Pp.(str "not a cached state")
- with VCS.Expired -> anomaly Pp.(str "not a cached state (expired)")
+ | _ -> anomaly Pp.(str "not a cached state.")
+ with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).")
let assign id what =
if VCS.get_state id <> Empty then () else
@@ -801,9 +805,9 @@ end = struct (* {{{ *)
match Stateid.get info with
| Some _ -> (e, info)
| None ->
- let loc = Option.default Loc.ghost (Loc.get_loc info) in
+ let loc = Loc.get_loc info in
let (e, info) = Hooks.(call_process_error_once (e, info)) in
- execution_error id loc (iprint (e, info));
+ execution_error ?loc id (iprint (e, info));
(e, Stateid.add info ~valid id)
let same_env { system = s1 } { system = s2 } =
@@ -819,7 +823,7 @@ end = struct (* {{{ *)
feedback ~id:id (ProcessingIn !Flags.async_proofs_worker_id);
let str_id = Stateid.to_string id in
if is_cached id && not redefine then
- anomaly Pp.(str"defining state "++str str_id++str" twice");
+ anomaly Pp.(str"defining state "++str str_id++str" twice.");
try
stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^
if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)");
@@ -912,9 +916,9 @@ let get_script prf =
match view.step with
| `Fork((_,_,_,ns), _) when test ns -> acc
| `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof
- | `Sideff (`Ast (x,_)) ->
+ | `Sideff (ReplayCommand x,_) ->
find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next
- | `Sideff (`Id id) -> find acc id
+ | `Sideff (CherryPickEnv, id) -> find acc id
| `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *)
find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next
| `Cmd _ -> find acc view.next
@@ -949,7 +953,7 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } =
the whole document state, such as backtrack, etc... so we start
to design the stm command interpreter now *)
set_id_for_feedback ?route id;
- Aux_file.record_in_aux_set_at loc;
+ Aux_file.record_in_aux_set_at ?loc ();
(* We need to check if a command should be filtered from
* vernac_entries, as it cannot handle it. This should go away in
* future refactorings.
@@ -968,7 +972,7 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } =
| VernacShow ShowScript -> ShowScript.show_script ()
| expr ->
stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr);
- try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr)
+ try Vernacentries.interp ?verbosely:(Some verbose) ?proof (Loc.tag ?loc expr)
with e ->
let e = CErrors.push e in
Exninfo.iraise Hooks.(call_process_error_once e)
@@ -1011,7 +1015,7 @@ end = struct (* {{{ *)
match info.vcs_backup with
| None, _ ->
anomaly Pp.(str"Backtrack.backto "++str(Stateid.to_string oid)++
- str": a state with no vcs_backup")
+ str": a state with no vcs_backup.")
| Some vcs, _ -> VCS.restore vcs
let branches_of id =
@@ -1019,7 +1023,7 @@ end = struct (* {{{ *)
match info.vcs_backup with
| _, None ->
anomaly Pp.(str"Backtrack.branches_of "++str(Stateid.to_string id)++
- str": a state with no vcs_backup")
+ str": a state with no vcs_backup.")
| _, Some x -> x
let rec fold_until f acc id =
@@ -1073,7 +1077,7 @@ end = struct (* {{{ *)
let id = VCS.get_branch_pos (VCS.current_branch ()) in
let vcs =
match (VCS.get_info id).vcs_backup with
- | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup")
+ | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup.")
| Some vcs, _ -> vcs in
let cb, _ =
try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs)
@@ -1092,7 +1096,7 @@ end = struct (* {{{ *)
VtStm (VtBack oid, true), VtLater
| VernacBacktrack (id,_,_)
| VernacBackTo id ->
- VtStm (VtBack (Stateid.of_int id), not !Flags.print_emacs), VtNow
+ VtStm (VtBack (Stateid.of_int id), not !Flags.batch_mode), VtNow
| _ -> VtUnknown, VtNow
with
| Not_found ->
@@ -1105,11 +1109,11 @@ let hints = ref Aux_file.empty_aux_file
let set_compilation_hints file =
hints := Aux_file.load_aux_file_for file
let get_hint_ctx loc =
- let s = Aux_file.get !hints loc "context_used" in
+ let s = Aux_file.get ?loc !hints "context_used" in
match Str.split (Str.regexp ";") s with
| ids :: _ ->
let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") ids) in
- let ids = List.map (fun id -> Loc.ghost, id) ids in
+ let ids = List.map (fun id -> Loc.tag id) ids in
begin match ids with
| [] -> SsEmpty
| x :: xs ->
@@ -1118,15 +1122,15 @@ let get_hint_ctx loc =
| _ -> raise Not_found
let get_hint_bp_time proof_name =
- try float_of_string (Aux_file.get !hints Loc.ghost proof_name)
+ try float_of_string (Aux_file.get !hints proof_name)
with Not_found -> 1.0
-let record_pb_time proof_name loc time =
+let record_pb_time ?loc proof_name time =
let proof_build_time = Printf.sprintf "%.3f" time in
- Aux_file.record_in_aux_at loc "proof_build_time" proof_build_time;
+ Aux_file.record_in_aux_at ?loc "proof_build_time" proof_build_time;
if proof_name <> "" then begin
- Aux_file.record_in_aux_at Loc.ghost proof_name proof_build_time;
- hints := Aux_file.set !hints Loc.ghost proof_name proof_build_time
+ Aux_file.record_in_aux_at proof_name proof_build_time;
+ hints := Aux_file.set !hints proof_name proof_build_time
end
exception RemoteException of Pp.std_ppcmds
@@ -1170,7 +1174,7 @@ let register_proof_block_delimiter name static dynamic =
let mk_doc_node id = function
| { step = `Cmd { ctac; cast = { indentation; expr }}; next } when ctac ->
Some { indentation; ast = expr; id }
- | { step = `Sideff (`Ast ({ indentation; expr }, _)); next } ->
+ | { step = `Sideff (ReplayCommand { indentation; expr }, _); next } ->
Some { indentation; ast = expr; id }
| _ -> None
let prev_node { id } =
@@ -1217,7 +1221,7 @@ module rec ProofTask : sig
t_drop : bool;
t_states : competence;
t_assign : Proof_global.closed_proof_output Future.assignement -> unit;
- t_loc : Loc.t;
+ t_loc : Loc.t option;
t_uuid : Future.UUID.t;
t_name : string }
@@ -1235,8 +1239,9 @@ module rec ProofTask : sig
and type request := request
val build_proof_here :
+ ?loc:Loc.t ->
drop_pt:bool ->
- Stateid.t * Stateid.t -> Loc.t -> Stateid.t ->
+ Stateid.t * Stateid.t -> Stateid.t ->
Proof_global.closed_proof_output Future.computation
(* If set, only tasks overlapping with this list are processed *)
@@ -1254,7 +1259,7 @@ end = struct (* {{{ *)
t_drop : bool;
t_states : competence;
t_assign : Proof_global.closed_proof_output Future.assignement -> unit;
- t_loc : Loc.t;
+ t_loc : Loc.t option;
t_uuid : Future.UUID.t;
t_name : string }
@@ -1322,7 +1327,7 @@ end = struct (* {{{ *)
RespBuiltProof (pl, time) ->
feedback (InProgress ~-1);
t_assign (`Val pl);
- record_pb_time t_name t_loc time;
+ record_pb_time ?loc:t_loc t_name time;
if !Flags.async_proofs_full || t_drop
then `Stay(t_states,[States t_states])
else `End
@@ -1343,16 +1348,16 @@ end = struct (* {{{ *)
let info = Stateid.add ~valid:start Exninfo.null start in
let e = (RemoteException (Pp.strbrk s), info) in
t_assign (`Exn e);
- execution_error start Loc.ghost (Pp.strbrk s);
+ execution_error start (Pp.strbrk s);
feedback (InProgress ~-1)
- let build_proof_here ~drop_pt (id,valid) loc eop =
+ let build_proof_here ?loc ~drop_pt (id,valid) eop =
Future.create (State.exn_on id ~valid) (fun () ->
let wall_clock1 = Unix.gettimeofday () in
if !Flags.batch_mode then Reach.known_state ~cache:`No eop
else Reach.known_state ~cache:`Shallow eop;
let wall_clock2 = Unix.gettimeofday () in
- Aux_file.record_in_aux_at loc "proof_build_time"
+ Aux_file.record_in_aux_at ?loc "proof_build_time"
(Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
let p = Proof_global.return_proof ~allow_partial:drop_pt () in
if drop_pt then feedback ~id Complete;
@@ -1364,7 +1369,7 @@ end = struct (* {{{ *)
VCS.print ();
let proof, future_proof, time =
let wall_clock = Unix.gettimeofday () in
- let fp = build_proof_here ~drop_pt:drop exn_info loc stop in
+ let fp = build_proof_here ?loc ~drop_pt:drop exn_info stop in
let proof = Future.force fp in
proof, fp, Unix.gettimeofday () -. wall_clock in
(* We typecheck the proof with the kernel (in the worker) to spot
@@ -1446,7 +1451,7 @@ end = struct (* {{{ *)
msg_error(Pp.strbrk("Marshalling error: "^s^". "^
"The system state could not be sent to the worker process. "^
"Falling back to local, lazy, evaluation."));
- t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop));
+ t_assign(`Comp(build_proof_here ?loc:t_loc ~drop_pt t_exn_info t_stop));
feedback (InProgress ~-1)
end (* }}} *)
@@ -1456,7 +1461,7 @@ and Slaves : sig
(* (eventually) remote calls *)
val build_proof :
- loc:Loc.t -> drop_pt:bool ->
+ ?loc:Loc.t -> drop_pt:bool ->
exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t ->
name:string -> future_proof * cancel_switch
@@ -1535,8 +1540,8 @@ end = struct (* {{{ *)
| { step = `Cmd { cast = { loc } } }
| { step = `Fork (( { loc }, _, _, _), _) }
| { step = `Qed ( { qast = { loc } }, _) }
- | { step = `Sideff (`Ast ( { loc }, _)) } ->
- let start, stop = Loc.unloc loc in
+ | { step = `Sideff (ReplayCommand { loc }, _) } ->
+ let start, stop = Option.cata Loc.unloc (0,0) loc in
msg_error Pp.(
str"File " ++ str name ++ str ": proof of " ++ str r_name ++
str ": chars " ++ int start ++ str "-" ++ int stop ++
@@ -1592,10 +1597,10 @@ end = struct (* {{{ *)
let info_tasks l =
CList.map_i (fun i ({ Stateid.loc; name }, _) ->
let time1 =
- try float_of_string (Aux_file.get !hints loc "proof_build_time")
+ try float_of_string (Aux_file.get ?loc !hints "proof_build_time")
with Not_found -> 0.0 in
let time2 =
- try float_of_string (Aux_file.get !hints loc "proof_check_time")
+ try float_of_string (Aux_file.get ?loc !hints "proof_check_time")
with Not_found -> 0.0 in
name, max (time1 +. time2) 0.0001,i) 0 l
@@ -1616,7 +1621,7 @@ end = struct (* {{{ *)
BuildProof { t_states = s2 } -> overlap_rel s1 s2
| _ -> 0)
- let build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname =
+ let build_proof ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname =
let id, valid as t_exn_info = exn_info in
let cancel_switch = ref false in
if TaskQueue.n_workers (Option.get !queue) = 0 then
@@ -1631,7 +1636,7 @@ end = struct (* {{{ *)
TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
f, cancel_switch
end else
- ProofTask.build_proof_here ~drop_pt t_exn_info loc block_stop, cancel_switch
+ ProofTask.build_proof_here ?loc ~drop_pt t_exn_info block_stop, cancel_switch
else
let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in
let t_uuid = Future.uuid f in
@@ -1835,7 +1840,7 @@ end = struct (* {{{ *)
let gid = Goal.goal g in
let f =
try List.assoc gid res
- with Not_found -> CErrors.anomaly(str"Partac: wrong focus") in
+ with Not_found -> CErrors.anomaly(str"Partac: wrong focus.") in
if not (Future.is_over f) then
(* One has failed and cancelled the others, but not this one *)
if solve then Tacticals.New.tclZEROMSG
@@ -2001,10 +2006,10 @@ let collect_proof keep cur hd brkind id =
let rec collect last accn id =
let view = VCS.visit id in
match view.step with
- | (`Sideff (`Ast(x,_)) | `Cmd { cast = x })
+ | (`Sideff (ReplayCommand x,_) | `Cmd { cast = x })
when too_complex_to_delegate x -> `Sync(no_name,None,`Print)
| `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next
- | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next
+ | `Sideff (ReplayCommand x,_) -> collect (Some (id,x)) (id::accn) view.next
(* An Alias could jump everywhere... we hope we can ignore it*)
| `Alias _ -> `Sync (no_name,None,`Alias)
| `Fork((_,_,_,_::_::_), _) ->
@@ -2116,7 +2121,7 @@ let known_state ?(redefine_qed=false) ~cache id =
feedback ~id:id Feedback.AddedAxiom;
fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ());
Option.iter (fun expr -> stm_vernac_interp id {
- verbose = true; loc = Loc.ghost; expr; indentation = 0;
+ verbose = true; loc = None; expr; indentation = 0;
strlen = 0 })
recovery_command
| _ -> assert false
@@ -2238,7 +2243,7 @@ let known_state ?(redefine_qed=false) ~cache id =
^"the proof's statement to avoid that."));
let fp, cancel =
Slaves.build_proof
- ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in
+ ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in
Future.replace ofp fp;
qed.fproof <- Some (fp, cancel);
(* We don't generate a new state, but we still need
@@ -2250,10 +2255,10 @@ let known_state ?(redefine_qed=false) ~cache id =
let fp, cancel =
if delegate then
Slaves.build_proof
- ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name
+ ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name
else
- ProofTask.build_proof_here
- ~drop_pt exn_info loc block_stop, ref false
+ ProofTask.build_proof_here ?loc
+ ~drop_pt exn_info block_stop, ref false
in
qed.fproof <- Some (fp, cancel);
let proof =
@@ -2273,7 +2278,7 @@ let known_state ?(redefine_qed=false) ~cache id =
log_processing_sync id name reason;
reach eop;
let wall_clock = Unix.gettimeofday () in
- record_pb_time name x.loc (wall_clock -. !wall_clock_last_fork);
+ record_pb_time name ?loc:x.loc (wall_clock -. !wall_clock_last_fork);
let proof =
match keep with
| VtDrop -> None
@@ -2290,7 +2295,7 @@ let known_state ?(redefine_qed=false) ~cache id =
let wall_clock2 = Unix.gettimeofday () in
stm_vernac_interp id ?proof x;
let wall_clock3 = Unix.gettimeofday () in
- Aux_file.record_in_aux_at x.loc "proof_check_time"
+ Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time"
(Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2));
Proof_global.discard_all ()
), `Yes, true
@@ -2303,10 +2308,10 @@ let known_state ?(redefine_qed=false) ~cache id =
), (if redefine_qed then `No else `Yes), true
in
aux (collect_proof keep (view.next, x) brname brinfo eop)
- | `Sideff (`Ast (x,_)) -> (fun () ->
+ | `Sideff (ReplayCommand x,_) -> (fun () ->
reach view.next; stm_vernac_interp id x; update_global_env ()
), cache, true
- | `Sideff (`Id origin) -> (fun () ->
+ | `Sideff (CherryPickEnv, origin) -> (fun () ->
reach view.next;
inject_non_pstate (pure_cherry_pick_non_pstate view.next origin);
), cache, true
@@ -2427,7 +2432,7 @@ let merge_proof_branch ~valid ?id qast keep brname =
let id = VCS.new_node ?id () in
VCS.merge id ~ours:(Qed (qed None)) brname;
VCS.delete_branch brname;
- VCS.propagate_sideff ~replay:None;
+ VCS.propagate_sideff ~action:CherryPickEnv;
`Ok
| { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } ->
let ofp =
@@ -2452,7 +2457,7 @@ let handle_failure (e, info) vcs =
VCS.restore vcs;
VCS.print ();
anomaly(str"error with no safe_id attached:" ++ spc() ++
- CErrors.iprint_no_report (e, info))
+ CErrors.iprint_no_report (e, info) ++ str".")
| Some (safe_id, id) ->
stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
VCS.restore vcs;
@@ -2484,7 +2489,7 @@ let process_transaction ?(newtip=Stateid.fresh ())
| VtStm (VtJoinDocument, b), VtNow -> join (); `Ok
| VtStm (VtWait, b), VtNow -> finish (); wait (); `Ok
| VtStm ((VtJoinDocument|VtWait),_), VtLater ->
- anomaly(str"classifier: join actions cannot be classified as VtLater")
+ anomaly(str"classifier: join actions cannot be classified as VtLater.")
(* Back *)
| VtStm (VtBack oid, true), w ->
@@ -2512,7 +2517,7 @@ let process_transaction ?(newtip=Stateid.fresh ())
VCS.checkout_shallowest_proof_branch ();
Reach.known_state ~cache:(interactive ()) id; `Ok
| VtStm (VtBack id, false), VtLater ->
- anomaly(str"classifier: VtBack + VtLater must imply part_of_script")
+ anomaly(str"classifier: VtBack + VtLater must imply part_of_script.")
(* Query *)
| VtQuery (false,(report_id,route)), VtNow ->
@@ -2533,7 +2538,7 @@ let process_transaction ?(newtip=Stateid.fresh ())
VCS.commit id (mkTransCmd x [] false queue);
Backtrack.record (); if w == VtNow then finish (); `Ok
| VtQuery (false,_), VtLater ->
- anomaly(str"classifier: VtQuery + VtLater must imply part_of_script")
+ anomaly(str"classifier: VtQuery + VtLater must imply part_of_script.")
(* Proof *)
| VtStartProof (mode, guarantee, names), w ->
@@ -2550,7 +2555,7 @@ let process_transaction ?(newtip=Stateid.fresh ())
Proof_global.activate_proof_mode mode;
Backtrack.record (); if w == VtNow then finish (); `Ok
| VtProofMode _, VtLater ->
- anomaly(str"VtProofMode must be executed VtNow")
+ anomaly(str"VtProofMode must be executed VtNow.")
| VtProofMode mode, VtNow ->
let id = VCS.new_node ~id:newtip () in
VCS.commit id (mkTransCmd x [] false `MainQueue);
@@ -2598,10 +2603,10 @@ let process_transaction ?(newtip=Stateid.fresh ())
VCS.commit id (mkTransCmd x l in_proof `MainQueue);
(* We can't replay a Definition since universes may be differently
* inferred. This holds in Coq >= 8.5 *)
- let replay = match x.expr with
- | VernacDefinition(_, _, DefineBody _) -> None
- | _ -> Some x in
- VCS.propagate_sideff ~replay;
+ let action = match x.expr with
+ | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv
+ | _ -> ReplayCommand x in
+ VCS.propagate_sideff ~action;
VCS.checkout_shallowest_proof_branch ();
Backtrack.record (); if w == VtNow then finish (); `Ok
@@ -2632,16 +2637,20 @@ let process_transaction ?(newtip=Stateid.fresh ())
end else begin
VCS.commit id (mkTransCmd x [] in_proof `MainQueue);
(* We hope it can be replayed, but we can't really know *)
- VCS.propagate_sideff ~replay:(Some x);
+ VCS.propagate_sideff ~action:(ReplayCommand x);
VCS.checkout_shallowest_proof_branch ();
end in
State.define ~safe_id:head_id ~cache:`Yes step id;
Backtrack.record (); `Ok
| VtUnknown, VtLater ->
- anomaly(str"classifier: VtUnknown must imply VtNow")
+ anomaly(str"classifier: VtUnknown must imply VtNow.")
end in
- stm_prerr_endline (fun () -> "processed }}}");
+ let pr_rc rc = match rc with
+ | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"])
+ | _ -> Pp.(str "unfocus")
+ in
+ stm_pperr_endline (fun () -> str "processed with " ++ pr_rc rc ++ str " }}}");
VCS.print ();
rc
with e ->
@@ -2653,7 +2662,7 @@ let get_ast id =
| { step = `Cmd { cast = { loc; expr } } }
| { step = `Fork (({ loc; expr }, _, _, _), _) }
| { step = `Qed ({ qast = { loc; expr } }, _) } ->
- Some (expr, loc)
+ Some (Loc.tag ?loc expr)
| _ -> None
let stop_worker n = Slaves.cancel_worker n
@@ -2681,7 +2690,7 @@ let parse_sentence sid pa =
(str "Currently, the parsing api only supports parsing at the tip of the document." ++ fnl () ++
str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++
str " but the current tip is: " ++ str (Stateid.to_string cur_tip)) ;
- if not (Stateid.equal sid real_tip) && !Flags.debug && stm_debug then
+ if not (Stateid.equal sid real_tip) && !Flags.debug && stm_debug () then
Feedback.msg_debug
(str "Warning, the real tip doesn't match the current tip." ++
str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++
@@ -2691,8 +2700,8 @@ let parse_sentence sid pa =
Flags.with_option Flags.we_are_parsing (fun () ->
try
match Pcoq.Gram.entry_parse Pcoq.main_entry pa with
- | None -> raise End_of_input
- | Some com -> com
+ | None -> raise End_of_input
+ | Some (loc, cmd) -> Loc.tag ~loc cmd
with e when CErrors.noncritical e ->
let (e, info) = CErrors.push e in
Exninfo.iraise (e, info))
@@ -2717,7 +2726,7 @@ let ind_len_loc_of_id sid =
Note, this could maybe improved by handling more cases in
compute_indentation. *)
-let compute_indentation sid loc =
+let compute_indentation ?loc sid = Option.cata (fun loc ->
let open Loc in
(* The effective lenght is the lenght on the last line *)
let len = loc.ep - loc.bp in
@@ -2731,16 +2740,16 @@ let compute_indentation sid loc =
eff_indent + prev_indent, len
else
eff_indent, len
-
+ ) (0, 0) loc
let add ~ontop ?newtip verb (loc, ast) =
let cur_tip = VCS.cur_tip () in
if not (Stateid.equal ontop cur_tip) then
- user_err ~hdr:"Stm.add"
+ user_err ?loc ~hdr:"Stm.add"
(str "Stm.add called for a different state (" ++ str (Stateid.to_string ontop) ++
str ") than the tip: " ++ str (Stateid.to_string cur_tip) ++ str "." ++ fnl () ++
str "This is not supported yet, sorry.");
- let indentation, strlen = compute_indentation ontop loc in
+ let indentation, strlen = compute_indentation ?loc ontop in
CWarnings.set_current_loc loc;
(* XXX: Classifiy vernac should be moved inside process transaction *)
let clas = classify_vernac ast in
@@ -2762,7 +2771,7 @@ let query ~at ?(report_with=(Stateid.dummy,default_route)) s =
if Stateid.equal at Stateid.dummy then finish ()
else Reach.known_state ~cache:`Yes at;
let loc, ast = parse_sentence at s in
- let indentation, strlen = compute_indentation at loc in
+ let indentation, strlen = compute_indentation ?loc at in
CWarnings.set_current_loc loc;
let clas = classify_vernac ast in
let aast = { verbose = true; indentation; strlen; loc; expr = ast } in
@@ -2774,7 +2783,7 @@ let query ~at ?(report_with=(Stateid.dummy,default_route)) s =
s
let edit_at id =
- if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy") else
+ if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy.") else
let vcs = VCS.backup () in
let on_cur_branch id =
let rec aux cur =
@@ -2805,7 +2814,7 @@ let edit_at id =
if Stateid.equal tip Stateid.initial then tip else
match VCS.visit tip with
| { step = (`Fork _ | `Qed _) } -> tip
- | { step = `Sideff (`Ast(_,id)) } -> id
+ | { step = `Sideff (ReplayCommand _,id) } -> id
| { step = `Sideff _ } -> tip
| { next } -> master_for_br root next in
let reopen_branch start at_id mode qed_id tip old_branch =
@@ -2813,7 +2822,7 @@ let edit_at id =
(* Hum, this should be the real start_id in the cluster and not next *)
match VCS.visit qed_id with
| { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep
- | _ -> anomaly (str "ProofTask not ending with Qed") in
+ | _ -> anomaly (str "ProofTask not ending with Qed.") in
VCS.branch ~root:master_id ~pos:id
VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch));
VCS.delete_boxes_of id;
@@ -2865,7 +2874,7 @@ let edit_at id =
end else if is_ancestor_of_cur_branch id then begin
backto id (Some bn)
end else begin
- anomaly(str"Cannot leave an `Edit branch open")
+ anomaly(str"Cannot leave an `Edit branch open.")
end
| true, None, _ ->
if on_cur_branch id then begin
@@ -2876,7 +2885,7 @@ let edit_at id =
end else if is_ancestor_of_cur_branch id then begin
backto id None
end else begin
- anomaly(str"Cannot leave an `Edit branch open")
+ anomaly(str"Cannot leave an `Edit branch open.")
end
| false, None, Some(_,bn) -> backto id (Some bn)
| false, None, None -> backto id None
@@ -2889,7 +2898,7 @@ let edit_at id =
| None ->
VCS.print ();
anomaly (str ("edit_at "^Stateid.to_string id^": ") ++
- CErrors.print_no_report e)
+ CErrors.print_no_report e ++ str ".")
| Some (_, id) ->
stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
VCS.restore vcs;
diff --git a/stm/stm.mli b/stm/stm.mli
index d2bee44964..b150f97489 100644
--- a/stm/stm.mli
+++ b/stm/stm.mli
@@ -84,7 +84,7 @@ val get_current_state : unit -> Stateid.t
val init : unit -> unit
(* This returns the node at that position *)
-val get_ast : Stateid.t -> (Vernacexpr.vernac_expr * Loc.t) option
+val get_ast : Stateid.t -> (Vernacexpr.vernac_expr Loc.located) option
(* Filename *)
val set_compilation_hints : string -> unit
diff --git a/stm/tQueue.ml b/stm/tQueue.ml
index a0b08778ba..fee4f35b49 100644
--- a/stm/tQueue.ml
+++ b/stm/tQueue.ml
@@ -88,7 +88,7 @@ let broadcast { lock = m; cond = c } =
let push { queue = q; lock = m; cond = c; release } x =
if release then CErrors.anomaly(Pp.str
- "TQueue.push while being destroyed! Only 1 producer/destroyer allowed");
+ "TQueue.push while being destroyed! Only 1 producer/destroyer allowed.");
Mutex.lock m;
PriorityQueue.push q x;
Condition.broadcast c;
diff --git a/stm/vcs.ml b/stm/vcs.ml
index 88f860eb69..df3b8aa621 100644
--- a/stm/vcs.ml
+++ b/stm/vcs.ml
@@ -113,7 +113,7 @@ let add_node vcs id edges =
let get_branch vcs head =
try BranchMap.find head vcs.heads
- with Not_found -> anomaly (str"head " ++ str head ++ str" not found")
+ with Not_found -> anomaly (str"head " ++ str head ++ str" not found.")
let reset_branch vcs head id =
let map name h =
diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml
index c4f392f201..d597f64ada 100644
--- a/stm/vernac_classifier.ml
+++ b/stm/vernac_classifier.ml
@@ -206,7 +206,7 @@ let rec classify_vernac e =
(* Plugins should classify their commands *)
| VernacExtend (s,l) ->
try List.assoc s !classifiers l ()
- with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s))
+ with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".")
in
let res = static_classifier e in
if Flags.is_universe_polymorphism () then
diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml
index a6237daa04..9f50ab589d 100644
--- a/stm/vio_checking.ml
+++ b/stm/vio_checking.ml
@@ -24,7 +24,7 @@ end
module Pool = Map.Make(IntOT)
let schedule_vio_checking j fs =
- if j < 1 then CErrors.error "The number of workers must be bigger than 0";
+ if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0");
let jobs = ref [] in
List.iter (fun f ->
let f =
@@ -98,7 +98,7 @@ let schedule_vio_checking j fs =
exit !rc
let schedule_vio_compilation j fs =
- if j < 1 then CErrors.error "The number of workers must be bigger than 0";
+ if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0");
let jobs = ref [] in
List.iter (fun f ->
let f =
@@ -107,7 +107,7 @@ let schedule_vio_compilation j fs =
let long_f_dot_v = Loadpath.locate_file (f^".v") in
let aux = Aux_file.load_aux_file_for long_f_dot_v in
let eta =
- try float_of_string (Aux_file.get aux Loc.ghost "vo_compile_time")
+ try float_of_string (Aux_file.get aux "vo_compile_time")
with Not_found -> 0.0 in
jobs := (f, eta) :: !jobs)
fs;
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 22:16:31 +0000