Commit 0da5f41e authored by Mário Pereira's avatar Mário Pereira

Why3 "bootstrap":

The code in file /src/util/pqueue.ml has been extracted from a Why3 proof,
and is now a correct-by-construction OCaml code. This file depends on the Vector
module, which is also an OCaml implementation extracted from another Why3 proof.
The proofs can be found in /examples/util/

This is the result of Aymeric Walch bachelor internship.
parent a67650db
......@@ -192,7 +192,7 @@ LIB_UTIL = config bigInt util opt lists strings \
hashcons wstdlib exn_printer \
json_base json_parser json_lexer \
debug loc lexlib print_tree \
cmdline warning sysutil rc plugin bigInt number pqueue
cmdline warning sysutil rc plugin bigInt number vector pqueue
LIB_CORE = ident ty term pattern decl coercion theory \
task pretty dterm env trans printer model_parser
......
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
(* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
(* on linking described in file LICENSE. *)
(* *)
(********************************************************************)
(** This module implements a priority queue based on a minimal binary heap.
The heap is implemented as a dynamic array, taken from the module vector. *)
(** This is a contribution by Aymeric Walch. *)
(*@ use Order *)
(*@ use Bag *)
module Make (X: sig
type t
val dummy : t
(*@ function cmp : t -> t -> int *)
(*@ axiom is_pre_order: Order.is_pre_order cmp *)
val compare : t -> t -> int
(*@ r = compare x y
ensures r = cmp x y *)
end) : sig
type elt = X.t
type t
(*@ ephemeral *)
(*@ mutable model bag : X.t bag *)
(*@ invariant card bag <= Sys.max_array_length *)
(*@ predicate mem (x: elt) (h: t) := nb_occ x h.bag > 0 *)
val create : unit -> t
(*@ h = create ()
ensures h.bag = empty_bag *)
val is_empty : t -> bool
(*@ b = is_empty h
ensures b <-> h.bag = empty_bag *)
val size : t -> int
(* x = size h
ensures x = card h.bag *)
(*@ function minimum: t -> elt *)
(*@ predicate is_minimum (x: elt) (h: t) :=
mem x h && forall e. mem e h -> X.cmp x e <= 0 *)
(*@ axiom min_def:
forall h. 0 < card h.bag -> is_minimum (minimum h) h *)
val find_min : t -> elt option
(*@ r = find_min h
ensures match r with
| None -> card h.bag = 0
| Some x -> card h.bag > 0 && x = minimum h *)
exception Empty
val find_min_exn : t -> elt
(*@ x = find_min_exn h
raises Empty -> card h.bag = 0
ensures card h.bag > 0 && x = minimum h *)
val delete_min_exn : t -> unit
(*@ delete_min_exn h
modifies h
raises Empty -> card h.bag = 0 && h.bag = old h.bag
ensures (old h).bag = add (minimum (old h)) h.bag *)
val extract_min_exn : t -> elt
(*@ x = extract_min_exn h
modifies h
raises Empty -> card h.bag = 0 && h.bag = old h.bag
ensures x = minimum (old h)
ensures (old h).bag = add x h.bag *)
val insert : elt -> t -> unit
(*@ insert x h
checks card h.bag < Sys.max_array_length
modifies h
ensures h.bag = add x (old h).bag *)
end
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
let iteri f a = for i = 0 to length a - 1 do f i (get a i) done
let iter f a =
for i = 0 to length a - 1 do f (get a i) done
This diff is collapsed.
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
"http://why3.lri.fr/why3session.dtd">
<why3session shape_version="4">
<prover id="0" name="Alt-Ergo" version="2.2.0" timelimit="1" steplimit="0" memlimit="1000"/>
<prover id="1" name="CVC4" version="1.5" timelimit="1" steplimit="0" memlimit="1000"/>
<prover id="2" name="CVC4" version="1.4" timelimit="10" steplimit="0" memlimit="4000"/>
<prover id="3" name="Z3" version="4.4.0" timelimit="1" steplimit="0" memlimit="1000"/>
<file name="../Vector_impl.mlw" proved="true">
<theory name="Impl" proved="true">
<goal name="VC t" expl="VC for t" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.01" steps="101"/></proof>
</goal>
<goal name="VC create" expl="VC for create" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.14" steps="400"/></proof>
</goal>
<goal name="VC make" expl="VC for make" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.22" steps="902"/></proof>
</goal>
<goal name="VC init" expl="VC for init" proved="true">
<proof prover="3"><result status="valid" time="0.59"/></proof>
</goal>
<goal name="VC length" expl="VC for length" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.00" steps="10"/></proof>
</goal>
<goal name="VC get" expl="VC for get" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.02" steps="25"/></proof>
</goal>
<goal name="VC set" expl="VC for set" proved="true">
<proof prover="3"><result status="valid" time="0.36"/></proof>
</goal>
<goal name="VC unsafe_resize" expl="VC for unsafe_resize" proved="true">
<proof prover="3"><result status="valid" time="0.81"/></proof>
</goal>
<goal name="VC resize" expl="VC for resize" proved="true">
<proof prover="3"><result status="valid" time="0.02"/></proof>
</goal>
<goal name="VC clear" expl="VC for clear" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.02" steps="20"/></proof>
</goal>
<goal name="VC is_empty" expl="VC for is_empty" proved="true">
<proof prover="3"><result status="valid" time="0.20"/></proof>
</goal>
<goal name="VC sub" expl="VC for sub" proved="true">
<proof prover="1"><result status="valid" time="0.14"/></proof>
</goal>
<goal name="VC fill" expl="VC for fill" proved="true">
<proof prover="1"><result status="valid" time="0.16"/></proof>
</goal>
<goal name="VC blit" expl="VC for blit" proved="true">
<proof prover="3"><result status="valid" time="0.14"/></proof>
</goal>
<goal name="VC append" expl="VC for append" proved="true">
<proof prover="1"><result status="valid" time="0.16"/></proof>
</goal>
<goal name="VC merge_right" expl="VC for merge_right" proved="true">
<proof prover="1"><result status="valid" time="0.15"/></proof>
</goal>
<goal name="VC copy" expl="VC for copy" proved="true">
<proof prover="0"><result status="valid" time="0.08" steps="670"/></proof>
</goal>
<goal name="VC push" expl="VC for push" proved="true">
<proof prover="3"><result status="valid" time="0.56"/></proof>
</goal>
<goal name="VC pop" expl="VC for pop" proved="true">
<proof prover="1"><result status="valid" time="0.12"/></proof>
</goal>
<goal name="VC pop_opt" expl="VC for pop_opt" proved="true">
<proof prover="1"><result status="valid" time="0.12"/></proof>
</goal>
<goal name="VC top" expl="VC for top" proved="true">
<proof prover="0"><result status="valid" time="0.03" steps="96"/></proof>
</goal>
<goal name="VC top_opt" expl="VC for top_opt" proved="true">
<proof prover="0"><result status="valid" time="0.20" steps="1037"/></proof>
</goal>
<goal name="VC fold_left" expl="VC for fold_left" proved="true">
<transf name="split_all_full" proved="true" >
<goal name="VC fold_left.0" expl="integer overflow" proved="true">
<proof prover="3"><result status="valid" time="0.06"/></proof>
</goal>
<goal name="VC fold_left.1" expl="loop invariant init" proved="true">
<proof prover="3"><result status="valid" time="0.06"/></proof>
</goal>
<goal name="VC fold_left.2" expl="precondition" proved="true">
<proof prover="3"><result status="valid" time="0.04"/></proof>
</goal>
<goal name="VC fold_left.3" expl="loop invariant preservation" proved="true">
<proof prover="2"><result status="valid" time="3.58"/></proof>
<transf name="introduce_premises" proved="true" >
<goal name="VC fold_left.3.0" expl="loop invariant preservation" proved="true">
<proof prover="2"><result status="valid" time="4.07"/></proof>
</goal>
</transf>
</goal>
<goal name="VC fold_left.4" expl="postcondition" proved="true">
<proof prover="3"><result status="valid" time="0.03"/></proof>
</goal>
<goal name="VC fold_left.5" expl="postcondition" proved="true">
<proof prover="3"><result status="valid" time="0.04"/></proof>
</goal>
</transf>
</goal>
<goal name="VC fold_right" expl="VC for fold_right" proved="true">
<transf name="split_all_full" proved="true" >
<goal name="VC fold_right.0" expl="integer overflow" proved="true">
<proof prover="3"><result status="valid" time="0.04"/></proof>
</goal>
<goal name="VC fold_right.1" expl="loop invariant init" proved="true">
<proof prover="3"><result status="valid" time="0.07"/></proof>
</goal>
<goal name="VC fold_right.2" expl="precondition" proved="true">
<proof prover="3"><result status="valid" time="0.04"/></proof>
</goal>
<goal name="VC fold_right.3" expl="loop invariant preservation" proved="true">
<proof prover="2"><result status="valid" time="5.31"/></proof>
</goal>
<goal name="VC fold_right.4" expl="postcondition" proved="true">
<proof prover="3"><result status="valid" time="0.04"/></proof>
</goal>
<goal name="VC fold_right.5" expl="postcondition" proved="true">
<proof prover="3"><result status="valid" time="0.04"/></proof>
</goal>
</transf>
</goal>
<goal name="VC map" expl="VC for map" proved="true">
<proof prover="3"><result status="valid" time="0.58"/></proof>
</goal>
<goal name="VC mapi" expl="VC for mapi" proved="true">
<proof prover="3"><result status="valid" time="0.86"/></proof>
</goal>
</theory>
<theory name="Correct" proved="true">
<goal name="Sig.VC t" expl="VC for t" proved="true">
<proof prover="3"><result status="valid" time="0.02"/></proof>
</goal>
<goal name="Sig.VC create" expl="VC for create" proved="true">
<proof prover="0"><result status="valid" time="0.05" steps="205"/></proof>
</goal>
<goal name="Sig.VC make" expl="VC for make" proved="true">
<proof prover="3"><result status="valid" time="0.03"/></proof>
</goal>
<goal name="Sig.VC init" expl="VC for init" proved="true">
<proof prover="3"><result status="valid" time="0.03"/></proof>
</goal>
<goal name="Sig.VC unsafe_resize" expl="VC for unsafe_resize" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.04" steps="152"/></proof>
</goal>
<goal name="Sig.VC resize" expl="VC for resize" proved="true">
<proof prover="0" timelimit="5"><result status="valid" time="0.05" steps="146"/></proof>
</goal>
<goal name="Sig.VC clear" expl="VC for clear" proved="true">
<proof prover="3"><result status="valid" time="0.05"/></proof>
</goal>
<goal name="Sig.VC is_empty" expl="VC for is_empty" proved="true">
<proof prover="0"><result status="valid" time="0.02" steps="49"/></proof>
</goal>
<goal name="Sig.VC length" expl="VC for length" proved="true">
<proof prover="3"><result status="valid" time="0.05"/></proof>
</goal>
<goal name="Sig.VC get" expl="VC for get" proved="true">
<proof prover="3"><result status="valid" time="0.05"/></proof>
</goal>
<goal name="Sig.VC set" expl="VC for set" proved="true">
<proof prover="0"><result status="valid" time="0.10" steps="361"/></proof>
</goal>
<goal name="Sig.VC sub" expl="VC for sub" proved="true">
<proof prover="0"><result status="valid" time="0.03" steps="188"/></proof>
</goal>
<goal name="Sig.VC fill" expl="VC for fill" proved="true">
<proof prover="0"><result status="valid" time="0.04" steps="249"/></proof>
</goal>
<goal name="Sig.VC blit" expl="VC for blit" proved="true">
<proof prover="0"><result status="valid" time="0.15" steps="360"/></proof>
</goal>
<goal name="Sig.VC append" expl="VC for append" proved="true">
<proof prover="0"><result status="valid" time="0.84" steps="1245"/></proof>
</goal>
<goal name="Sig.VC merge_right" expl="VC for merge_right" proved="true">
<proof prover="0"><result status="valid" time="0.80" steps="1707"/></proof>
</goal>
<goal name="Sig.VC map" expl="VC for map" proved="true">
<proof prover="3"><result status="valid" time="0.03"/></proof>
</goal>
<goal name="Sig.VC mapi" expl="VC for mapi" proved="true">
<proof prover="3"><result status="valid" time="0.03"/></proof>
</goal>
<goal name="Sig.VC copy" expl="VC for copy" proved="true">
<proof prover="3"><result status="valid" time="0.05"/></proof>
</goal>
<goal name="Sig.VC fold_left" expl="VC for fold_left" proved="true">
<proof prover="3"><result status="valid" time="0.02"/></proof>
</goal>
<goal name="Sig.VC fold_right" expl="VC for fold_right" proved="true">
<proof prover="3"><result status="valid" time="0.01"/></proof>
</goal>
<goal name="Sig.VC push" expl="VC for push" proved="true">
<proof prover="0"><result status="valid" time="0.06" steps="196"/></proof>
</goal>
<goal name="Sig.VC pop" expl="VC for pop" proved="true">
<proof prover="0"><result status="valid" time="0.02" steps="274"/></proof>
</goal>
<goal name="Sig.VC pop_opt" expl="VC for pop_opt" proved="true">
<proof prover="0"><result status="valid" time="0.36" steps="540"/></proof>
</goal>
<goal name="Sig.VC top" expl="VC for top" proved="true">
<proof prover="3"><result status="valid" time="0.02"/></proof>
</goal>
<goal name="Sig.VC top_opt" expl="VC for top_opt" proved="true">
<proof prover="0"><result status="valid" time="0.02" steps="127"/></proof>
</goal>
</theory>
</file>
</why3session>
module Order
use int.Int
use mach.int.Int63
predicate is_pre_order (cmp: 'a -> 'a -> int63) =
(forall x. cmp x x = 0) /\
(forall x y. cmp x y <= 0 <-> cmp y x >= 0) /\
(forall x y z.
(cmp x y <= 0 -> cmp y z <= 0 -> cmp x z <= 0) /\
(cmp x y <= 0 -> cmp y z < 0 -> cmp x z < 0) /\
(cmp x y < 0 -> cmp y z <= 0 -> cmp x z < 0) /\
(cmp x y < 0 -> cmp y z < 0 -> cmp x z < 0))
end
module Comparable
use int.Int
use Order
use mach.int.Int63
type t
val function compare t t : int63
axiom is_pre_order: is_pre_order compare
predicate le (x y: t) = compare x y <= 0
end
module ArrayPermut
use export mach.array.Array63Permut
end
theory Seq
use export seq.Seq
use export seq.OfList
use export seq.FoldLeft
use export seq.FoldRight
end
theory Set
use export set.Fset
use export set.FsetSum
end
theory Map
use export map.Map
end
module List
use export list.List
use export list.Length
end
module Peano
use export mach.peano.Peano
end
module Bag
use export bag.Bag
end
......@@ -868,12 +868,6 @@ module Pairing(Old: S)(New: S) = struct
(* priority queues for pairs of nodes *)
module E = struct
type t = int * (node * node)
let compare (v1, _) (v2, _) = Pervasives.compare v2 v1
end
module PQ = Pqueue.Make(E)
let dprintf = Debug.dprintf debug
let associate oldgoals newgoals =
......@@ -930,15 +924,21 @@ module Pairing(Old: S)(New: S) = struct
let allgoals = List.sort compare allgoals in
build_list allgoals;
if allgoals <> [] then begin
let dummy = let n = List.hd allgoals (* safe *) in 0, (n, n) in
let pq = PQ.create ~dummy in
let module E = struct
let dummy = let n = List.hd allgoals (* safe *) in 0, (n, n)
type t = int * (node * node)
let compare (v1, _) (v2, _) = Pervasives.compare v2 v1
end in
let module PQ = Pqueue.Make(E) in
let pq = PQ.create () in
let add x y = match x.elt, y.elt with
| Old _, New _ | New _, Old _ -> PQ.add pq (lcp x.shape y.shape, (x, y))
| Old _, New _ | New _, Old _ ->
PQ.insert (lcp x.shape y.shape, (x, y)) pq
| Old _, Old _ | New _, New _ -> () in
iter_pairs add allgoals;
(* FIXME: exit earlier, as soon as we get min(old,new) pairs *)
while not (PQ.is_empty pq) do
let _, (x, y) = PQ.extract_min pq in
let _, (x, y) = PQ.extract_min_exn pq in
if x.valid && y.valid then begin
let o, n = match x.elt, y.elt with
| New n, Old o | Old o, New n -> o, n | _ -> assert false in
......
......@@ -605,21 +605,22 @@ let run_match (type i) icmp cp mty mv t =
code_loc = cp
} in
let module MS = struct
let dummy = origin
type t = i matching_state
let compare t1 t2 = icmp t2.code_loc.highest_id t1.code_loc.highest_id
end in
let module HMS = Pqueue.Make(MS) in
let h = HMS.create ~dummy:origin in
HMS.add h origin;
let h = HMS.create () in
HMS.insert origin h;
let rec run () =
match HMS.extract_min h with
match HMS.extract_min_exn h with
| ms ->
if instrs ms ms.code_loc.straight_code
then
match ms.code_loc.branch with
| Stop -> Some (ms.code_loc.highest_id,ms.type_match,ms.term_match)
| Fork cm ->
MInstr.iter (fun _ cp -> HMS.add h {ms with code_loc = cp}) cm;
MInstr.iter (fun _ cp -> HMS.insert {ms with code_loc = cp} h) cm;
run ()
| Switch mp ->
let t = match ms.term_stack with
......@@ -647,7 +648,7 @@ let run_match (type i) icmp cp mty mv t =
begin match MC.find c mp with
| mil -> MIL.iter (fun l cp ->
let ms = {ms with code_loc = cp} in
if instr ms (Fragment (l,c)) then HMS.add h ms) mil
if instr ms (Fragment (l,c)) then HMS.insert ms h) mil
| exception Not_found -> ()
end;
run ()
......@@ -660,7 +661,7 @@ let run_match (type i) icmp cp mty mv t =
begin match MCty.find c mp with
| mil -> MIL.iter (fun l cp ->
let ms = {ms with code_loc = cp} in
if instr ms (FragmentTy (l,c)) then HMS.add h ms) mil
if instr ms (FragmentTy (l,c)) then HMS.insert ms h) mil
| exception Not_found -> ()
end;
run ()
......@@ -675,7 +676,7 @@ let run_match (type i) icmp cp mty mv t =
in
begin match MCpat.find c mp with
| cp ->
if instr ms (FragmentPat c) then HMS.add h {ms with code_loc = cp}
if instr ms (FragmentPat c) then HMS.insert {ms with code_loc = cp} h
| exception Not_found -> ()
end;
run ()
......@@ -1200,16 +1201,3 @@ let compile id rigid_tv rigid_vs tp =
)
let () = Trans.register_env_transform "a" matching_debug ~desc:"DEBUG"*)
......@@ -9,97 +9,104 @@
(* *)
(********************************************************************)
(* Resizable arrays *)
(** This module is automatically extracted from
why3/examples/util/PQueue_impl.mlw *)
module RA = struct
(** This is a contribution by Aymeric Walch. *)
type 'a t = { default: 'a; mutable size: int; mutable data: 'a array }
let length a = a.size
let make n d = { default = d; size = n; data = Array.make n d }
let get a i =
if i < 0 || i >= a.size then invalid_arg "RA.get";
a.data.(i)
let set a i v =
if i < 0 || i >= a.size then invalid_arg "RA.set";
a.data.(i) <- v
let resize a s =
if s <= a.size then begin
Array.fill a.data s (a.size - s) a.default
end else begin
let n = Array.length a.data in
if s > n then begin
let n' = max (2 * n) s in
let a' = Array.make n' a.default in
Array.blit a.data 0 a' 0 a.size;
a.data <- a'
end
end;
a.size <- s
end
(* Priority queue *)
(* The heap is encoded into a resizable array, where elements are stored
from [0] to [length - 1]. From an element stored at [i], the left
(resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *)
module Make(X: Set.OrderedType) = struct
module Make(X: sig type t
val dummy : t
val compare : t -> t -> int end) =
struct
type elt = X.t
type t = elt RA.t
let create ~dummy = RA.make 0 dummy
let is_empty h = RA.length h = 0
(* dead code
let clear h = RA.resize h 0
*)
let rec move_up h x i =
if i = 0 then RA.set h i x else
let fi = (i - 1) / 2 in
let y = RA.get h fi in
if X.compare y x > 0 then begin RA.set h i y; move_up h x fi end
else RA.set h i x
let add h x =
let n = RA.length h in RA.resize h (n + 1); move_up h x n
exception Empty
let get_min h =
if RA.length h = 0 then raise Empty;
RA.get h 0
type t = X.t Vector.t
let min h l r = if X.compare (RA.get h r) (RA.get h l) < 0 then r else l
let create (us: unit) : t =
Vector.create ?capacity:(Some 0) ~dummy:X.dummy
let smallest_node h x i =
let l = 2 * i + 1 in
let n = RA.length h in
if l >= n then i else
let r = l + 1 in
let j = if r < n then min h l r else l in
if X.compare (RA.get h j) x < 0 then j else i
let is_empty (h: t) : bool = Vector.is_empty h
let rec move_down h x i =
let j = smallest_node h x i in
if j = i then RA.set h i x
else begin RA.set h i (RA.get h j); move_down h x j end
let size (h: t) : int = Vector.length h
let remove_min h =
let n = RA.length h - 1 in
if n < 0 then raise Empty;
let x = RA.get h n in
RA.resize h n;
if n > 0 then move_down h x 0
let extract_min h =
if RA.length h = 0 then raise Empty;
let x = RA.get h 0 in
remove_min h;
x
exception Empty
let find_min_exn (h: t) : X.t =
begin
if Vector.is_empty h then begin raise Empty end;
Vector.get h 0
end
let find_min (h: t) : X.t option =
if Vector.is_empty h then begin None end
else
begin
Some (Vector.get h 0) end
let rec move_down (a: X.t Vector.t) (i: int) (x: X.t) : unit =
let n = Vector.length a in
let q = if n = 1 then begin (-1) end else begin (n - 2) / 2 end in
if i <= q then begin
let j = let j1 = (2 * i) + 1 in
if
((j1 + 1) < n) && ((X.compare (Vector.get a (j1 + 1))
(Vector.get a j1)) < 0) then begin
j1 + 1 end
else
begin
j1 end in
if (X.compare (Vector.get a j) x) < 0 then begin
begin
let o = Vector.get a j in Vector.set a i o;
move_down a j x
end end
else
begin
Vector.set a i x end end
else
begin
Vector.set a i x end
let extract_min_exn (h: t) : X.t =
begin try let x = Vector.pop h in
let n = Vector.length h in
if not (n = 0) then begin
let min = Vector.get h 0 in begin move_down h 0 x; min end end
else
begin
x end with
| Vector.Empty -> raise Empty
end
let delete_min_exn (h: t) : unit = ignore (extract_min_exn h)
let rec move_up (a: X.t Vector.t) (i: int) (x: X.t) : unit =
if i = 0 then begin Vector.set a i x end
else
begin
let j = (i - 1) / 2 in
let y = Vector.get a j in
if (X.compare y x) > 0 then begin
begin Vector.set a i y; move_up a j x end end
else
begin
Vector.set a i x end end
let insert (x: X.t) (h: t) : unit =
begin
if (size h) = Sys.max_array_length
then begin
raise (Invalid_argument "") end;
let n = Vector.length h in
if n = 0 then begin Vector.push h x end
else
begin
let j = (n - 1) / 2 in
let y = Vector.get h j in
if (X.compare y x) > 0 then begin
begin Vector.push h y; move_up h j x end end
else
begin
Vector.push h x end end
end
end