diff --git a/src/base/Proof.ml b/src/base/Proof.ml index e91bbdc0..30dc7efc 100644 --- a/src/base/Proof.ml +++ b/src/base/Proof.ml @@ -51,6 +51,7 @@ end (* a step is just a unique integer ID. The actual step is stored in the chunk_stack. *) type proof_step = Proof_ser.ID.t +type term_id = Proof_ser.ID.t type lit = Lit.t type term = Term.t @@ -58,9 +59,13 @@ type term = Term.t type t = { mutable enabled : bool; config: Config.t; + buf: Buffer.t; mutable storage: Storage.t; mutable dispose: unit -> unit; - mutable steps: CS.Writer.t; + mutable steps_writer: CS.Writer.t; + mutable next_id: int; + map_term: term_id Term.Tbl.t; (* term -> proof ID *) + map_fun: term_id Fun.Tbl.t; } type proof_rule = t -> proof_step @@ -73,14 +78,14 @@ let disable (self:t) : unit = self.enabled <- false; self.storage <- Storage.No_store; self.dispose(); - self.steps <- CS.Writer.dummy; + self.steps_writer <- CS.Writer.dummy; () let nop_ _ = () let create ?(config=Config.default) () : t = (* acquire resources for logging *) - let storage, steps, dispose = + let storage, steps_writer, dispose = match config.Config.storage with | Config.No_store -> Storage.No_store, CS.Writer.dummy, nop_ @@ -99,7 +104,12 @@ let create ?(config=Config.default) () : t = in { enabled=config.Config.enabled; config; - steps; storage; dispose; } + next_id=1; + buf=Buffer.create 1_024; + map_term=Term.Tbl.create 32; + map_fun=Fun.Tbl.create 32; + steps_writer; storage; dispose; + } let iter_chunks_ (r:CS.Reader.t) k = let rec loop () = @@ -127,14 +137,77 @@ let iter_steps_backward (self:t) : Proof_ser.Step.t Iter.t = iter_chunks_ iter yield end -let dummy_step : proof_step = -1l +let dummy_step : proof_step = Int32.min_int let[@inline] enabled (self:t) = self.enabled -let begin_subproof _ = dummy_step -let end_subproof _ = dummy_step +(* allocate a unique ID to refer to an event in the trace *) +let[@inline] alloc_id (self:t) : Proof_ser.ID.t = + let n = self.next_id in + self.next_id <- 1 + self.next_id; + Int32.of_int n + +(* emit a proof step *) +let emit_step_ (self:t) (step:Proof_ser.Step.t) : unit = + if enabled self then ( + Buffer.clear self.buf; + Proof_ser.Step.encode self.buf step; + Chunk_stack.Writer.add_buffer self.steps_writer self.buf; + ) + +let emit_fun_ (self:t) (f:Fun.t) : term_id = + try Fun.Tbl.find self.map_fun f + with Not_found -> + let id = alloc_id self in + Fun.Tbl.add self.map_fun f id; + let f_name = ID.to_string (Fun.id f) in + emit_step_ self + Proof_ser.({ Step.id; view=Fun_decl {Fun_decl.f=f_name}}); + id + +let rec emit_term_ (self:t) (t:Term.t) : term_id = + try Term.Tbl.find self.map_term t + with Not_found -> + let view = match Term_cell.map (emit_term_ self) @@ Term.view t with + | Term_cell.Bool b -> + Proof_ser.Step_view.Expr_bool {Proof_ser.Expr_bool.b} + + | Term_cell.Ite (a,b,c) -> + Proof_ser.Step_view.Expr_if {Proof_ser.Expr_if.cond=a; then_=b; else_=c} + + | Term_cell.Not a -> + Proof_ser.Step_view.Expr_not {Proof_ser.Expr_not.f=a} + + | Term_cell.App_fun (f, arr) -> + let f = emit_fun_ self f in + Proof_ser.Step_view.Expr_app {Proof_ser.Expr_app.f; args=(arr:_ IArray.t:> _ array)} + + | Term_cell.Eq (a, b) -> + Proof_ser.Step_view.Expr_eq {Proof_ser.Expr_eq.lhs=a; rhs=b} + + | LRA _ -> assert false (* TODO *) + in + + let id = alloc_id self in + emit_step_ self Proof_ser.({id; view}); + id + +let emit_lit_ (self:t) (lit:Lit.t) : term_id = + let sign = Lit.sign lit in + let t = emit_term_ self (Lit.term lit) in + if sign then t else Int32.neg t + let emit_redundant_clause _ ~hyps:_ _ = dummy_step -let emit_input_clause _ _ = dummy_step +let emit_input_clause (lits:Lit.t Iter.t) (self:t) = + if enabled self then ( + let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in + let id = alloc_id self in + emit_step_ self ( + Proof_ser.({Step.id; view=Step_view.Step_input {Step_input.c={Clause.lits}}}) + ); + id + ) else dummy_step + let define_term _ _ _ = dummy_step let proof_p1 _ _ (_pr:t) = dummy_step let lemma_preprocess _ _ ~using:_ (_pr:t) = dummy_step diff --git a/src/base/Proof_dummy.ml b/src/base/Proof_dummy.ml index 6fe22d51..c44d5f72 100644 --- a/src/base/Proof_dummy.ml +++ b/src/base/Proof_dummy.ml @@ -14,8 +14,6 @@ let create () : t = () let with_proof _ _ = () let enabled (_pr:t) = false -let begin_subproof _ = () -let end_subproof _ = () let del_clause _ _ (_pr:t) = () let emit_redundant_clause _ ~hyps:_ _ = () let emit_input_clause _ _ = () diff --git a/src/base/proof_ser.bare b/src/base/proof_ser.bare index b3224e94..b4a05cd4 100644 --- a/src/base/proof_ser.bare +++ b/src/base/proof_ser.bare @@ -1,17 +1,22 @@ type ID i32 -type Lit int +type Lit ID type Clause { lits: []Lit } +type Step_input { + c: Clause +} + # clause, RUP with previous steps type Step_rup { res: Clause steps: []ID } +# TODO: remove? # lit <-> expr type Step_bridge_lit_expr { lit: Lit @@ -31,11 +36,46 @@ type Step_preprocess { using: []ID } +type Fun_decl { + f: string +} + +type Expr_bool { + b: bool +} + +type Expr_if { + cond: ID + then_: ID + else_: ID +} + +type Expr_not { + f: ID +} + +type Expr_eq { + lhs: ID + rhs: ID +} + +type Expr_app { + f: ID + args: []ID +} + type Step_view - ( Step_rup + ( Step_input + | Step_rup | Step_bridge_lit_expr | Step_cc | Step_preprocess + | Fun_decl + | Expr_bool + | Expr_if + | Expr_not + | Expr_eq + | Expr_app ) type Step { diff --git a/src/base/proof_ser.ml b/src/base/proof_ser.ml index a0323bf4..421660a1 100644 --- a/src/base/proof_ser.ml +++ b/src/base/proof_ser.ml @@ -252,14 +252,14 @@ module ID = struct end module Lit = struct - type t = int64 + type t = ID.t (** @raise Bare.Decode.Error in case of error. *) let decode (dec: Bare.Decode.t) : t = - Bare.Decode.int dec + ID.decode dec let encode (enc: Bare.Encode.t) (self: t) : unit = - Bare.Encode.int enc self + ID.encode enc self end @@ -285,6 +285,20 @@ module Clause = struct end +module Step_input = struct + type t = { + c: Clause.t; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let c = Clause.decode dec in {c; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin Clause.encode enc self.c; end + +end + module Step_rup = struct type t = { res: Clause.t; @@ -375,39 +389,179 @@ module Step_preprocess = struct end +module Fun_decl = struct + type t = { + f: string; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let f = Bare.Decode.string dec in {f; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin Bare.Encode.string enc self.f; end + +end + +module Expr_bool = struct + type t = { + b: bool; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let b = Bare.Decode.bool dec in {b; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin Bare.Encode.bool enc self.b; end + +end + +module Expr_if = struct + type t = { + cond: ID.t; + then_: ID.t; + else_: ID.t; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let cond = ID.decode dec in + let then_ = ID.decode dec in + let else_ = ID.decode dec in + {cond; then_; else_; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin + ID.encode enc self.cond; + ID.encode enc self.then_; + ID.encode enc self.else_; + end + +end + +module Expr_not = struct + type t = { + f: ID.t; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let f = ID.decode dec in {f; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin ID.encode enc self.f; end + +end + +module Expr_eq = struct + type t = { + lhs: ID.t; + rhs: ID.t; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let lhs = ID.decode dec in let rhs = ID.decode dec in {lhs; rhs; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin ID.encode enc self.lhs; ID.encode enc self.rhs; end + +end + +module Expr_app = struct + type t = { + f: ID.t; + args: ID.t array; + } + + (** @raise Bare.Decode.Error in case of error. *) + let decode (dec: Bare.Decode.t) : t = + let f = ID.decode dec in + let args = + (let len = Bare.Decode.uint dec in + if len>Int64.of_int Sys.max_array_length then raise (Bare.Decode.Error"array too big"); + Array.init (Int64.to_int len) (fun _ -> ID.decode dec)) in + {f; args; } + + let encode (enc: Bare.Encode.t) (self: t) : unit = + begin + ID.encode enc self.f; + (let arr = self.args in + Bare.Encode.uint enc (Int64.of_int (Array.length arr)); + Array.iter (fun xi -> ID.encode enc xi) arr); + end + +end + module Step_view = struct type t = + | Step_input of Step_input.t | Step_rup of Step_rup.t | Step_bridge_lit_expr of Step_bridge_lit_expr.t | Step_cc of Step_cc.t | Step_preprocess of Step_preprocess.t + | Fun_decl of Fun_decl.t + | Expr_bool of Expr_bool.t + | Expr_if of Expr_if.t + | Expr_not of Expr_not.t + | Expr_eq of Expr_eq.t + | Expr_app of Expr_app.t (** @raise Bare.Decode.Error in case of error. *) let decode (dec: Bare.Decode.t) : t = let tag = Bare.Decode.uint dec in match tag with - | 0L -> Step_rup (Step_rup.decode dec) - | 1L -> Step_bridge_lit_expr (Step_bridge_lit_expr.decode dec) - | 2L -> Step_cc (Step_cc.decode dec) - | 3L -> Step_preprocess (Step_preprocess.decode dec) + | 0L -> Step_input (Step_input.decode dec) + | 1L -> Step_rup (Step_rup.decode dec) + | 2L -> Step_bridge_lit_expr (Step_bridge_lit_expr.decode dec) + | 3L -> Step_cc (Step_cc.decode dec) + | 4L -> Step_preprocess (Step_preprocess.decode dec) + | 5L -> Fun_decl (Fun_decl.decode dec) + | 6L -> Expr_bool (Expr_bool.decode dec) + | 7L -> Expr_if (Expr_if.decode dec) + | 8L -> Expr_not (Expr_not.decode dec) + | 9L -> Expr_eq (Expr_eq.decode dec) + | 10L -> Expr_app (Expr_app.decode dec) | _ -> raise (Bare.Decode.Error(Printf.sprintf "unknown union tag Step_view.t: %Ld" tag)) let encode (enc: Bare.Encode.t) (self: t) : unit = match self with - | Step_rup x -> + | Step_input x -> Bare.Encode.uint enc 0L; + Step_input.encode enc x + | Step_rup x -> + Bare.Encode.uint enc 1L; Step_rup.encode enc x | Step_bridge_lit_expr x -> - Bare.Encode.uint enc 1L; + Bare.Encode.uint enc 2L; Step_bridge_lit_expr.encode enc x | Step_cc x -> - Bare.Encode.uint enc 2L; + Bare.Encode.uint enc 3L; Step_cc.encode enc x | Step_preprocess x -> - Bare.Encode.uint enc 3L; + Bare.Encode.uint enc 4L; Step_preprocess.encode enc x + | Fun_decl x -> + Bare.Encode.uint enc 5L; + Fun_decl.encode enc x + | Expr_bool x -> + Bare.Encode.uint enc 6L; + Expr_bool.encode enc x + | Expr_if x -> + Bare.Encode.uint enc 7L; + Expr_if.encode enc x + | Expr_not x -> + Bare.Encode.uint enc 8L; + Expr_not.encode enc x + | Expr_eq x -> + Bare.Encode.uint enc 9L; + Expr_eq.encode enc x + | Expr_app x -> + Bare.Encode.uint enc 10L; + Expr_app.encode enc x end diff --git a/src/util/Chunk_stack.ml b/src/util/Chunk_stack.ml index 61bbb36f..5547cb75 100644 --- a/src/util/Chunk_stack.ml +++ b/src/util/Chunk_stack.ml @@ -8,6 +8,8 @@ module Buf = struct let create ?(cap=16) () : t = { len=0; b=Bytes.create cap; } + let[@inline] size self = self.len + let resize_ self new_len : unit = let size = min (new_len + new_len / 4 + 5) Sys.max_string_length in if new_len > size then failwith "max buf size exceeded"; @@ -27,6 +29,10 @@ module Buf = struct Bytes.blit b off self.b self.len len; self.len <- self.len + len + let add_buffer (self:t) (buf:Buffer.t) = + ensure_size_ self (size self + Buffer.length buf); + Buffer.blit buf 0 self.b self.len (Buffer.length buf) + let[@inline] add_buf (self:t) (other:t) = add_bytes self other.b 0 other.len @@ -38,11 +44,15 @@ end module Writer = struct type t = { write: bytes -> int -> int -> unit; + write_buf: Buffer.t -> unit; } let nop_ _ = () - let dummy : t = { write=fun _ _ _ -> (); } + let dummy : t = { + write=(fun _ _ _ -> ()); + write_buf=(fun _ -> ()); + } let into_buf (into:Buf.t) : t = let blen = Bytes.create 4 in @@ -52,7 +62,12 @@ module Writer = struct Bytes.set_int32_le blen 0 (Int32.of_int len); Buf.add_bytes into blen 0 4; in - { write; } + let write_buf buf = + Buf.add_buffer into buf; + Bytes.set_int32_le blen 0 (Int32.of_int (Buffer.length buf)); + Buf.add_bytes into blen 0 4; + in + { write; write_buf } let into_channel (oc:out_channel) : t = let blen = Bytes.create 4 in @@ -61,13 +76,19 @@ module Writer = struct (* add len *) Bytes.set_int32_le blen 0 (Int32.of_int len); output oc blen 0 4 + and write_buf buf = + Buffer.output_buffer oc buf; + (* add len *) + Bytes.set_int32_le blen 0 (Int32.of_int (Buffer.length buf)); + output oc blen 0 4 in - { write; } + { write; write_buf; } let[@inline] add_buf self buf = self.write buf.Buf.b 0 buf.Buf.len let[@inline] add_bytes self b i len = self.write b i len let[@inline] add_string self s = add_bytes self (Bytes.unsafe_of_string s) 0 (String.length s) + let[@inline] add_buffer self (buf:Buffer.t) = self.write_buf buf end module Reader = struct diff --git a/src/util/Chunk_stack.mli b/src/util/Chunk_stack.mli index d3bce75c..c577d94e 100644 --- a/src/util/Chunk_stack.mli +++ b/src/util/Chunk_stack.mli @@ -41,6 +41,8 @@ module Writer : sig val add_bytes : t -> bytes -> int -> int -> unit val add_string : t -> string -> unit + + val add_buffer : t -> Buffer.t -> unit end module Reader : sig