From 93f9aa39b2885f98bf2be89583102d5c7f4c6f22 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 16 Sep 2020 09:13:59 +0200 Subject: just missing OpWeights for AARCH64 --- Makefile | 17 +- Makefile.extr | 2 +- configure | 1 + kvx/InstructionScheduler.ml | 1263 ----------------------- kvx/InstructionScheduler.mli | 113 --- kvx/lib/PrepassSchedulingOracle.ml | 432 -------- kvx/lib/RTLpath.v | 1066 -------------------- kvx/lib/RTLpathLivegen.v | 290 ------ kvx/lib/RTLpathLivegenaux.ml | 309 ------ kvx/lib/RTLpathLivegenproof.v | 736 -------------- kvx/lib/RTLpathSE_impl.v | 1631 ------------------------------ kvx/lib/RTLpathSE_impl_junk.v | 736 -------------- kvx/lib/RTLpathSE_theory.v | 1778 --------------------------------- kvx/lib/RTLpathScheduler.v | 333 ------ kvx/lib/RTLpathScheduleraux.ml | 368 ------- kvx/lib/RTLpathSchedulerproof.v | 341 ------- kvx/lib/RTLpathproof.v | 50 - scheduling/InstructionScheduler.ml | 1263 +++++++++++++++++++++++ scheduling/InstructionScheduler.mli | 113 +++ scheduling/PrepassSchedulingOracle.ml | 432 ++++++++ scheduling/RTLpath.v | 1066 ++++++++++++++++++++ scheduling/RTLpathLivegen.v | 290 ++++++ scheduling/RTLpathLivegenaux.ml | 309 ++++++ scheduling/RTLpathLivegenproof.v | 736 ++++++++++++++ scheduling/RTLpathSE_impl.v | 1631 ++++++++++++++++++++++++++++++ scheduling/RTLpathSE_impl_junk.v | 736 ++++++++++++++ scheduling/RTLpathSE_theory.v | 1778 +++++++++++++++++++++++++++++++++ scheduling/RTLpathScheduler.v | 333 ++++++ scheduling/RTLpathScheduleraux.ml | 368 +++++++ scheduling/RTLpathSchedulerproof.v | 341 +++++++ scheduling/RTLpathproof.v | 50 + 31 files changed, 9461 insertions(+), 9451 deletions(-) delete mode 100644 kvx/InstructionScheduler.ml delete mode 100644 kvx/InstructionScheduler.mli delete mode 100644 kvx/lib/PrepassSchedulingOracle.ml delete mode 100644 kvx/lib/RTLpath.v delete mode 100644 kvx/lib/RTLpathLivegen.v delete mode 100644 kvx/lib/RTLpathLivegenaux.ml delete mode 100644 kvx/lib/RTLpathLivegenproof.v delete mode 100644 kvx/lib/RTLpathSE_impl.v delete mode 100644 kvx/lib/RTLpathSE_impl_junk.v delete mode 100644 kvx/lib/RTLpathSE_theory.v delete mode 100644 kvx/lib/RTLpathScheduler.v delete mode 100644 kvx/lib/RTLpathScheduleraux.ml delete mode 100644 kvx/lib/RTLpathSchedulerproof.v delete mode 100644 kvx/lib/RTLpathproof.v create mode 100644 scheduling/InstructionScheduler.ml create mode 100644 scheduling/InstructionScheduler.mli create mode 100644 scheduling/PrepassSchedulingOracle.ml create mode 100644 scheduling/RTLpath.v create mode 100644 scheduling/RTLpathLivegen.v create mode 100644 scheduling/RTLpathLivegenaux.ml create mode 100644 scheduling/RTLpathLivegenproof.v create mode 100644 scheduling/RTLpathSE_impl.v create mode 100644 scheduling/RTLpathSE_impl_junk.v create mode 100644 scheduling/RTLpathSE_theory.v create mode 100644 scheduling/RTLpathScheduler.v create mode 100644 scheduling/RTLpathScheduleraux.ml create mode 100644 scheduling/RTLpathSchedulerproof.v create mode 100644 scheduling/RTLpathproof.v diff --git a/Makefile b/Makefile index baccc9ab..adbfb661 100644 --- a/Makefile +++ b/Makefile @@ -23,11 +23,11 @@ endif BACKENDLIB?=Asmgenproof0.v Asmgenproof1.v -DIRS=lib lib/Impure common $(ARCHDIRS) backend cfrontend driver \ +DIRS=lib lib/Impure common $(ARCHDIRS) scheduling backend cfrontend driver \ flocq/Core flocq/Prop flocq/Calc flocq/IEEE754 \ exportclight MenhirLib cparser -RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight \ +RECDIRS=lib common $(ARCHDIRS) scheduling backend cfrontend driver flocq exportclight \ MenhirLib cparser COQINCLUDES=$(foreach d, $(RECDIRS), -R $(d) $(subst /,.,compcert.$(d))) @@ -60,7 +60,9 @@ VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ HashedSet.v \ Iteration.v Zbits.v Integers.v Archi.v IEEE754_extra.v Floats.v \ Parmov.v UnionFind.v Wfsimpl.v \ - Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v + Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v \ + ImpConfig.v ImpExtern.v ImpIO.v ImpMonads.v \ + ImpCore.v ImpHCons.v ImpLoops.v ImpPrelude.v # Parts common to the front-ends and the back-end (in common/) @@ -111,6 +113,13 @@ BACKEND=\ Asm.v Asmgen.v Asmgenproof.v Asmaux.v \ $(BACKENDLIB) +SCHEDULING= \ + RTLpathLivegenproof.v RTLpathSE_impl_junk.v \ + RTLpathLivegen.v RTLpathSE_impl.v \ + RTLpathproof.v RTLpathSE_theory.v \ + RTLpathSchedulerproof.v RTLpath.v \ + RTLpathScheduler.v + # C front-end modules (in cfrontend/) CFRONTEND=Ctypes.v Cop.v Csyntax.v Csem.v Ctyping.v Cstrategy.v Cexec.v \ @@ -136,7 +145,7 @@ DRIVER=Compopts.v Compiler.v Complements.v # All source files -FILES=$(VLIB) $(COMMON) $(BACKEND) $(CFRONTEND) $(DRIVER) $(FLOCQ) \ +FILES=$(VLIB) $(COMMON) $(BACKEND) $(SCHEDULING) $(CFRONTEND) $(DRIVER) $(FLOCQ) \ $(MENHIRLIB) $(PARSER) # Generated source files diff --git a/Makefile.extr b/Makefile.extr index 5e328a4c..1a894a16 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -42,7 +42,7 @@ cparser/pre_parser_messages.ml: # Directories containing plain Caml code DIRS=extraction \ - lib common $(ARCH) backend cfrontend cparser driver \ + lib common $(ARCH) scheduling backend cfrontend cparser driver \ exportclight debug kvx/unittest lib/Impure/ocaml \ kvx/lib diff --git a/configure b/configure index 8261f9f3..dbc53c16 100755 --- a/configure +++ b/configure @@ -689,6 +689,7 @@ echo "-R lib compcert.lib \ -R common compcert.common \ -R ${arch} compcert.${arch} \ -R backend compcert.backend \ +-R scheduling compcert.scheduling \ -R cfrontend compcert.cfrontend \ -R driver compcert.driver \ -R flocq compcert.flocq \ diff --git a/kvx/InstructionScheduler.ml b/kvx/InstructionScheduler.ml deleted file mode 100644 index eab0b21a..00000000 --- a/kvx/InstructionScheduler.ml +++ /dev/null @@ -1,1263 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -let with_destructor dtor stuff f = - try let ret = f stuff in - dtor stuff; - ret - with exn -> dtor stuff; - raise exn;; - -let with_out_channel chan f = with_destructor close_out chan f;; -let with_in_channel chan f = with_destructor close_in chan f;; - -(** Schedule instructions on a synchronized pipeline -@author David Monniaux, CNRS, VERIMAG *) - -type latency_constraint = { - instr_from : int; - instr_to : int; - latency : int };; - -type problem = { - max_latency : int; - resource_bounds : int array; - instruction_usages : int array array; - latency_constraints : latency_constraint list; - };; - -let print_problem channel problem = - (if problem.max_latency >= 0 - then Printf.fprintf channel "max makespan: %d\n" problem.max_latency); - output_string channel "resource bounds:"; - (Array.iter (fun b -> Printf.fprintf channel " %d" b) problem.resource_bounds); - output_string channel ";\n"; - (Array.iteri (fun i v -> - Printf.fprintf channel "instr%d:" i; - (Array.iter (fun b -> Printf.fprintf channel " %d" b) v); - output_string channel ";\n") problem.instruction_usages); - List.iter (fun instr -> - Printf.printf "t%d - t%d >= %d;\n" - instr.instr_to instr.instr_from instr.latency) - problem.latency_constraints;; - -let get_nr_instructions problem = Array.length problem.instruction_usages;; -let get_nr_resources problem = Array.length problem.resource_bounds;; - -type solution = int array -type scheduler = problem -> solution option - -(* DISABLED -(** Schedule the problem optimally by constraint solving using the Gecode solver. *) -external gecode_scheduler : problem -> solution option = - "caml_gecode_schedule_instr";; - *) - -let maximum_slot_used times = - let maxi = ref (-1) in - for i=0 to (Array.length times)-2 - do - maxi := max !maxi times.(i) - done; - !maxi;; - -let check_schedule (problem : problem) (times : solution) = - let nr_instructions = get_nr_instructions problem in - (if Array.length times <> nr_instructions+1 - then failwith - (Printf.sprintf "check_schedule: %d times expected, got %d" - (nr_instructions+1) (Array.length times))); - (if problem.max_latency >= 0 && times.(nr_instructions)> problem.max_latency - then failwith "check_schedule: max_latency exceeded"); - (Array.iteri (fun i time -> - (if time < 0 - then failwith (Printf.sprintf "time[%d] < 0" i))) times); - let slot_resources = Array.init ((maximum_slot_used times)+1) - (fun _ -> Array.copy problem.resource_bounds) in - for i=0 to nr_instructions -1 - do - let remaining_resources = slot_resources.(times.(i)) - and used_resources = problem.instruction_usages.(i) in - for resource=0 to (Array.length used_resources)-1 - do - let after = remaining_resources.(resource) - used_resources.(resource) in - (if after < 0 - then failwith (Printf.sprintf "check_schedule: instruction %d exceeds resource %d at slot %d" i resource times.(i))); - remaining_resources.(resource) <- after - done - done; - List.iter (fun ctr -> - if times.(ctr.instr_to) - times.(ctr.instr_from) < ctr.latency - then failwith (Printf.sprintf "check_schedule: time[%d]=%d - time[%d]=%d < %d" - ctr.instr_to times.(ctr.instr_to) - ctr.instr_from times.(ctr.instr_from) - ctr.latency) - ) problem.latency_constraints;; - -let bound_max_time problem = - let total = ref(Array.length problem.instruction_usages) in - List.iter (fun ctr -> total := !total + ctr.latency) problem.latency_constraints; - !total;; - -let vector_less_equal a b = - try - Array.iter2 (fun x y -> - if x>y - then raise Exit) a b; - true - with Exit -> false;; - -let vector_subtract a b = - assert ((Array.length a) = (Array.length b)); - for i=0 to (Array.length a)-1 - do - b.(i) <- b.(i) - a.(i) - done;; - -(* The version with critical path ordering is much better! *) -type list_scheduler_order = - | INSTRUCTION_ORDER - | CRITICAL_PATH_ORDER;; - -let int_max (x : int) (y : int) = - if x > y then x else y;; - -let int_min (x : int) (y : int) = - if x < y then x else y;; - -let get_predecessors problem = - let nr_instructions = get_nr_instructions problem in - let predecessors = Array.make (nr_instructions+1) [] in - List.iter (fun ctr -> - predecessors.(ctr.instr_to) <- - (ctr.instr_from, ctr.latency)::predecessors.(ctr.instr_to)) - problem.latency_constraints; - predecessors;; - -let get_successors problem = - let nr_instructions = get_nr_instructions problem in - let successors = Array.make nr_instructions [] in - List.iter (fun ctr -> - successors.(ctr.instr_from) <- - (ctr.instr_to, ctr.latency)::successors.(ctr.instr_from)) - problem.latency_constraints; - successors;; - -let critical_paths successors = - let nr_instructions = Array.length successors in - let path_lengths = Array.make nr_instructions (-1) in - let rec compute i = - if i=nr_instructions then 0 else - match path_lengths.(i) with - | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" - | -1 -> path_lengths.(i) <- -2; - let x = List.fold_left - (fun cur (j, latency)-> int_max cur (latency+(compute j))) - 1 successors.(i) - in path_lengths.(i) <- x; x - | x -> x - in for i = nr_instructions-1 downto 0 - do - ignore (compute i) - done; - path_lengths;; - -let maximum_critical_path problem = - let paths = critical_paths (get_successors problem) in - Array.fold_left int_max 0 paths;; - -let get_earliest_dates predecessors = - let nr_instructions = (Array.length predecessors)-1 in - let path_lengths = Array.make (nr_instructions+1) (-1) in - let rec compute i = - match path_lengths.(i) with - | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" - | -1 -> path_lengths.(i) <- -2; - let x = List.fold_left - (fun cur (j, latency)-> int_max cur (latency+(compute j))) - 0 predecessors.(i) - in path_lengths.(i) <- x; x - | x -> x - in for i = 0 to nr_instructions - do - ignore (compute i) - done; - for i = 0 to nr_instructions - 1 - do - path_lengths.(nr_instructions) <- int_max - path_lengths.(nr_instructions) (1 + path_lengths.(i)) - done; - path_lengths;; - -exception Unschedulable - -let get_latest_dates deadline successors = - let nr_instructions = Array.length successors - and path_lengths = critical_paths successors in - Array.init (nr_instructions + 1) - (fun i -> - if i < nr_instructions then - let path_length = path_lengths.(i) in - assert (path_length >= 1); - (if path_length > deadline - then raise Unschedulable); - deadline - path_length - else deadline);; - -let priority_list_scheduler (order : list_scheduler_order) - (problem : problem) : - solution option = - let nr_instructions = get_nr_instructions problem in - let successors = get_successors problem - and predecessors = get_predecessors problem - and times = Array.make (nr_instructions+1) (-1) in - - let priorities = match order with - | INSTRUCTION_ORDER -> None - | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in - - let module InstrSet = - Set.Make (struct type t=int - let compare = match priorities with - | None -> (fun x y -> x - y) - | Some p -> (fun x y -> - (match p.(y)-p.(x) with - | 0 -> x - y - | z -> z)) - end) in - - let max_time = bound_max_time problem in - let ready = Array.make max_time InstrSet.empty in - Array.iteri (fun i preds -> - if i - if times.(j) < 0 - then raise Exit - else let t = times.(j) + latency in - if t > !time - then time := t) predecessors.(i); - assert(!time >= 0); - !time - with Exit -> -1 - - in - let advance_time() = - begin - (if !current_time < max_time-1 - then - begin - Array.blit problem.resource_bounds 0 current_resources 0 - (Array.length current_resources); - ready.(!current_time + 1) <- - InstrSet.union (ready.(!current_time)) (ready.(!current_time + 1)); - ready.(!current_time) <- InstrSet.empty; - end); - incr current_time - end in - - let attempt_scheduling ready usages = - let result = ref (-1) in - try - InstrSet.iter (fun i -> - (* Printf.printf "trying scheduling %d\n" i; - pr int_vector usages.(i); - print _vector current_resources; *) - if vector_less_equal usages.(i) current_resources - then - begin - vector_subtract usages.(i) current_resources; - result := i; - raise Exit - end) ready; - -1 - with Exit -> !result in - - while !current_time < max_time - do - if (InstrSet.is_empty ready.(!current_time)) - then advance_time() - else - match attempt_scheduling ready.(!current_time) - problem.instruction_usages with - | -1 -> advance_time() - | i -> - begin - assert(times.(i) < 0); - times.(i) <- !current_time; - ready.(!current_time) <- InstrSet.remove i (ready.(!current_time)); - List.iter (fun (instr_to, latency) -> - if instr_to < nr_instructions then - match earliest_time instr_to with - | -1 -> () - | to_time -> - ready.(to_time) <- InstrSet.add instr_to ready.(to_time)) - successors.(i); - successors.(i) <- [] - end - done; - try - let final_time = ref (-1) in - for i=0 to nr_instructions-1 - do - (if times.(i) < 0 then raise Exit); - (if !final_time < times.(i)+1 then final_time := times.(i)+1) - done; - List.iter (fun (i, latency) -> - let target_time = latency + times.(i) in - if target_time > !final_time - then final_time := target_time - ) predecessors.(nr_instructions); - times.(nr_instructions) <- !final_time; - Some times - with Exit -> None;; - -let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; - -(* dummy code for placating ocaml's warnings *) -let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;; - -type bundle = int list;; - -let rec extract_deps_to index = function - | [] -> [] - | dep :: deps -> let extracts = extract_deps_to index deps in - if (dep.instr_to == index) then - dep :: extracts - else - extracts - -exception InvalidBundle;; - -let dependency_check problem bundle index = - let index_deps = extract_deps_to index problem.latency_constraints in - List.iter (fun i -> - List.iter (fun dep -> - if (dep.instr_from == i) then raise InvalidBundle - ) index_deps - ) bundle;; - -let rec make_bundle problem resources bundle index = - let resources_copy = Array.copy resources in - let nr_instructions = get_nr_instructions problem in - if (index >= nr_instructions) then (bundle, index+1) else - let inst_usage = problem.instruction_usages.(index) in - try match vector_less_equal inst_usage resources with - | false -> raise InvalidBundle - | true -> ( - dependency_check problem bundle index; - vector_subtract problem.instruction_usages.(index) resources_copy; - make_bundle problem resources_copy (index::bundle) (index+1) - ) - with InvalidBundle -> (bundle, index);; - -let rec make_bundles problem index : bundle list = - if index >= get_nr_instructions problem then - [] - else - let (bundle, new_index) = make_bundle problem problem.resource_bounds [] index in - bundle :: (make_bundles problem new_index);; - -let bundles_to_schedule problem bundles : solution = - let nr_instructions = get_nr_instructions problem in - let schedule = Array.make (nr_instructions+1) (nr_instructions+4) in - let time = ref 0 in - List.iter (fun bundle -> - begin - List.iter (fun i -> - schedule.(i) <- !time - ) bundle; - time := !time + 1 - end - ) bundles; schedule;; - -let greedy_scheduler (problem : problem) : solution option = - let bundles = make_bundles problem 0 in - Some (bundles_to_schedule problem bundles);; - -(* alternate implementation -let swap_array_elements a i j = - let x = a.(i) in - a.(i) <- a.(j); - a.(j) <- x;; - -let array_reverse_slice a first last = - let i = ref first and j = ref last in - while i < j - do - swap_array_elements a !i !j; - incr i; - decr j - done;; - -let array_reverse a = - let a' = Array.copy a in - array_reverse_slice a' 0 ((Array.length a)-1); - a';; - *) - -(* unneeded -let array_reverse a = - let n=Array.length a in - Array.init n (fun i -> a.(n-1-i));; - *) - -let reverse_constraint nr_instructions ctr = - { instr_to = nr_instructions -ctr.instr_from; - instr_from = nr_instructions - ctr.instr_to; - latency = ctr.latency };; - -(* unneeded -let rec list_map_filter f = function - | [] -> [] - | h::t -> - (match f h with - | None -> list_map_filter f t - | Some x -> x :: (list_map_filter f t));; - *) - -let reverse_problem problem = - let nr_instructions = get_nr_instructions problem in - { - max_latency = problem.max_latency; - resource_bounds = problem.resource_bounds; - instruction_usages = Array.init (nr_instructions + 1) - (fun i -> - if i=0 - then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i)); - latency_constraints = List.map (reverse_constraint nr_instructions) - problem.latency_constraints - };; - -let max_scheduled_time solution = - let time = ref (-1) in - for i = 0 to ((Array.length solution) - 2) - do - time := max !time solution.(i) - done; - !time;; - -(* -let recompute_makespan problem solution = - let n = (Array.length solution) - 1 and ms = ref 0 in - List.iter (fun cstr -> - if cstr.instr_to = n - then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) - ) problem.latency_constraints; - !ms;; - *) - -let schedule_reversed (scheduler : problem -> solution option) - (problem : problem) = - match scheduler (reverse_problem problem) with - | None -> None - | Some solution -> - let nr_instructions = get_nr_instructions problem in - let makespan = max_scheduled_time solution in - let ret = Array.init (nr_instructions + 1) - (fun i -> makespan-solution.(nr_instructions-i)) in - ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1) - (ret.(nr_instructions)); - Some ret;; - -(** Schedule the problem using a greedy list scheduling algorithm, from the end. *) -let reverse_list_scheduler = schedule_reversed list_scheduler;; - -let check_problem problem = - (if (Array.length problem.instruction_usages) < 1 - then failwith "length(problem.instruction_usages) < 1");; - -let validated_scheduler (scheduler : problem -> solution option) - (problem : problem) = - check_problem problem; - match scheduler problem with - | None -> None - | (Some solution) as ret -> check_schedule problem solution; ret;; - -let get_max_latency solution = - solution.((Array.length solution)-1);; - -let show_date_ranges problem = - let deadline = problem.max_latency in - assert(deadline >= 0); - let successors = get_successors problem - and predecessors = get_predecessors problem in - let earliest_dates : int array = get_earliest_dates predecessors - and latest_dates : int array = get_latest_dates deadline successors in - assert ((Array.length earliest_dates) = - (Array.length latest_dates)); - Array.iteri (fun i early -> - let late = latest_dates.(i) in - Printf.printf "t[%d] in %d..%d\n" i early late) - earliest_dates;; - -type pseudo_boolean_problem_type = - | SATISFIABILITY - | OPTIMIZATION;; - -type pseudo_boolean_mapper = { - mapper_pb_type : pseudo_boolean_problem_type; - mapper_nr_instructions : int; - mapper_nr_pb_variables : int; - mapper_earliest_dates : int array; - mapper_latest_dates : int array; - mapper_var_offsets : int array; - mapper_final_predecessors : (int * int) list -};; - -(* Latency constraints are: - presence of instr-to at each t <= sum of presences of instr-from at compatible times - - if reverse_encoding - presence of instr-from at each t <= sum of presences of instr-to at compatible times *) - -(* Experiments show reverse_encoding=true multiplies time by 2 in sat4j - without making hard instances easier *) -let direct_encoding = false -and reverse_encoding = false -and delta_encoding = true - -let pseudo_boolean_print_problem channel problem pb_type = - let deadline = problem.max_latency in - assert (deadline > 0); - let nr_instructions = get_nr_instructions problem - and nr_resources = get_nr_resources problem - and successors = get_successors problem - and predecessors = get_predecessors problem in - let earliest_dates = get_earliest_dates predecessors - and latest_dates = get_latest_dates deadline successors in - let var_offsets = Array.make - (match pb_type with - | OPTIMIZATION -> nr_instructions+1 - | SATISFIABILITY -> nr_instructions) 0 in - let nr_pb_variables = - (let nr = ref 0 in - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - var_offsets.(i) <- !nr; - nr := !nr + latest_dates.(i) - earliest_dates.(i) + 1 - done; - !nr) - and nr_pb_constraints = - (match pb_type with - | OPTIMIZATION -> nr_instructions+1 - | SATISFIABILITY -> nr_instructions) + - - (let count = ref 0 in - for t=0 to deadline-1 - do - for j=0 to nr_resources-1 - do - try - for i=0 to nr_instructions-1 - do - let usage = problem.instruction_usages.(i).(j) in - if t >= earliest_dates.(i) && t <= latest_dates.(i) - && usage > 0 then raise Exit - done - with Exit -> incr count - done - done; - !count) + - - (let count=ref 0 in - List.iter - (fun ctr -> - if ctr.instr_to < nr_instructions - then count := !count + 1 + latest_dates.(ctr.instr_to) - - earliest_dates.(ctr.instr_to) - + (if reverse_encoding - then 1 + latest_dates.(ctr.instr_from) - - earliest_dates.(ctr.instr_from) - else 0) - ) - problem.latency_constraints; - !count) + - - (match pb_type with - | OPTIMIZATION -> (1 + deadline - earliest_dates.(nr_instructions)) * nr_instructions - | SATISFIABILITY -> 0) - and measured_nr_constraints = ref 0 in - - let pb_var i t = - assert(t >= earliest_dates.(i)); - assert(t <= latest_dates.(i)); - let v = 1+var_offsets.(i)+t-earliest_dates.(i) in - assert(v <= nr_pb_variables); - Printf.sprintf "x%d" v in - - let end_constraint () = - begin - output_string channel ";\n"; - incr measured_nr_constraints - end in - - let gen_latency_constraint i_to i_from latency t_to = - Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_to; - for t_from=earliest_dates.(i_from) to - int_min latest_dates.(i_from) (t_to - latency) - do - Printf.fprintf channel "+1 %s " (pb_var i_from t_from) - done; - Printf.fprintf channel "-1 %s " (pb_var i_to t_to); - Printf.fprintf channel ">= 0"; - end_constraint() - - and gen_dual_latency_constraint i_to i_from latency t_from = - Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_from; - for t_to=int_max earliest_dates.(i_to) (t_from + latency) - to latest_dates.(i_to) - do - Printf.fprintf channel "+1 %s " (pb_var i_to t_to) - done; - Printf.fprintf channel "-1 %s " (pb_var i_from t_from); - Printf.fprintf channel ">= 0"; - end_constraint() - in - - Printf.fprintf channel "* #variable= %d #constraint= %d\n" nr_pb_variables nr_pb_constraints; - Printf.fprintf channel "* nr_instructions=%d deadline=%d\n" nr_instructions deadline; - begin - match pb_type with - | SATISFIABILITY -> () - | OPTIMIZATION -> - output_string channel "min:"; - for t=earliest_dates.(nr_instructions) to deadline - do - Printf.fprintf channel " %+d %s" t (pb_var nr_instructions t) - done; - output_string channel ";\n"; - end; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - Printf.fprintf channel "* t[%d] in %d..%d\n" i early late; - for t=early to late - do - Printf.fprintf channel "+1 %s " (pb_var i t) - done; - Printf.fprintf channel "= 1"; - end_constraint() - done; - - for t=0 to deadline-1 - do - for j=0 to nr_resources-1 - do - let bound = problem.resource_bounds.(j) - and coeffs = ref [] in - for i=0 to nr_instructions-1 - do - let usage = problem.instruction_usages.(i).(j) in - if t >= earliest_dates.(i) && t <= latest_dates.(i) - && usage > 0 - then coeffs := (i, usage) :: !coeffs - done; - if !coeffs <> [] then - begin - Printf.fprintf channel "* resource #%d at t=%d <= %d\n" j t bound; - List.iter (fun (i, usage) -> - Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; - Printf.fprintf channel ">= %d" (-bound); - end_constraint(); - end - done - done; - - List.iter - (fun ctr -> - if ctr.instr_to < nr_instructions then - begin - for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) - do - gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to - done; - if reverse_encoding - then - for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) - do - gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from - done - end - ) problem.latency_constraints; - - begin - match pb_type with - | SATISFIABILITY -> () - | OPTIMIZATION -> - let final_latencies = Array.make nr_instructions 1 in - List.iter (fun (i, latency) -> - final_latencies.(i) <- int_max final_latencies.(i) latency) - predecessors.(nr_instructions); - for t_to=earliest_dates.(nr_instructions) to deadline - do - for i_from = 0 to nr_instructions -1 - do - gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to - done - done - end; - assert (!measured_nr_constraints = nr_pb_constraints); - { - mapper_pb_type = pb_type; - mapper_nr_instructions = nr_instructions; - mapper_nr_pb_variables = nr_pb_variables; - mapper_earliest_dates = earliest_dates; - mapper_latest_dates = latest_dates; - mapper_var_offsets = var_offsets; - mapper_final_predecessors = predecessors.(nr_instructions) - };; - -type pb_answer = - | Positive - | Negative - | Unknown - -let line_to_pb_solution sol line nr_pb_variables = - let assign s v = - begin - let i = int_of_string s in - sol.(i-1) <- v - end in - List.iter - begin - function "" -> () - | item -> - (match String.get item 0 with - | '+' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Positive - | '-' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Negative - | 'x' -> - assert ((String.length item) >= 2); - assign (String.sub item 1 ((String.length item)-1)) Positive - | _ -> failwith "syntax error in pseudo Boolean solution: epected + - or x" - ) - end - (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; - -let pb_solution_to_schedule mapper pb_solution = - Array.mapi (fun i offset -> - let first = mapper.mapper_earliest_dates.(i) - and last = mapper.mapper_latest_dates.(i) - and time = ref (-1) in - for t=first to last - do - match pb_solution.(t - first + offset) with - | Positive -> - (if !time = -1 - then time:=t - else failwith "duplicate time in pseudo boolean solution") - | Negative -> () - | Unknown -> failwith "unknown value in pseudo boolean solution" - done; - (if !time = -1 - then failwith "no time in pseudo boolean solution"); - !time - ) mapper.mapper_var_offsets;; - -let pseudo_boolean_read_solution mapper channel = - let optimum = ref (-1) - and optimum_found = ref false - and solution = Array.make mapper.mapper_nr_pb_variables Unknown in - try - while true do - match input_line channel with - | "" -> () - | line -> - begin - match String.get line 0 with - | 'c' -> () - | 'o' -> - assert ((String.length line) >= 2); - assert ((String.get line 1) = ' '); - optimum := int_of_string (String.sub line 2 ((String.length line)-2)) - | 's' -> (match line with - | "s OPTIMUM FOUND" -> optimum_found := true - | "s SATISFIABLE" -> () - | "s UNSATISFIABLE" -> close_in channel; - raise Unschedulable - | _ -> failwith line) - | 'v' -> line_to_pb_solution solution line mapper.mapper_nr_pb_variables - | x -> Printf.printf "unknown: %s\n" line - end - done; - assert false - with End_of_file -> - close_in channel; - begin - let sol = pb_solution_to_schedule mapper solution in - sol - end;; - -let recompute_max_latency mapper solution = - let maxi = ref (-1) in - for i=0 to (mapper.mapper_nr_instructions-1) - do - maxi := int_max !maxi (1+solution.(i)) - done; - List.iter (fun (i, latency) -> - maxi := int_max !maxi (solution.(i) + latency)) mapper.mapper_final_predecessors; - !maxi;; - -let adjust_check_solution mapper solution = - match mapper.mapper_pb_type with - | OPTIMIZATION -> - let max_latency = recompute_max_latency mapper solution in - assert (max_latency = solution.(mapper.mapper_nr_instructions)); - solution - | SATISFIABILITY -> - let max_latency = recompute_max_latency mapper solution in - Array.init (mapper.mapper_nr_instructions+1) - (fun i -> if i < mapper.mapper_nr_instructions - then solution.(i) - else max_latency);; - -(* let pseudo_boolean_solver = ref "/local/monniaux/progs/naps/naps" *) -(* let pseudo_boolean_solver = ref "/local/monniaux/packages/sat4j/org.sat4j.pb.jar CuttingPlanes" *) - -(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar CuttingPlanes" *) -(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar" *) -(* let pseudo_boolean_solver = ref "clasp" *) -(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/open-wbo/open-wbo_static -formula=1" *) -(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) -(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) -(* let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" *) -let pseudo_boolean_solver = ref "pb_solver" - -let pseudo_boolean_scheduler pb_type problem = - try - let filename_in = "problem.opb" in - (* needed only if not using stdout and filename_out = "problem.sol" *) - let mapper = - with_out_channel (open_out filename_in) - (fun opb_problem -> - pseudo_boolean_print_problem opb_problem problem pb_type) in - Some (with_in_channel - (Unix.open_process_in (!pseudo_boolean_solver ^ " " ^ filename_in)) - (fun opb_solution -> adjust_check_solution mapper (pseudo_boolean_read_solution mapper opb_solution))) - with - | Unschedulable -> None;; - -let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = - if (get_max_latency previous_solution)>1 then - begin - Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); - flush stdout; - match scheduler - { problem with max_latency = (get_max_latency previous_solution)-1 } - with - | None -> previous_solution - | Some solution -> reoptimizing_scheduler scheduler solution problem - end - else previous_solution;; - -let smt_var i = Printf.sprintf "t%d" i - -let is_resource_used problem j = - try - Array.iter (fun usages -> - if usages.(j) > 0 - then raise Exit) problem.instruction_usages; - false - with Exit -> true;; - -let smt_use_quantifiers = false - -let smt_print_problem channel problem = - let nr_instructions = get_nr_instructions problem in - let gen_smt_resource_constraint time j = - output_string channel "(<= (+"; - Array.iteri - (fun i usages -> - let usage=usages.(j) in - if usage > 0 - then Printf.fprintf channel " (ite (= %s %s) %d 0)" - time (smt_var i) usage) - problem.instruction_usages; - Printf.fprintf channel ") %d)" problem.resource_bounds.(j) - in - output_string channel "(set-option :produce-models true)\n"; - for i=0 to nr_instructions - do - Printf.fprintf channel "(declare-const %s Int)\n" (smt_var i); - Printf.fprintf channel "(assert (>= %s 0))\n" (smt_var i) - done; - for i=0 to nr_instructions-1 - do - Printf.fprintf channel "(assert (< %s %s))\n" - (smt_var i) (smt_var nr_instructions) - done; - (if problem.max_latency > 0 - then Printf.fprintf channel "(assert (<= %s %d))\n" - (smt_var nr_instructions) problem.max_latency); - List.iter (fun ctr -> - Printf.fprintf channel "(assert (>= (- %s %s) %d))\n" - (smt_var ctr.instr_to) - (smt_var ctr.instr_from) - ctr.latency) problem.latency_constraints; - for j=0 to (Array.length problem.resource_bounds)-1 - do - if is_resource_used problem j - then - begin - if smt_use_quantifiers - then - begin - Printf.fprintf channel - "; resource #%d <= %d\n(assert (forall ((t Int)) " - j problem.resource_bounds.(j); - gen_smt_resource_constraint "t" j; - output_string channel "))\n" - end - else - begin - (if problem.max_latency < 0 - then failwith "quantifier explosion needs max latency"); - for t=0 to problem.max_latency - do - Printf.fprintf channel - "; resource #%d <= %d at t=%d\n(assert " - j problem.resource_bounds.(j) t; - gen_smt_resource_constraint (string_of_int t) j; - output_string channel ")\n" - done - end - end - done; - output_string channel "(check-sat)(get-model)\n";; - - -let ilp_print_problem channel problem pb_type = - let deadline = problem.max_latency in - assert (deadline > 0); - let nr_instructions = get_nr_instructions problem - and nr_resources = get_nr_resources problem - and successors = get_successors problem - and predecessors = get_predecessors problem in - let earliest_dates = get_earliest_dates predecessors - and latest_dates = get_latest_dates deadline successors in - - let pb_var i t = - Printf.sprintf "x%d_%d" i t in - - let gen_latency_constraint i_to i_from latency t_to = - Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_to; - Printf.fprintf channel "c_%d_%d_%d_%d: " - i_to i_from latency t_to; - for t_from=earliest_dates.(i_from) to - int_min latest_dates.(i_from) (t_to - latency) - do - Printf.fprintf channel "+1 %s " (pb_var i_from t_from) - done; - Printf.fprintf channel "-1 %s " (pb_var i_to t_to); - output_string channel ">= 0\n" - - and gen_dual_latency_constraint i_to i_from latency t_from = - Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_from; - Printf.fprintf channel "d_%d_%d_%d_%d: " - i_to i_from latency t_from; - for t_to=int_max earliest_dates.(i_to) (t_from + latency) - to latest_dates.(i_to) - do - Printf.fprintf channel "+1 %s " (pb_var i_to t_to) - done; - Printf.fprintf channel "-1 %s " (pb_var i_from t_from); - Printf.fprintf channel ">= 0\n" - - and gen_delta_constraint i_from i_to latency = - if delta_encoding - then Printf.fprintf channel "l_%d_%d_%d: +1 t%d -1 t%d >= %d\n" - i_from i_to latency i_to i_from latency - - in - - Printf.fprintf channel "\\ nr_instructions=%d deadline=%d\n" nr_instructions deadline; - begin - match pb_type with - | SATISFIABILITY -> output_string channel "Minimize dummy: 0\n" - | OPTIMIZATION -> - Printf.fprintf channel "Minimize\nmakespan: t%d\n" nr_instructions - end; - output_string channel "Subject To\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - Printf.fprintf channel "\\ t[%d] in %d..%d\ntimes%d: " i early late i; - for t=early to late - do - Printf.fprintf channel "+1 %s " (pb_var i t) - done; - Printf.fprintf channel "= 1\n" - done; - - for t=0 to deadline-1 - do - for j=0 to nr_resources-1 - do - let bound = problem.resource_bounds.(j) - and coeffs = ref [] in - for i=0 to nr_instructions-1 - do - let usage = problem.instruction_usages.(i).(j) in - if t >= earliest_dates.(i) && t <= latest_dates.(i) - && usage > 0 - then coeffs := (i, usage) :: !coeffs - done; - if !coeffs <> [] then - begin - Printf.fprintf channel "\\ resource #%d at t=%d <= %d\nr%d_%d: " j t bound j t; - List.iter (fun (i, usage) -> - Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; - Printf.fprintf channel ">= %d\n" (-bound) - end - done - done; - - List.iter - (fun ctr -> - if ctr.instr_to < nr_instructions then - begin - gen_delta_constraint ctr.instr_from ctr.instr_to ctr.latency; - begin - if direct_encoding - then - for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) - do - gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to - done - end; - begin - if reverse_encoding - then - for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) - do - gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from - done - end - end - ) problem.latency_constraints; - - begin - match pb_type with - | SATISFIABILITY -> () - | OPTIMIZATION -> - let final_latencies = Array.make nr_instructions 1 in - List.iter (fun (i, latency) -> - final_latencies.(i) <- int_max final_latencies.(i) latency) - predecessors.(nr_instructions); - for i_from = 0 to nr_instructions -1 - do - gen_delta_constraint i_from nr_instructions final_latencies.(i_from) - done; - for t_to=earliest_dates.(nr_instructions) to deadline - do - for i_from = 0 to nr_instructions -1 - do - gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to - done - done - end; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - Printf.fprintf channel "ct%d : -1 t%d" i i; - let early = earliest_dates.(i) and late= latest_dates.(i) in - for t=early to late do - Printf.fprintf channel " +%d %s" t (pb_var i t) - done; - output_string channel " = 0\n" - done; - output_string channel "Bounds\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - begin - Printf.fprintf channel "%d <= t%d <= %d\n" early i late; - if true then - for t=early to late do - Printf.fprintf channel "0 <= %s <= 1\n" (pb_var i t) - done - end - done; - output_string channel "Integer\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - Printf.fprintf channel "t%d " i - done; - output_string channel "\nBinary\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - for t=early to late do - output_string channel (pb_var i t); - output_string channel " " - done; - output_string channel "\n" - done; - output_string channel "End\n"; - { - mapper_pb_type = pb_type; - mapper_nr_instructions = nr_instructions; - mapper_nr_pb_variables = 0; - mapper_earliest_dates = earliest_dates; - mapper_latest_dates = latest_dates; - mapper_var_offsets = [| |]; - mapper_final_predecessors = predecessors.(nr_instructions) - };; - -(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) - -let positive_float_round x = truncate (x +. 0.5) - -let float_round (x : float) : int = - if x > 0.0 - then positive_float_round x - else - (positive_float_round (-. x)) - -let rounded_int_of_string x = float_round (float_of_string x) - -let ilp_read_solution mapper channel = - let times = Array.make - (match mapper.mapper_pb_type with - | OPTIMIZATION -> 1+mapper.mapper_nr_instructions - | SATISFIABILITY -> mapper.mapper_nr_instructions) (-1) in - try - while true do - let line = input_line channel in - ( if (String.length line) < 3 - then failwith (Printf.sprintf "bad ilp output: length(line) < 3: %s" line)); - match String.get line 0 with - | 'x' -> () - | 't' -> let space = - try String.index line ' ' - with Not_found -> - failwith "bad ilp output: no t variable number" - in - let tnumber = - try int_of_string (String.sub line 1 (space-1)) - with Failure _ -> - failwith "bad ilp output: not a variable number" - in - (if tnumber < 0 || tnumber >= (Array.length times) - then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); - let value = - let s = String.sub line (space+1) ((String.length line)-space-1) in - try rounded_int_of_string s - with Failure _ -> - failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s) - in - (if value < 0 - then failwith "bad ilp output: negative time"); - times.(tnumber) <- value - | '#' -> () - | '0' -> () - | _ -> failwith (Printf.sprintf "bad ilp output: bad variable initial, line = %s" line) - done; - assert false - with End_of_file -> - Array.iteri (fun i x -> - if i<(Array.length times)-1 - && x<0 then raise Unschedulable) times; - times;; - -let ilp_solver = ref "ilp_solver" - -let problem_nr = ref 0 - -let ilp_scheduler pb_type problem = - try - let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr - and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in - incr problem_nr; - let mapper = with_out_channel (open_out filename_in) - (fun opb_problem -> ilp_print_problem opb_problem problem pb_type) in - - begin - match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with - | Unix.WEXITED 0 -> - Some (with_in_channel - (open_in filename_out) - (fun opb_solution -> - adjust_check_solution mapper - (ilp_read_solution mapper opb_solution))) - | Unix.WEXITED _ -> failwith "failed to start ilp solver" - | _ -> None - end - with - | Unschedulable -> None;; - -let current_utime_all () = - let t = Unix.times() in - t.Unix.tms_cutime +. t.Unix.tms_utime;; - -let utime_all_fn fn arg = - let utime_start = current_utime_all () in - let output = fn arg in - let utime_end = current_utime_all () in - (output, utime_end -. utime_start);; - -let cascaded_scheduler (problem : problem) = - let (some_initial_solution, list_scheduler_time) = - utime_all_fn (validated_scheduler list_scheduler) problem in - match some_initial_solution with - | None -> None - | Some initial_solution -> - let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in - begin - let latency2 = get_max_latency solution - and latency1 = get_max_latency initial_solution in - Printf.printf "postpass %s: %d, %d, %d, %g, %g\n" - (if latency2 < latency1 then "REOPTIMIZED" else "unchanged") - (get_nr_instructions problem) - latency1 latency2 - list_scheduler_time reoptimizing_time; - flush stdout - end; - Some solution;; - -let scheduler_by_name name = - match name with - | "ilp" -> validated_scheduler cascaded_scheduler - | "list" -> validated_scheduler list_scheduler - | "revlist" -> validated_scheduler reverse_list_scheduler - | "greedy" -> greedy_scheduler - | s -> failwith ("unknown scheduler: " ^ s);; diff --git a/kvx/InstructionScheduler.mli b/kvx/InstructionScheduler.mli deleted file mode 100644 index 85e2a5c6..00000000 --- a/kvx/InstructionScheduler.mli +++ /dev/null @@ -1,113 +0,0 @@ -(** Schedule instructions on a synchronized pipeline -by David Monniaux, CNRS, VERIMAG *) - -(** A latency constraint: instruction number [instr_to] should be scheduled at least [latency] clock ticks before [instr_from]. - -It is possible to specify [latency]=0, meaning that [instr_to] can be scheduled at the same clock tick as [instr_from], but not before. - -[instr_to] can be the special value equal to the number of instructions, meaning that it refers to the final output latency. *) -type latency_constraint = { - instr_from : int; - instr_to : int; - latency : int; - } - -(** A scheduling problem. - -In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. -*) -type problem = { - max_latency : int; - (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) - - resource_bounds : int array; - (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) - - instruction_usages: int array array; - (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) - - latency_constraints : latency_constraint list - (** The latency constraints that must be satisfied *) - };; - -(** Print problem for human readability. *) -val print_problem : out_channel -> problem -> unit;; - -(** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) -type solution = int array - -(** A scheduling algorithm. -The return value [Some x] is a solution [x]. -[None] means that scheduling failed. *) -type scheduler = problem -> solution option;; - -(* DISABLED -(** Schedule the problem optimally by constraint solving using the Gecode solver. *) -external gecode_scheduler : problem -> solution option - = "caml_gecode_schedule_instr" - *) - -(** Get the number the last scheduling time used for an instruction in a solution. -@return The last clock tick used *) -val maximum_slot_used : solution -> int - -(** Validate that a solution is truly a solution of a scheduling problem. -@raise Failure if validation fails *) -val check_schedule : problem -> solution -> unit - -(** Schedule the problem using a greedy list scheduling algorithm, from the start. -The first (according to instruction ordering) instruction that is ready (according to the latency constraints) is scheduled at the current clock tick. -Once a clock tick is full go to the next. - -@return [Some solution] when a solution is found, [None] if not. *) -val list_scheduler : problem -> solution option - -(** Schedule the problem using the order of instructions without any reordering *) -val greedy_scheduler : problem -> solution option - -(** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) -val schedule_reversed : scheduler -> problem -> int array option - -(** Schedule a problem from the end using a list scheduler. BUGGY *) -val reverse_list_scheduler : problem -> int array option - -(** Check that a problem is well-formed. -@raise Failure if validation fails *) -val check_problem : problem -> unit - -(** Apply a scheduler and validate the result against the input problem. -@return The solution found -@raise Failure if validation fails *) -val validated_scheduler : scheduler -> problem -> solution option;; - -(** Get max latency from solution -@return Max latency *) -val get_max_latency : solution -> int;; - -(** Get the length of a maximal critical path -@return Max length *) -val maximum_critical_path : problem -> int;; - -(** Apply line scheduler then advanced solver -@return A solution if found *) -val cascaded_scheduler : problem -> solution option;; - -val show_date_ranges : problem -> unit;; - -type pseudo_boolean_problem_type = - | SATISFIABILITY - | OPTIMIZATION;; - -type pseudo_boolean_mapper -val pseudo_boolean_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; -val pseudo_boolean_read_solution : pseudo_boolean_mapper -> in_channel -> solution;; -val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; - -val smt_print_problem : out_channel -> problem -> unit;; - -val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; - -val ilp_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; - -(** Schedule a problem using a scheduler given by a string name *) -val scheduler_by_name : string -> problem -> int array option;; diff --git a/kvx/lib/PrepassSchedulingOracle.ml b/kvx/lib/PrepassSchedulingOracle.ml deleted file mode 100644 index 78961310..00000000 --- a/kvx/lib/PrepassSchedulingOracle.ml +++ /dev/null @@ -1,432 +0,0 @@ -open AST -open RTL -open Maps -open InstructionScheduler -open OpWeights -open Registers - -let use_alias_analysis () = false - -let length_of_chunk = function -| Mint8signed -| Mint8unsigned -> 1 -| Mint16signed -| Mint16unsigned -> 2 -| Mint32 -| Mfloat32 -| Many32 -> 4 -| Mint64 -| Mfloat64 -| Many64 -> 8;; - -let get_simple_dependencies (seqa : (instruction*Regset.t) array) = - let last_reg_reads : int list PTree.t ref = ref PTree.empty - and last_reg_write : (int*int) PTree.t ref = ref PTree.empty - and last_mem_reads : int list ref = ref [] - and last_mem_write : int option ref = ref None - and last_branch : int option ref = ref None - and latency_constraints : latency_constraint list ref = ref [] in - let add_constraint instr_from instr_to latency = - assert (instr_from <= instr_to); - assert (latency >= 0); - if instr_from = instr_to - then (if latency = 0 - then () - else failwith "PrepassSchedulingOracle.get_dependencies: negative self-loop") - else - latency_constraints := - { instr_from = instr_from; - instr_to = instr_to; - latency = latency - }:: !latency_constraints - and get_last_reads reg = - match PTree.get reg !last_reg_reads - with Some l -> l - | None -> [] in - let add_input_mem i = - if not (use_alias_analysis ()) - then - begin - begin - (* Read after write *) - match !last_mem_write with - | None -> () - | Some j -> add_constraint j i 1 - end; - last_mem_reads := i :: !last_mem_reads - end - and add_output_mem i = - if not (use_alias_analysis ()) - then - begin - begin - (* Write after write *) - match !last_mem_write with - | None -> () - | Some j -> add_constraint j i 1 - end; - (* Write after read *) - List.iter (fun j -> add_constraint j i 0) !last_mem_reads; - last_mem_write := Some i; - last_mem_reads := [] - end - and add_input_reg i reg = - begin - (* Read after write *) - match PTree.get reg !last_reg_write with - | None -> () - | Some (j, latency) -> add_constraint j i latency - end; - last_reg_reads := PTree.set reg - (i :: get_last_reads reg) - !last_reg_reads - and add_output_reg i latency reg = - begin - (* Write after write *) - match PTree.get reg !last_reg_write with - | None -> () - | Some (j, _) -> add_constraint j i 1 - end; - begin - (* Write after read *) - List.iter (fun j -> add_constraint j i 0) (get_last_reads reg) - end; - last_reg_write := PTree.set reg (i, latency) !last_reg_write; - last_reg_reads := PTree.remove reg !last_reg_reads - in - let add_input_regs i regs = List.iter (add_input_reg i) regs in - let rec add_builtin_res i (res : reg builtin_res) = - match res with - | BR r -> add_output_reg i 10 r - | BR_none -> () - | BR_splitlong (hi, lo) -> add_builtin_res i hi; - add_builtin_res i lo in - let rec add_builtin_arg i (ba : reg builtin_arg) = - match ba with - | BA r -> add_input_reg i r - | BA_int _ | BA_long _ | BA_float _ | BA_single _ -> () - | BA_loadstack(_,_) -> add_input_mem i - | BA_addrstack _ -> () - | BA_loadglobal(_, _, _) -> add_input_mem i - | BA_addrglobal _ -> () - | BA_splitlong(hi, lo) -> add_builtin_arg i hi; - add_builtin_arg i lo - | BA_addptr(a1, a2) -> add_builtin_arg i a1; - add_builtin_arg i a2 in - let irreversible_action i = - match !last_branch with - | None -> () - | Some j -> add_constraint j i 1 in - let set_branch i = - irreversible_action i; - last_branch := Some i - in - Array.iteri - begin - fun i (insn, other_uses) -> - List.iter (fun use -> - add_input_reg i use) - (Regset.elements other_uses); - - match insn with - | Inop _ -> () - | Iop(op, inputs, output, _) -> - (if Op.is_trapping_op op then irreversible_action i); - add_input_regs i inputs; - add_output_reg i (latency_of_op op (List.length inputs)) output - | Iload(trap, chunk, addressing, addr_regs, output, _) -> - (if trap=TRAP then irreversible_action i); - add_input_mem i; - add_input_regs i addr_regs; - add_output_reg i (latency_of_load trap chunk addressing (List.length addr_regs)) output - | Istore(chunk, addressing, addr_regs, input, _) -> - irreversible_action i; - add_input_regs i addr_regs; - add_input_reg i input; - add_output_mem i - | Icall(signature, ef, inputs, output, _) -> - set_branch i; - (match ef with - | Datatypes.Coq_inl r -> add_input_reg i r - | Datatypes.Coq_inr symbol -> () - ); - add_input_mem i; - add_input_regs i inputs; - add_output_reg i (latency_of_call signature ef) output; - add_output_mem i; - failwith "Icall" - | Itailcall(signature, ef, inputs) -> - set_branch i; - (match ef with - | Datatypes.Coq_inl r -> add_input_reg i r - | Datatypes.Coq_inr symbol -> () - ); - add_input_mem i; - add_input_regs i inputs; - failwith "Itailcall" - | Ibuiltin(ef, builtin_inputs, builtin_output, _) -> - set_branch i; - add_input_mem i; - List.iter (add_builtin_arg i) builtin_inputs; - add_builtin_res i builtin_output; - add_output_mem i; - failwith "Ibuiltin" - | Icond(cond, inputs, _, _, _) -> - set_branch i; - add_input_mem i; - add_input_regs i inputs - | Ijumptable(input, _) -> - set_branch i; - add_input_reg i input; - failwith "Ijumptable" - | Ireturn(Some input) -> - set_branch i; - add_input_reg i input; - failwith "Ireturn" - | Ireturn(None) -> - set_branch i; - failwith "Ireturn none" - end seqa; - !latency_constraints;; - -let resources_of_instruction = function - | Inop _ -> Array.map (fun _ -> 0) resource_bounds - | Iop(op, inputs, output, _) -> resources_of_op op (List.length inputs) - | Iload(trap, chunk, addressing, addr_regs, output, _) -> - resources_of_load trap chunk addressing (List.length addr_regs) - | Istore(chunk, addressing, addr_regs, input, _) -> - resources_of_store chunk addressing (List.length addr_regs) - | Icall(signature, ef, inputs, output, _) -> - resources_of_call signature ef - | Ibuiltin(ef, builtin_inputs, builtin_output, _) -> - resources_of_builtin ef - | Icond(cond, args, _, _ , _) -> - resources_of_cond cond (List.length args) - | Itailcall _ | Ijumptable _ | Ireturn _ -> resource_bounds - -let print_sequence pp (seqa : instruction array) = - Array.iteri ( - fun i (insn : instruction) -> - PrintRTL.print_instruction pp (i, insn)) seqa;; - -type unique_id = int - -type 'a symbolic_term_node = - | STop of Op.operation * 'a list - | STinitial_reg of int - | STother of int;; - -type symbolic_term = { - hash_id : unique_id; - hash_ct : symbolic_term symbolic_term_node - };; - -let rec print_term channel term = - match term.hash_ct with - | STop(op, args) -> - PrintOp.print_operation print_term channel (op, args) - | STinitial_reg n -> Printf.fprintf channel "x%d" n - | STother n -> Printf.fprintf channel "y%d" n;; - -type symbolic_term_table = { - st_table : (unique_id symbolic_term_node, symbolic_term) Hashtbl.t; - mutable st_next_id : unique_id };; - -let hash_init () = { - st_table = Hashtbl.create 20; - st_next_id = 0 - };; - -let ground_to_id = function - | STop(op, l) -> STop(op, List.map (fun t -> t.hash_id) l) - | STinitial_reg r -> STinitial_reg r - | STother i -> STother i;; - -let hash_node (table : symbolic_term_table) (term : symbolic_term symbolic_term_node) : symbolic_term = - let grounded = ground_to_id term in - match Hashtbl.find_opt table.st_table grounded with - | Some x -> x - | None -> - let term' = { hash_id = table.st_next_id; - hash_ct = term } in - (if table.st_next_id = max_int then failwith "hash: max_int"); - table.st_next_id <- table.st_next_id + 1; - Hashtbl.add table.st_table grounded term'; - term';; - -type access = { - base : symbolic_term; - offset : int64; - length : int - };; - -let term_equal a b = (a.hash_id = b.hash_id);; - -let access_of_addressing get_reg chunk addressing args = - match addressing, args with - | (Op.Aindexed ofs), [reg] -> Some - { base = get_reg reg; - offset = Camlcoq.camlint64_of_ptrofs ofs; - length = length_of_chunk chunk - } - | _, _ -> None ;; -(* TODO: global *) - -let symbolic_execution (seqa : instruction array) = - let regs = ref PTree.empty - and table = hash_init() in - let assign reg term = regs := PTree.set reg term !regs - and hash term = hash_node table term in - let get_reg reg = - match PTree.get reg !regs with - | None -> hash (STinitial_reg (Camlcoq.P.to_int reg)) - | Some x -> x in - let targets = Array.make (Array.length seqa) None in - Array.iteri - begin - fun i insn -> - match insn with - | Iop(Op.Omove, [input], output, _) -> - assign output (get_reg input) - | Iop(op, inputs, output, _) -> - assign output (hash (STop(op, List.map get_reg inputs))) - - | Iload(trap, chunk, addressing, args, output, _) -> - let access = access_of_addressing get_reg chunk addressing args in - targets.(i) <- access; - assign output (hash (STother(i))) - - | Icall(_, _, _, output, _) - | Ibuiltin(_, _, BR output, _) -> - assign output (hash (STother(i))) - - | Istore(chunk, addressing, args, va, _) -> - let access = access_of_addressing get_reg chunk addressing args in - targets.(i) <- access - - | Inop _ -> () - | Ibuiltin(_, _, BR_none, _) -> () - | Ibuiltin(_, _, BR_splitlong _, _) -> failwith "BR_splitlong" - - | Itailcall (_, _, _) - |Icond (_, _, _, _, _) - |Ijumptable (_, _) - |Ireturn _ -> () - end seqa; - targets;; - -let print_access channel = function - | None -> Printf.fprintf channel "any" - | Some x -> Printf.fprintf channel "%a + %Ld" print_term x.base x.offset;; - -let print_targets channel seqa = - let targets = symbolic_execution seqa in - Array.iteri - (fun i insn -> - match insn with - | Iload _ -> Printf.fprintf channel "%d: load %a\n" - i print_access targets.(i) - | Istore _ -> Printf.fprintf channel "%d: store %a\n" - i print_access targets.(i) - | _ -> () - ) seqa;; - -let may_overlap a0 b0 = - match a0, b0 with - | (None, _) | (_ , None) -> true - | (Some a), (Some b) -> - if term_equal a.base b.base - then (max a.offset b.offset) < - (min (Int64.add (Int64.of_int a.length) a.offset) - (Int64.add (Int64.of_int b.length) b.offset)) - else match a.base.hash_ct, b.base.hash_ct with - | STop(Op.Oaddrsymbol(ida, ofsa),[]), - STop(Op.Oaddrsymbol(idb, ofsb),[]) -> - (ida=idb) && - let ao = Int64.add a.offset (Camlcoq.camlint64_of_ptrofs ofsa) - and bo = Int64.add b.offset (Camlcoq.camlint64_of_ptrofs ofsb) in - (max ao bo) < - (min (Int64.add (Int64.of_int a.length) ao) - (Int64.add (Int64.of_int b.length) bo)) - | STop(Op.Oaddrstack _, []), - STop(Op.Oaddrsymbol _, []) - | STop(Op.Oaddrsymbol _, []), - STop(Op.Oaddrstack _, []) -> false - | STop(Op.Oaddrstack(ofsa),[]), - STop(Op.Oaddrstack(ofsb),[]) -> - let ao = Int64.add a.offset (Camlcoq.camlint64_of_ptrofs ofsa) - and bo = Int64.add b.offset (Camlcoq.camlint64_of_ptrofs ofsb) in - (max ao bo) < - (min (Int64.add (Int64.of_int a.length) ao) - (Int64.add (Int64.of_int b.length) bo)) - | _ -> true;; - -(* -(* TODO suboptimal quadratic algorithm *) -let get_alias_dependencies seqa = - let targets = symbolic_execution seqa - and deps = ref [] in - let add_constraint instr_from instr_to latency = - deps := { instr_from = instr_from; - instr_to = instr_to; - latency = latency - }:: !deps in - for i=0 to (Array.length seqa)-1 - do - for j=0 to i-1 - do - match seqa.(j), seqa.(i) with - | (Istore _), ((Iload _) | (Istore _)) -> - if may_overlap targets.(j) targets.(i) - then add_constraint j i 1 - | (Iload _), (Istore _) -> - if may_overlap targets.(j) targets.(i) - then add_constraint j i 0 - | (Istore _ | Iload _), (Icall _ | Ibuiltin _) - | (Icall _ | Ibuiltin _), (Icall _ | Ibuiltin _ | Iload _ | Istore _) -> - add_constraint j i 1 - | (Inop _ | Iop _), _ - | _, (Inop _ | Iop _) - | (Iload _), (Iload _) -> () - done - done; - !deps;; - *) - -let define_problem seqa = - let simple_deps = get_simple_dependencies seqa in - { max_latency = -1; - resource_bounds = OpWeights.resource_bounds; - instruction_usages = Array.map resources_of_instruction (Array.map fst seqa); - latency_constraints = - (* if (use_alias_analysis ()) - then (get_alias_dependencies seqa) @ simple_deps - else *) simple_deps };; - -let schedule_sequence (seqa : (instruction*Regset.t) array) = - try - if (Array.length seqa) <= 1 - then None - else - begin - let nr_instructions = Array.length seqa in - Printf.printf "prepass scheduling length = %d\n" (Array.length seqa); - let problem = define_problem seqa in - print_sequence stdout (Array.map fst seqa); - print_problem stdout problem; - match scheduler_by_name (!Clflags.option_fprepass_sched) problem with - | None -> Printf.printf "no solution in prepass scheduling\n"; - None - | Some solution -> - let positions = Array.init nr_instructions (fun i -> i) in - Array.sort (fun i j -> - let si = solution.(i) and sj = solution.(j) in - if si < sj then -1 - else if si > sj then 1 - else i - j) positions; - Some positions - end - with (Failure s) -> - Printf.printf "failure in prepass scheduling: %s\n" s; - None;; - diff --git a/kvx/lib/RTLpath.v b/kvx/lib/RTLpath.v deleted file mode 100644 index 82991a4d..00000000 --- a/kvx/lib/RTLpath.v +++ /dev/null @@ -1,1066 +0,0 @@ -(** We introduce a data-structure extending the RTL CFG into a control-flow graph over "traces" (in the sense of "trace-scheduling") - Here, we use the word "path" instead of "trace" because "trace" has already a meaning in CompCert: - a "path" is simply a list of successive nodes in the CFG (modulo some additional wellformness conditions). - - Actually, we extend syntactically the notion of RTL programs with a structure of "path_map": - this gives an alternative view of the CFG -- where "nodes" are paths instead of simple instructions. - Our wellformness condition on paths express that: - - the CFG on paths is wellformed: any successor of a given path points to another path (possibly the same). - - execution of a paths only emit single events. - - We represent each path only by a natural: the number of nodes in the path. These nodes are recovered from a static notion of "default successor". - This notion of path is thus incomplete. For example, if a path contains a whole loop (and for example, unrools it several times), - then this loop must be a suffix of the path. - - However: it is sufficient in order to represent superblocks (each superblock being represented as a path). - A superblock decomposition of the CFG exactly corresponds to the case where each node is in at most one path. - - Our goal is to provide two bisimulable semantics: - - one is simply the RTL semantics - - the other is based on a notion of "path-step": each path is executed in a single step. - - Remark that all analyses on RTL programs should thus be appliable for "free" also for RTLpath programs ! -*) - -Require Import Coqlib Maps. -Require Import AST Integers Values Events Memory Globalenvs Smallstep. -Require Import Op Registers. -Require Import RTL Linking. - -Declare Scope option_monad_scope. - -Notation "'SOME' X <- A 'IN' B" := (match A with Some X => B | None => None end) - (at level 200, X ident, A at level 100, B at level 200) - : option_monad_scope. - -Notation "'ASSERT' A 'IN' B" := (if A then B else None) - (at level 200, A at level 100, B at level 200) - : option_monad_scope. - -Local Open Scope option_monad_scope. - -(** * Syntax of RTLpath programs *) - -(** Internal instruction = instruction with a default successor in a path. *) - -Definition default_succ (i: instruction): option node := - match i with - | Inop s => Some s - | Iop op args res s => Some s - | Iload _ chunk addr args dst s => Some s - | Istore chunk addr args src s => Some s - | Icond cond args ifso ifnot _ => Some ifnot - | _ => None (* TODO: we could choose a successor for jumptable ? *) - end. - -Definition early_exit (i: instruction): option node := (* FIXME: for jumptable, replace [node] by [list node] *) - match i with - | Icond cond args ifso ifnot _ => Some ifso - | _ => None - end. - -(** Our notion of path. - - We do not formally require that the set of path is a partition of the CFG. - path may have intersections ! - - Moreover, we do not formally require that path have a single entry-point (a superblock structure) - - But, in practice, these properties are probably necessary in order to ensure the success of dynamic verification of scheduling. - - Here: we only require that each exit-point of a path is the entry-point of a path - (and that internal node of a path are internal instructions) -*) - - -(* By convention, we say that node [n] is the entry-point of a path if it is a key of the path_map. - - Such a path of entry [n] is defined from a natural [path] representing the [path] default-successors of [n]. - - Remark: a path can loop several times in the CFG. - -*) - -Record path_info := { - psize: nat; (* number minus 1 of instructions in the path *) - input_regs: Regset.t; - (** Registers that are used (as input_regs) by the "fallthrough successors" of the path *) - (** This field is not used by the verificator, but is helpful for the superblock scheduler *) - output_regs: Regset.t -}. - -Definition path_map: Type := PTree.t path_info. - -Definition path_entry (*c:code*) (pm: path_map) (n: node): Prop - := pm!n <> None (*/\ c!n <> None*). - -Inductive wellformed_path (c:code) (pm: path_map): nat -> node -> Prop := - | wf_last_node i pc: - c!pc = Some i -> - (forall n, List.In n (successors_instr i) -> path_entry (*c*) pm n) -> - wellformed_path c pm 0 pc - | wf_internal_node path i pc pc': - c!pc = Some i -> - default_succ i = Some pc' -> - (forall n, early_exit i = Some n -> path_entry (*c*) pm n) -> - wellformed_path c pm path pc' -> - wellformed_path c pm (S path) pc. - -(* all paths defined from the path_map are wellformed *) -Definition wellformed_path_map (c:code) (pm: path_map): Prop := - forall n path, pm!n = Some path -> wellformed_path c pm path.(psize) n. - -(** We "extend" the notion of RTL program with the additional structure for path. - - There is thus a trivial "forgetful functor" from RTLpath programs to RTL ones. -*) - -Record function : Type := - { fn_RTL:> RTL.function; - fn_path: path_map; - (* condition 1 below: the entry-point of the code is an entry-point of a path *) - fn_entry_point_wf: path_entry (*fn_RTL.(fn_code)*) fn_path fn_RTL.(fn_entrypoint); - (* condition 2 below: the path_map is well-formed *) - fn_path_wf: wellformed_path_map fn_RTL.(fn_code) fn_path - }. - -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -Definition genv := Genv.t fundef unit. - -Definition fundef_RTL (fu: fundef) : RTL.fundef := - match fu with - | Internal f => Internal f.(fn_RTL) - | External ef => External ef - end. -Coercion fundef_RTL: fundef >-> RTL.fundef. - -Definition transf_program (p: program) : RTL.program := transform_program fundef_RTL p. -Coercion transf_program: program >-> RTL.program. - -(** * Path-step semantics of RTLpath programs *) - -(* Semantics of internal instructions (mimicking RTL semantics) *) - -Record istate := mk_istate { icontinue: bool; ipc: node; irs: regset; imem: mem }. - -(* FIXME - prediction *) -(* Internal step through the path *) -Definition istep (ge: RTL.genv) (i: instruction) (sp: val) (rs: regset) (m: mem): option istate := - match i with - | Inop pc' => Some (mk_istate true pc' rs m) - | Iop op args res pc' => - SOME v <- eval_operation ge sp op rs##args m IN - Some (mk_istate true pc' (rs#res <- v) m) - | Iload TRAP chunk addr args dst pc' => - SOME a <- eval_addressing ge sp addr rs##args IN - SOME v <- Mem.loadv chunk m a IN - Some (mk_istate true pc' (rs#dst <- v) m) - | Iload NOTRAP chunk addr args dst pc' => - let default_state := mk_istate true pc' rs#dst <- (default_notrap_load_value chunk) m in - match (eval_addressing ge sp addr rs##args) with - | None => Some default_state - | Some a => match (Mem.loadv chunk m a) with - | None => Some default_state - | Some v => Some (mk_istate true pc' (rs#dst <- v) m) - end - end - | Istore chunk addr args src pc' => - SOME a <- eval_addressing ge sp addr rs##args IN - SOME m' <- Mem.storev chunk m a rs#src IN - Some (mk_istate true pc' rs m') - | Icond cond args ifso ifnot _ => - SOME b <- eval_condition cond rs##args m IN - Some (mk_istate (negb b) (if b then ifso else ifnot) rs m) - | _ => None (* TODO jumptable ? *) - end. - -(** Execution of a path in a single step *) - -(* Executes until a state [st] is reached where st.(continue) is false *) -Fixpoint isteps ge (path:nat) (f: function) sp rs m pc: option istate := - match path with - | O => Some (mk_istate true pc rs m) - | S p => - SOME i <- (fn_code f)!pc IN - SOME st <- istep ge i sp rs m IN - if (icontinue st) then - isteps ge p f sp (irs st) (imem st) (ipc st) - else - Some st - end. - -Definition find_function (pge: genv) (ros: reg + ident) (rs: regset) : option fundef := - match ros with - | inl r => Genv.find_funct pge rs#r - | inr symb => - match Genv.find_symbol pge symb with - | None => None - | Some b => Genv.find_funct_ptr pge b - end - end. - -Inductive stackframe : Type := - | Stackframe - (res: reg) (**r where to store the result *) - (f: function) (**r calling function *) - (sp: val) (**r stack pointer in calling function *) - (pc: node) (**r program point in calling function *) - (rs: regset) (**r register state in calling function *) - . - -Definition stf_RTL (st: stackframe): RTL.stackframe := - match st with - | Stackframe res f sp pc rs => RTL.Stackframe res f sp pc rs - end. - -Fixpoint stack_RTL (stack: list stackframe): list RTL.stackframe := - match stack with - | nil => nil - | cons stf stack' => cons (stf_RTL stf) (stack_RTL stack') - end. - -Inductive state : Type := - | State - (stack: list stackframe) (**r call stack *) - (f: function) (**r current function *) - (sp: val) (**r stack pointer *) - (pc: node) (**r current program point in [c] *) - (rs: regset) (**r register state *) - (m: mem) (**r memory state *) - | Callstate - (stack: list stackframe) (**r call stack *) - (f: fundef) (**r function to call *) - (args: list val) (**r arguments to the call *) - (m: mem) (**r memory state *) - | Returnstate - (stack: list stackframe) (**r call stack *) - (v: val) (**r return value for the call *) - (m: mem) (**r memory state *) - . - -Definition state_RTL (s: state): RTL.state := - match s with - | State stack f sp pc rs m => RTL.State (stack_RTL stack) f sp pc rs m - | Callstate stack f args m => RTL.Callstate (stack_RTL stack) f args m - | Returnstate stack v m => RTL.Returnstate (stack_RTL stack) v m - end. -Coercion state_RTL: state >-> RTL.state. - -(* Used to execute the last instruction of a path (isteps is only in charge of executing the instructions before the last) *) -Inductive path_last_step ge pge stack (f: function): val -> node -> regset -> mem -> trace -> state -> Prop := - | exec_istate i sp pc rs m st: - (fn_code f)!pc = Some i -> - istep ge i sp rs m = Some st -> - path_last_step ge pge stack f sp pc rs m - E0 (State stack f sp (ipc st) (irs st) (imem st)) - | exec_Icall sp pc rs m sig ros args res pc' fd: - (fn_code f)!pc = Some(Icall sig ros args res pc') -> - find_function pge ros rs = Some fd -> - funsig fd = sig -> - path_last_step ge pge stack f sp pc rs m - E0 (Callstate (Stackframe res f sp pc' rs :: stack) fd rs##args m) - | exec_Itailcall stk pc rs m sig ros args fd m': - (fn_code f)!pc = Some(Itailcall sig ros args) -> - find_function pge ros rs = Some fd -> - funsig fd = sig -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - path_last_step ge pge stack f (Vptr stk Ptrofs.zero) pc rs m - E0 (Callstate stack fd rs##args m') - | exec_Ibuiltin sp pc rs m ef args res pc' vargs t vres m': - (fn_code f)!pc = Some(Ibuiltin ef args res pc') -> - eval_builtin_args ge (fun r => rs#r) sp m args vargs -> - external_call ef ge vargs m t vres m' -> - path_last_step ge pge stack f sp pc rs m - t (State stack f sp pc' (regmap_setres res vres rs) m') - | exec_Ijumptable sp pc rs m arg tbl n pc': (* TODO remove jumptable from here ? *) - (fn_code f)!pc = Some(Ijumptable arg tbl) -> - rs#arg = Vint n -> - list_nth_z tbl (Int.unsigned n) = Some pc' -> - path_last_step ge pge stack f sp pc rs m - E0 (State stack f sp pc' rs m) - | exec_Ireturn stk pc rs m or m': - (fn_code f)!pc = Some(Ireturn or) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - path_last_step ge pge stack f (Vptr stk Ptrofs.zero) pc rs m - E0 (Returnstate stack (regmap_optget or Vundef rs) m'). - -(* Executes an entire path *) -Inductive path_step ge pge (path:nat) stack f sp rs m pc: trace -> state -> Prop := - | exec_early_exit st: - isteps ge path f sp rs m pc = Some st -> - (icontinue st) = false -> - path_step ge pge path stack f sp rs m pc E0 (State stack f sp (ipc st) (irs st) (imem st)) - | exec_normal_exit st t s: - isteps ge path f sp rs m pc = Some st -> - (icontinue st) = true -> - path_last_step ge pge stack f sp (ipc st) (irs st) (imem st) t s -> - path_step ge pge path stack f sp rs m pc t s. - -(* Either internal path execution, or the usual exec_function / exec_return borrowed from RTL *) -Inductive step ge pge: state -> trace -> state -> Prop := - | exec_path path stack f sp rs m pc t s: - (fn_path f)!pc = Some path -> - path_step ge pge path.(psize) stack f sp rs m pc t s -> - step ge pge (State stack f sp pc rs m) t s - | exec_function_internal s f args m m' stk: - Mem.alloc m 0 (fn_RTL f).(fn_stacksize) = (m', stk) -> - step ge pge (Callstate s (Internal f) args m) - E0 (State s - f - (Vptr stk Ptrofs.zero) - f.(fn_entrypoint) - (init_regs args f.(fn_params)) - m') - | exec_function_external s ef args res t m m': - external_call ef ge args m t res m' -> - step ge pge (Callstate s (External ef) args m) - t (Returnstate s res m') - | exec_return res f sp pc rs s vres m: - step ge pge (Returnstate (Stackframe res f sp pc rs :: s) vres m) - E0 (State s f sp pc (rs#res <- vres) m). - -Inductive initial_state (p:program) : state -> Prop := - initial_state_intro (b : block) (f : fundef) (m0 : mem): - Genv.init_mem p = Some m0 -> - Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b -> - Genv.find_funct_ptr (Genv.globalenv p) b = Some f -> - funsig f = signature_main -> initial_state p (Callstate nil f nil m0). - -Definition final_state (st: state) (i:int): Prop - := RTL.final_state st i. - -Definition semantics (p: program) := - Semantics (step (Genv.globalenv (transf_program p))) (initial_state p) final_state (Genv.globalenv p). - -(** * Proving the bisimulation between (semantics p) and (RTL.semantics p). *) - -(** ** Preliminaries: simple tactics for option-monad *) - -Lemma destruct_SOME A B (P: option B -> Prop) (e: option A) (f: A -> option B): - (forall x, e = Some x -> P (f x)) -> (e = None -> P None) -> (P (SOME x <- e IN f x)). -Proof. - intros; destruct e; simpl; auto. -Qed. - -Lemma destruct_ASSERT B (P: option B -> Prop) (e: bool) (x: option B): - (e = true -> P x) -> (e = false -> P None) -> (P (ASSERT e IN x)). -Proof. - intros; destruct e; simpl; auto. -Qed. - -Ltac inversion_SOME x := - try (eapply destruct_SOME; [ let x := fresh x in intro x | simpl; try congruence ]). - -Ltac inversion_ASSERT := - try (eapply destruct_ASSERT; [ idtac | simpl; try congruence ]). - -Ltac simplify_someHyp := - match goal with - | H: None = Some _ |- _ => inversion H; clear H; subst - | H: Some _ = None |- _ => inversion H; clear H; subst - | H: ?t = ?t |- _ => clear H - | H: Some _ = Some _ |- _ => inversion H; clear H; subst - | H: Some _ <> None |- _ => clear H - | H: None <> Some _ |- _ => clear H - | H: _ = Some _ |- _ => (try rewrite !H in * |- *); generalize H; clear H - end. - -Ltac explore_destruct := - repeat (match goal with - | [H: ?expr = ?val |- context[match ?expr with | _ => _ end]] => rewrite H - | [H: match ?var with | _ => _ end |- _] => destruct var - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | _ => discriminate - end). - -Ltac simplify_someHyps := - repeat (simplify_someHyp; simpl in * |- *). - -Ltac try_simplify_someHyps := - try (intros; simplify_someHyps; eauto). - -(* TODO: try to improve this tactic with a better control over names and inversion *) -Ltac simplify_SOME x := - (repeat inversion_SOME x); try_simplify_someHyps. - -(** ** The easy way: Forward simulation of RTLpath by RTL - -This way can be viewed as a correctness property: all transitions in RTLpath are valid RTL transitions ! - -*) - -Local Hint Resolve RTL.exec_Inop RTL.exec_Iop RTL.exec_Iload RTL.exec_Istore RTL.exec_Icond RTL.exec_Iload_notrap1 RTL.exec_Iload_notrap2: core. - -(* istep reflects RTL.step *) -Lemma istep_correct ge i stack (f:function) sp rs m st : - istep ge i sp rs m = Some st -> - forall pc, (fn_code f)!pc = Some i -> - RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). -Proof. - destruct i; simpl; try congruence; simplify_SOME x. - 1-3: explore_destruct; simplify_SOME x. -Qed. - -Local Hint Resolve star_refl: core. - -(* isteps reflects a star relation on RTL.step *) -Lemma isteps_correct ge path stack f sp: forall rs m pc st, - isteps ge path f sp rs m pc = Some st -> - star RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). -Proof. - induction path; simpl; try_simplify_someHyps. - inversion_SOME i; intros Hi. - inversion_SOME st0; intros Hst0. - destruct (icontinue st0) eqn:cont. - + intros; eapply star_step. - - eapply istep_correct; eauto. - - simpl; eauto. - - auto. - + intros; simplify_someHyp; eapply star_step. - - eapply istep_correct; eauto. - - simpl; eauto. - - auto. -Qed. - -Lemma isteps_correct_early_exit ge path stack f sp: forall rs m pc st, - isteps ge path f sp rs m pc = Some st -> - st.(icontinue) = false -> - plus RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). -Proof. - destruct path; simpl; try_simplify_someHyps; try congruence. - inversion_SOME i; intros Hi. - inversion_SOME st0; intros Hst0. - destruct (icontinue st0) eqn:cont. - + intros; eapply plus_left. - - eapply istep_correct; eauto. - - eapply isteps_correct; eauto. - - auto. - + intros X; inversion X; subst. - eapply plus_one. - eapply istep_correct; eauto. -Qed. - -Local Hint Resolve list_forall2_nil match_globdef_fun linkorder_refl match_globvar_intro: core. - -Section CORRECTNESS. - -Variable p: program. - -Lemma match_prog_RTL: match_program (fun _ f tf => tf = fundef_RTL f) eq p (transf_program p). -Proof. - eapply match_transform_program; eauto. -Qed. - -Let pge := Genv.globalenv p. -Let ge := Genv.globalenv (transf_program p). - -Lemma senv_preserved: Senv.equiv pge ge. -Proof (Genv.senv_match match_prog_RTL). - -Lemma symbols_preserved s: Genv.find_symbol ge s = Genv.find_symbol pge s. -Proof (Genv.find_symbol_match match_prog_RTL s). - -Lemma find_function_RTL_match ros rs fd: - find_function pge ros rs = Some fd -> RTL.find_function ge ros rs = Some (fundef_RTL fd). -Proof. - destruct ros; simpl. - + intro; exploit (Genv.find_funct_match match_prog_RTL); eauto. - intros (cuint & tf & H1 & H2 & H3); subst; auto. - + rewrite symbols_preserved. - destruct (Genv.find_symbol pge i); simpl; try congruence. - intro; exploit (Genv.find_funct_ptr_match match_prog_RTL); eauto. - intros (cuint & tf & H1 & H2 & H3); subst; auto. -Qed. - -Local Hint Resolve istep_correct RTL.exec_Ibuiltin RTL.exec_Ijumptable RTL.exec_Ireturn RTL.exec_Icall RTL.exec_Itailcall find_function_RTL_match: core. - -Lemma path_last_step_correct stack f sp pc rs m t s: - path_last_step ge pge stack f sp pc rs m t s -> - RTL.step ge (State stack f sp pc rs m) t s. -Proof. - destruct 1; try (eapply istep_correct); simpl; eauto. -Qed. - -Lemma path_step_correct path stack f sp pc rs m t s: - path_step ge pge path stack f sp rs m pc t s -> - plus RTL.step ge (State stack f sp pc rs m) t s. -Proof. - destruct 1. - + eapply isteps_correct_early_exit; eauto. - + eapply plus_right. - eapply isteps_correct; eauto. - eapply path_last_step_correct; eauto. - auto. -Qed. - -Local Hint Resolve plus_one RTL.exec_function_internal RTL.exec_function_external RTL.exec_return: core. - -Lemma step_correct s t s': step ge pge s t s' -> plus RTL.step ge s t s'. -Proof. - destruct 1; try (eapply path_step_correct); simpl; eauto. -Qed. - -Theorem RTLpath_correct: forward_simulation (semantics p) (RTL.semantics p). -Proof. - eapply forward_simulation_plus with (match_states := fun s1 s2 => s2 = state_RTL s1); simpl; auto. - - apply senv_preserved. - - destruct 1; intros; eexists; intuition eauto. econstructor; eauto. - + apply (Genv.init_mem_match match_prog_RTL); auto. - + rewrite (Genv.find_symbol_match match_prog_RTL). - rewrite (match_program_main match_prog_RTL); eauto. - + exploit (Genv.find_funct_ptr_match match_prog_RTL); eauto. - intros (cunit & tf0 & XX); intuition subst; eauto. - - unfold final_state; intros; subst; eauto. - - intros; subst. eexists; intuition. - eapply step_correct; eauto. -Qed. - -End CORRECTNESS. - -Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), - prog_defs p1 = prog_defs p2 -> - prog_public p1 = prog_public p2 -> - prog_main p1 = prog_main p2 -> - p1 = p2. -Proof. - intros. destruct p1. destruct p2. simpl in *. subst. auto. -Qed. - -Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. -Proof. - intros. congruence. -Qed. - -(* Definition transf_program : RTLpath.program -> RTL.program := transform_program fundef_RTL. - -Lemma transf_program_proj: forall p, transf_program (transf_program p) = p. -Proof. - intros p. destruct p as [defs pub main]. unfold program_proj. simpl. - apply program_equals; simpl; auto. - induction defs. - - simpl; auto. - - simpl. rewrite IHdefs. - destruct a as [id gd]; simpl. - destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj. auto. -Qed. *) - - -(** The hard way: Forward simulation of RTL by RTLpath - -This way can be viewed as a completeness property: all transitions in RTL can be represented as RTLpath transitions ! - -*) - -(* This lemma is probably needed to compose a pass from RTL -> RTLpath with other passes.*) -Lemma match_RTL_prog {LA: Linker fundef} {LV: Linker unit} p: match_program (fun _ f tf => f = fundef_RTL tf) eq (transf_program p) p. -Proof. - unfold match_program, match_program_gen; intuition. - unfold transf_program at 2; simpl. - generalize (prog_defs p). - induction l as [|a l]; simpl; eauto. - destruct a; simpl. - intros; eapply list_forall2_cons; eauto. - unfold match_ident_globdef; simpl; intuition; destruct g as [f|v]; simpl; eauto. - eapply match_globdef_var. destruct v; eauto. -Qed. - -(* Theory of wellformed paths *) - -Fixpoint nth_default_succ (c: code) (path:nat) (pc: node): option node := - match path with - | O => Some pc - | S path' => - SOME i <- c!pc IN - SOME pc' <- default_succ i IN - nth_default_succ c path' pc' - end. - -Lemma wellformed_suffix_path c pm path path': - (path' <= path)%nat -> - forall pc, wellformed_path c pm path pc -> - exists pc', nth_default_succ c (path-path') pc = Some pc' /\ wellformed_path c pm path' pc'. -Proof. - induction 1 as [|m]. - + intros. enough (path'-path'=0)%nat as ->; [simpl;eauto|omega]. - + intros pc WF; enough (S m-path'=S (m-path'))%nat as ->; [simpl;eauto|omega]. - inversion WF; subst; clear WF; intros; simplify_someHyps. - intros; simplify_someHyps; eauto. -Qed. - -Definition nth_default_succ_inst (c: code) (path:nat) pc: option instruction := - SOME pc <- nth_default_succ c path pc IN - c!pc. - -Lemma final_node_path f path pc: - (fn_path f)!pc = Some path -> - exists i, nth_default_succ_inst (fn_code f) path.(psize) pc = Some i - /\ (forall n, List.In n (successors_instr i) -> path_entry (*fn_code f*) (fn_path f) n). -Proof. - intros; exploit fn_path_wf; eauto. - intro WF. - set (ps:=path.(psize)). - exploit (wellformed_suffix_path (fn_code f) (fn_path f) ps O); omega || eauto. - destruct 1 as (pc' & NTH_SUCC & WF'); auto. - assert (ps - 0 = ps)%nat as HH by omega. rewrite HH in NTH_SUCC. clear HH. - unfold nth_default_succ_inst. - inversion WF'; clear WF'; subst. simplify_someHyps; eauto. -Qed. - -Lemma internal_node_path path f path0 pc: - (fn_path f)!pc = (Some path0) -> - (path < path0.(psize))%nat -> - exists i pc', - nth_default_succ_inst (fn_code f) path pc = Some i /\ - default_succ i = Some pc' /\ - (forall n, early_exit i = Some n -> path_entry (*fn_code f*) (fn_path f) n). -Proof. - intros; exploit fn_path_wf; eauto. - set (ps:=path0.(psize)). - intro WF; exploit (wellformed_suffix_path (fn_code f) (fn_path f) ps (ps-path)); eauto. { omega. } - destruct 1 as (pc' & NTH_SUCC & WF'). - assert (ps - (ps - path) = path)%nat as HH by omega. rewrite HH in NTH_SUCC. clear HH. - unfold nth_default_succ_inst. - inversion WF'; clear WF'; subst. { omega. } - simplify_someHyps; eauto. -Qed. - -Lemma initialize_path (*c*) pm n: path_entry (*c*) pm n -> exists path, pm!n = Some path. -Proof. - unfold path_entry; destruct pm!n; eauto. intuition congruence. -Qed. -Local Hint Resolve fn_entry_point_wf: core. -Local Opaque path_entry. - -Lemma istep_successors ge i sp rs m st: - istep ge i sp rs m = Some st -> - In (ipc st) (successors_instr i). -Proof. - destruct i; simpl; try congruence; simplify_SOME x. - all: explore_destruct; simplify_SOME x. -Qed. - -Lemma istep_normal_exit ge i sp rs m st: - istep ge i sp rs m = Some st -> - st.(icontinue) = true -> - default_succ i = Some st.(ipc). -Proof. - destruct i; simpl; try congruence; simplify_SOME x. - all: explore_destruct; simplify_SOME x. -Qed. - -Lemma isteps_normal_exit ge path f sp: forall rs m pc st, - st.(icontinue) = true -> - isteps ge path f sp rs m pc = Some st -> - nth_default_succ (fn_code f) path pc = Some st.(ipc). -Proof. - induction path; simpl. { try_simplify_someHyps. } - intros rs m pc st CONT; try_simplify_someHyps. - inversion_SOME i; intros Hi. - inversion_SOME st0; intros Hst0. - destruct (icontinue st0) eqn:X; try congruence. - try_simplify_someHyps. - intros; erewrite istep_normal_exit; eauto. -Qed. - - -(* TODO: the three following lemmas could maybe simplified by introducing an auxiliary - left-recursive definition equivalent to isteps ? -*) -Lemma isteps_step_right ge path f sp: forall rs m pc st i, - isteps ge path f sp rs m pc = Some st -> - st.(icontinue) = true -> - (fn_code f)!(st.(ipc)) = Some i -> - istep ge i sp st.(irs) st.(imem) = isteps ge (S path) f sp rs m pc. -Proof. - induction path. - + simpl; intros; try_simplify_someHyps. simplify_SOME st. - destruct st as [b]; destruct b; simpl; auto. - + intros rs m pc st i H. - simpl in H. - generalize H; clear H; simplify_SOME xx. - destruct (icontinue xx0) eqn: CONTxx0. - * intros; erewrite IHpath; eauto. - * intros; congruence. -Qed. - -Lemma isteps_inversion_early ge path f sp: forall rs m pc st, - isteps ge path f sp rs m pc = Some st -> - (icontinue st)=false -> - exists st0 i path0, - (path > path0)%nat /\ - isteps ge path0 f sp rs m pc = Some st0 /\ - st0.(icontinue) = true /\ - (fn_code f)!(st0.(ipc)) = Some i /\ - istep ge i sp st0.(irs) st0.(imem) = Some st. -Proof. - induction path as [|path]; simpl. - - intros; try_simplify_someHyps; try congruence. - - intros rs m pc st; inversion_SOME i; inversion_SOME st0. - destruct (icontinue st0) eqn: CONT. - + intros STEP PC STEPS CONT0. exploit IHpath; eauto. - clear STEPS. - intros (st1 & i0 & path0 & BOUND & STEP1 & CONT1 & X1 & X2); auto. - exists st1. exists i0. exists (S path0). intuition. - simpl; try_simplify_someHyps. - rewrite CONT. auto. - + intros; try_simplify_someHyps; try congruence. - eexists. exists i. exists O; simpl. intuition eauto. - omega. -Qed. - -Lemma isteps_resize ge path0 path1 f sp rs m pc st: - (path0 <= path1)%nat -> - isteps ge path0 f sp rs m pc = Some st -> - (icontinue st)=false -> - isteps ge path1 f sp rs m pc = Some st. -Proof. - induction 1 as [|path1]; simpl; auto. - intros PSTEP CONT. exploit IHle; auto. clear PSTEP IHle H path0. - generalize rs m pc st CONT; clear rs m pc st CONT. - induction path1 as [|path]; simpl; auto. - - intros; try_simplify_someHyps; try congruence. - - intros rs m pc st; inversion_SOME i; inversion_SOME st0; intros; try_simplify_someHyps. - destruct (icontinue st0) eqn: CONT0; eauto. -Qed. - -(* FIXME - add prediction *) -Inductive is_early_exit pc: instruction -> Prop := - | Icond_early_exit cond args ifnot predict: - is_early_exit pc (Icond cond args pc ifnot predict) - . (* TODO add jumptable here ? *) - -Lemma istep_early_exit ge i sp rs m st : - istep ge i sp rs m = Some st -> - st.(icontinue) = false -> - st.(irs) = rs /\ st.(imem) = m /\ is_early_exit st.(ipc) i. -Proof. - Local Hint Resolve Icond_early_exit: core. - destruct i; simpl; try congruence; simplify_SOME b; simpl; try congruence. - all: explore_destruct; simplify_SOME b; try discriminate. -Qed. - -Section COMPLETENESS. - -Variable p: program. - -Let pge := Genv.globalenv p. -Let ge := Genv.globalenv (transf_program p). - -Lemma find_funct_ptr_RTL_preserv b f: - Genv.find_funct_ptr ge b = Some f -> (exists f0, Genv.find_funct_ptr pge b = Some f0 /\ f = f0). -Proof. - intros; exploit (Genv.find_funct_ptr_match (match_RTL_prog p)); eauto. - destruct 1 as (cunit & tf & X & Y & Z); subst. - eauto. -Qed. - -Lemma find_RTL_function_match ros rs fd: - RTL.find_function ge ros rs = Some fd -> exists fd', fd = fundef_RTL fd' /\ find_function pge ros rs = Some fd'. -Proof. - destruct ros; simpl. - + intro; exploit (Genv.find_funct_match (match_RTL_prog p)); eauto. - intros (cuint & tf & H1 & H2 & H3); subst; eauto. - + rewrite (symbols_preserved p); unfold pge. - destruct (Genv.find_symbol (Genv.globalenv p) i); simpl; try congruence. - intro; exploit find_funct_ptr_RTL_preserv; eauto. - intros (tf & H1 & H2); subst; eauto. -Qed. - - -(** *** Definition of well-formed stacks and of match_states *) -Definition wf_stf (st: stackframe): Prop := - match st with - | Stackframe res f sp pc rs => path_entry (*f.(fn_code)*) f.(fn_path) pc - end. - -Definition wf_stackframe (stack: list stackframe): Prop := - forall st, List.In st stack -> wf_stf st. - -Lemma wf_stackframe_nil: wf_stackframe nil. -Proof. - unfold wf_stackframe; simpl. tauto. -Qed. -Local Hint Resolve wf_stackframe_nil: core. - -Lemma wf_stackframe_cons st stack: - wf_stackframe (st::stack) <-> (wf_stf st) /\ wf_stackframe stack. -Proof. - unfold wf_stackframe; simpl; intuition (subst; auto). -Qed. - -Definition stack_of (s: state): list stackframe := - match s with - | State stack f sp pc rs m => stack - | Callstate stack f args m => stack - | Returnstate stack v m => stack - end. - -Definition is_inst (s: RTL.state): bool := - match s with - | RTL.State stack f sp pc rs m => true - | _ => false - end. - -Inductive match_inst_states_goal (idx: nat) (s1:RTL.state): state -> Prop := - | State_match path stack f sp pc rs m s2: - (fn_path f)!pc = Some path -> - (idx <= path.(psize))%nat -> - isteps ge (path.(psize)-idx) f sp rs m pc = Some s2 -> - s1 = State stack f sp s2.(ipc) s2.(irs) s2.(imem) -> - match_inst_states_goal idx s1 (State stack f sp pc rs m). - -Definition match_inst_states (idx: nat) (s1:RTL.state) (s2:state): Prop := - if is_inst s1 then match_inst_states_goal idx s1 s2 else s1 = state_RTL s2. - -Definition match_states (idx: nat) (s1:RTL.state) (s2:state): Prop := - match_inst_states idx s1 s2 - /\ wf_stackframe (stack_of s2). - -(** *** Auxiliary lemmas of completeness *) -Lemma istep_complete t i stack f sp rs m pc s': - RTL.step ge (State stack f sp pc rs m) t s' -> - (fn_code f)!pc = Some i -> - default_succ i <> None -> - t = E0 /\ exists st, istep ge i sp rs m = Some st /\ s'=(State stack f sp st.(ipc) st.(irs) st.(imem)). -Proof. - intros H X; inversion H; simpl; subst; try rewrite X in * |-; clear X; simplify_someHyps; try congruence; - (split; auto); simplify_someHyps; eexists; split; simplify_someHyps; eauto. - all: explore_destruct; simplify_SOME a. -Qed. - -Lemma stuttering path idx stack f sp rs m pc st t s1': - isteps ge (path.(psize)-(S idx)) f sp rs m pc = Some st -> - (fn_path f)!pc = Some path -> - (S idx <= path.(psize))%nat -> - st.(icontinue) = true -> - RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> - t = E0 /\ match_inst_states idx s1' (State stack f sp pc rs m). -Proof. - intros PSTEP PATH BOUND CONT RSTEP; exploit (internal_node_path (path.(psize)-(S idx))); omega || eauto. - intros (i & pc' & Hi & Hpc & DUM). - unfold nth_default_succ_inst in Hi. - erewrite isteps_normal_exit in Hi; eauto. - exploit istep_complete; congruence || eauto. - intros (SILENT & st0 & STEP0 & EQ). - intuition; subst; unfold match_inst_states; simpl. - intros; refine (State_match _ _ path stack f sp pc rs m _ PATH _ _ _); simpl; omega || eauto. - set (ps:=path.(psize)). enough (ps - idx = S (ps - (S idx)))%nat as ->; try omega. - erewrite <- isteps_step_right; eauto. -Qed. - -Lemma normal_exit path stack f sp rs m pc st t s1': - isteps ge path.(psize) f sp rs m pc = Some st -> - (fn_path f)!pc = Some path -> - st.(icontinue) = true -> - RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> - wf_stackframe stack -> - exists s2', - (path_last_step ge pge stack f sp st.(ipc) st.(irs) st.(imem)) t s2' - /\ (exists idx', match_states idx' s1' s2'). -Proof. - Local Hint Resolve istep_successors list_nth_z_in: core. (* Hint for path_entry proofs *) - intros PSTEP PATH CONT RSTEP WF; exploit (final_node_path f path); eauto. - intros (i & Hi & SUCCS). - unfold nth_default_succ_inst in Hi. - erewrite isteps_normal_exit in Hi; eauto. - destruct (default_succ i) eqn:Hn0. - + (* exec_istate *) - exploit istep_complete; congruence || eauto. - intros (SILENT & st0 & STEP0 & EQ); subst. - exploit (exec_istate ge pge); eauto. - eexists; intuition eauto. - unfold match_states, match_inst_states; simpl. - destruct (initialize_path (*fn_code f*) (fn_path f) (ipc st0)) as (path0 & Hpath0); eauto. - exists (path0.(psize)); intuition eauto. - econstructor; eauto. - * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. - * simpl; eauto. - + generalize Hi; inversion RSTEP; clear RSTEP; subst; (repeat (simplify_someHyp; simpl in * |- * )); try congruence; eauto. - - (* Icall *) - intros; exploit find_RTL_function_match; eauto. - intros (fd' & MATCHfd & Hfd'); subst. - exploit (exec_Icall ge pge); eauto. - eexists; intuition eauto. - eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. - rewrite wf_stackframe_cons; intuition simpl; eauto. - - (* Itailcall *) - intros; exploit find_RTL_function_match; eauto. - intros (fd' & MATCHfd & Hfd'); subst. - exploit (exec_Itailcall ge pge); eauto. - eexists; intuition eauto. - eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. - - (* Ibuiltin *) - intros; exploit exec_Ibuiltin; eauto. - eexists; intuition eauto. - unfold match_states, match_inst_states; simpl. - destruct (initialize_path (*fn_code f*) (fn_path f) pc') as (path0 & Hpath0); eauto. - exists path0.(psize); intuition eauto. - econstructor; eauto. - * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. - * simpl; eauto. - - (* Ijumptable *) - intros; exploit exec_Ijumptable; eauto. - eexists; intuition eauto. - unfold match_states, match_inst_states; simpl. - destruct (initialize_path (*fn_code f*) (fn_path f) pc') as (path0 & Hpath0); eauto. - exists path0.(psize); intuition eauto. - econstructor; eauto. - * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. - * simpl; eauto. - - (* Ireturn *) - intros; exploit exec_Ireturn; eauto. - eexists; intuition eauto. - eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. -Qed. - -Lemma path_step_complete stack f sp rs m pc t s1' idx path st: - isteps ge (path.(psize)-idx) f sp rs m pc = Some st -> - (fn_path f)!pc = Some path -> - (idx <= path.(psize))%nat -> - RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> - wf_stackframe stack -> - exists idx' s2', - (path_step ge pge path.(psize) stack f sp rs m pc t s2' - \/ (t = E0 /\ s2'=(State stack f sp pc rs m) /\ (idx' < idx)%nat) - \/ (exists path', path_step ge pge path.(psize) stack f sp rs m pc E0 (State stack f sp st.(ipc) st.(irs) st.(imem)) - /\ (fn_path f)!(ipc st) = Some path' /\ path'.(psize) = O - /\ path_step ge pge path'.(psize) stack f sp st.(irs) st.(imem) st.(ipc) t s2') - ) - /\ match_states idx' s1' s2'. -Proof. - Local Hint Resolve exec_early_exit exec_normal_exit: core. - intros PSTEP PATH BOUND RSTEP WF; destruct (st.(icontinue)) eqn: CONT. - destruct idx as [ | idx]. - + (* path_step on normal_exit *) - assert (path.(psize)-0=path.(psize))%nat as HH by omega. rewrite HH in PSTEP. clear HH. - exploit normal_exit; eauto. - intros (s2' & LSTEP & (idx' & MATCH)). - exists idx'; exists s2'; intuition eauto. - + (* stuttering step *) - exploit stuttering; eauto. - unfold match_states; exists idx; exists (State stack f sp pc rs m); - intuition. - + (* one or two path_step on early_exit *) - exploit (isteps_resize ge (path.(psize) - idx)%nat path.(psize)); eauto; try omega. - clear PSTEP; intros PSTEP. - (* TODO for clarification: move the assert below into a separate lemma *) - assert (HPATH0: exists path0, (fn_path f)!(ipc st) = Some path0). - { clear RSTEP. - exploit isteps_inversion_early; eauto. - intros (st0 & i & path0 & BOUND0 & PSTEP0 & CONT0 & PC0 & STEP0). - exploit istep_early_exit; eauto. - intros (X1 & X2 & EARLY_EXIT). - destruct st as [cont pc0 rs0 m0]; simpl in * |- *; intuition subst. - exploit (internal_node_path path0); omega || eauto. - intros (i' & pc' & Hi' & Hpc' & ENTRY). - unfold nth_default_succ_inst in Hi'. - erewrite isteps_normal_exit in Hi'; eauto. - clear pc' Hpc' STEP0 PSTEP0 BOUND0; try_simplify_someHyps; intros. - destruct EARLY_EXIT as [cond args ifnot]; simpl in ENTRY; - destruct (initialize_path (*fn_code f*) (fn_path f) pc0); eauto. - } - destruct HPATH0 as (path1 & Hpath1). - destruct (path1.(psize)) as [|ps] eqn:Hpath1size. - * (* two step case *) - exploit (normal_exit path1); try rewrite Hpath1size; simpl; eauto. - simpl; intros (s2' & LSTEP & (idx' & MATCH)). - exists idx'. exists s2'. constructor; auto. - right. right. eexists; intuition eauto. - (* now, prove the last step *) - rewrite Hpath1size; exploit exec_normal_exit. 4:{ eauto. } - - simpl; eauto. - - simpl; eauto. - - simpl; eauto. - * (* single step case *) - exploit (stuttering path1 ps stack f sp (irs st) (imem st) (ipc st)); simpl; auto. - - { rewrite Hpath1size; enough (S ps-S ps=0)%nat as ->; try omega. simpl; eauto. } - - omega. - - simpl; eauto. - - simpl; eauto. - - intuition subst. - repeat eexists; intuition eauto. -Qed. - -Lemma step_noninst_complete s1 t s1' s2: - is_inst s1 = false -> - s1 = state_RTL s2 -> - RTL.step ge s1 t s1' -> - wf_stackframe (stack_of s2) -> - exists s2', step ge pge s2 t s2' /\ exists idx, match_states idx s1' s2'. -Proof. - intros H0 H1 H2 WFSTACK; destruct s2; subst; simpl in * |- *; try congruence; - inversion H2; clear H2; subst; try_simplify_someHyps; try congruence. - + (* exec_function_internal *) - destruct f; simpl in H3; inversion H3; subst; clear H3. - eexists; constructor 1. - * eapply exec_function_internal; eauto. - * unfold match_states, match_inst_states; simpl. - destruct (initialize_path (*fn_code f*) (fn_path f) (fn_entrypoint (fn_RTL f))) as (path & Hpath); eauto. - exists path.(psize). constructor; auto. - econstructor; eauto. - - set (ps:=path.(psize)). enough (ps-ps=O)%nat as ->; simpl; eauto. - omega. - - simpl; auto. - + (* exec_function_external *) - destruct f; simpl in H3 |-; inversion H3; subst; clear H3. - eexists; constructor 1. - * apply exec_function_external; eauto. - * unfold match_states, match_inst_states; simpl. exists O; auto. - + (* exec_return *) - destruct stack eqn: Hstack; simpl in H1; inversion H1; clear H1; subst. - destruct s0 eqn: Hs0; simpl in H0; inversion H0; clear H0; subst. - eexists; constructor 1. - * apply exec_return. - * unfold match_states, match_inst_states; simpl. - rewrite wf_stackframe_cons in WFSTACK. - destruct WFSTACK as (H0 & H1); simpl in H0. - destruct (initialize_path (*fn_code f0*) (fn_path f0) pc0) as (path & Hpath); eauto. - exists path.(psize). constructor; auto. - econstructor; eauto. - - set (ps:=path.(psize)). enough (ps-ps=O)%nat as ->; simpl; eauto. - omega. - - simpl; auto. -Qed. - -(** *** The main completeness lemma and the simulation theorem...*) -Lemma step_complete s1 t s1' idx s2: - match_states idx s1 s2 -> - RTL.step ge s1 t s1' -> - exists idx' s2', (plus (step ge) pge s2 t s2' \/ (t = E0 /\ s2=s2' /\ (idx' < idx)%nat)) /\ match_states idx' s1' s2'. -Proof. - Local Hint Resolve plus_one plus_two exec_path: core. - unfold match_states at 1, match_inst_states. intros (IS_INST & WFSTACK). destruct (is_inst s1) eqn: His1. - - clear His1; destruct IS_INST as [path stack f sp pc rs m s2 X X0 X1 X2]; auto; subst; simpl in * |- *. - intros STEP; exploit path_step_complete; eauto. - intros (idx' & s2' & H0 & H1). - eexists; eexists; eauto. - destruct H0 as [H0|[H0|(path'&H0)]]; intuition subst; eauto. - - intros; exploit step_noninst_complete; eauto. - intros (s2' & STEP & (idx0 & MATCH)). - exists idx0; exists s2'; intuition auto. -Qed. - -Theorem RTLpath_complete: forward_simulation (RTL.semantics p) (semantics p). -Proof. - eapply (Forward_simulation (L1:=RTL.semantics p) (L2:=semantics p) lt match_states). - constructor 1; simpl. - - apply lt_wf. - - unfold match_states, match_inst_states. destruct 1; simpl; exists O. - destruct (find_funct_ptr_RTL_preserv b f) as (f0 & X1 & X2); subst; eauto. - exists (Callstate nil f0 nil m0). simpl; split; try econstructor; eauto. - + apply (Genv.init_mem_match (match_RTL_prog p)); auto. - + rewrite (Genv.find_symbol_match (match_RTL_prog p)). - rewrite (match_program_main (match_RTL_prog p)); eauto. - - unfold final_state, match_states, match_inst_states. intros i s1 s2 r (H0 & H1) H2; destruct H2. - destruct s2; simpl in * |- *; inversion H0; subst. - constructor. - - Local Hint Resolve star_refl: core. - intros; exploit step_complete; eauto. - destruct 1 as (idx' & s2' & X). - exists idx'. exists s2'. intuition (subst; eauto). - - intros id; destruct (senv_preserved p); simpl in * |-. intuition. -Qed. - -End COMPLETENESS. diff --git a/kvx/lib/RTLpathLivegen.v b/kvx/lib/RTLpathLivegen.v deleted file mode 100644 index 1f0ebe3c..00000000 --- a/kvx/lib/RTLpathLivegen.v +++ /dev/null @@ -1,290 +0,0 @@ -(** Building a RTLpath program with liveness annotation. -*) - - -Require Import Coqlib. -Require Import Maps. -Require Import Lattice. -Require Import AST. -Require Import Op. -Require Import Registers. -Require Import Globalenvs Smallstep RTL RTLpath. -Require Import Bool Errors. -Require Import Program. - -Local Open Scope lazy_bool_scope. - -Local Open Scope option_monad_scope. - -Axiom build_path_map: RTL.function -> path_map. - -Extract Constant build_path_map => "RTLpathLivegenaux.build_path_map". - -Fixpoint list_mem (rl: list reg) (alive: Regset.t) {struct rl}: bool := - match rl with - | nil => true - | r1 :: rs => Regset.mem r1 alive &&& list_mem rs alive - end. - -Definition exit_checker {A} (pm: path_map) (alive: Regset.t) (pc: node) (v:A): option A := - SOME path <- pm!pc IN - ASSERT Regset.subset path.(input_regs) alive IN - Some v. - -Lemma exit_checker_path_entry A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res: - exit_checker pm alive pc v = Some res -> path_entry pm pc. -Proof. - unfold exit_checker, path_entry. - inversion_SOME path; simpl; congruence. -Qed. - -Lemma exit_checker_res A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res: - exit_checker pm alive pc v = Some res -> v=res. -Proof. - unfold exit_checker, path_entry. - inversion_SOME path; try_simplify_someHyps. - inversion_ASSERT; try_simplify_someHyps. -Qed. - -(* FIXME - what about trap? *) -Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option (Regset.t * node) := - match i with - | Inop pc' => Some (alive, pc') - | Iop op args dst pc' => - ASSERT list_mem args alive IN - Some (Regset.add dst alive, pc') - | Iload _ chunk addr args dst pc' => - ASSERT list_mem args alive IN - Some (Regset.add dst alive, pc') - | Istore chunk addr args src pc' => - ASSERT Regset.mem src alive IN - ASSERT list_mem args alive IN - Some (alive, pc') - | Icond cond args ifso ifnot _ => - ASSERT list_mem args alive IN - exit_checker pm alive ifso (alive, ifnot) - | _ => None (* TODO jumptable ? *) - end. - - -Local Hint Resolve exit_checker_path_entry: core. - -Lemma iinst_checker_path_entry (pm: path_map) (alive: Regset.t) (i: instruction) res pc: - iinst_checker pm alive i = Some res -> - early_exit i = Some pc -> path_entry pm pc. -Proof. - destruct i; simpl; try_simplify_someHyps; subst. - inversion_ASSERT; try_simplify_someHyps. -Qed. - -Lemma iinst_checker_default_succ (pm: path_map) (alive: Regset.t) (i: instruction) res pc: - iinst_checker pm alive i = Some res -> - pc = snd res -> - default_succ i = Some pc. -Proof. - destruct i; simpl; try_simplify_someHyps; subst; - repeat (inversion_ASSERT); try_simplify_someHyps. - intros; exploit exit_checker_res; eauto. - intros; subst. simpl; auto. -Qed. - -Fixpoint ipath_checker (ps:nat) (f: RTL.function) (pm: path_map) (alive: Regset.t) (pc:node): option (Regset.t * node) := - match ps with - | O => Some (alive, pc) - | S p => - SOME i <- f.(fn_code)!pc IN - SOME res <- iinst_checker pm alive i IN - ipath_checker p f pm (fst res) (snd res) - end. - -Lemma ipath_checker_wellformed f pm ps: forall alive pc res, - ipath_checker ps f pm alive pc = Some res -> - wellformed_path f.(fn_code) pm 0 (snd res) -> - wellformed_path f.(fn_code) pm ps pc. -Proof. - induction ps; simpl; try_simplify_someHyps. - inversion_SOME i; inversion_SOME res'. - intros. eapply wf_internal_node; eauto. - * eapply iinst_checker_default_succ; eauto. - * intros; eapply iinst_checker_path_entry; eauto. -Qed. - -Definition reg_option_mem (or: option reg) (alive: Regset.t) := - match or with None => true | Some r => Regset.mem r alive end. - -Definition reg_sum_mem (ros: reg + ident) (alive: Regset.t) := - match ros with inl r => Regset.mem r alive | inr s => true end. - -(* NB: definition following [regmap_setres] in [RTL.step] semantics *) -Definition reg_builtin_res (res: builtin_res reg) (alive: Regset.t): Regset.t := - match res with - | BR r => Regset.add r alive - | _ => alive - end. - -Fixpoint exit_list_checker (pm: path_map) (alive: Regset.t) (l: list node): bool := - match l with - | nil => true - | pc::l' => exit_checker pm alive pc tt &&& exit_list_checker pm alive l' - end. - -Lemma lazy_and_Some_true A (o: option A) (b: bool): o &&& b = true <-> (exists v, o = Some v) /\ b = true. -Proof. - destruct o; simpl; intuition. - - eauto. - - firstorder. try_simplify_someHyps. -Qed. - -Lemma lazy_and_Some_tt_true (o: option unit) (b: bool): o &&& b = true <-> o = Some tt /\ b = true. -Proof. - intros; rewrite lazy_and_Some_true; firstorder. - destruct x; auto. -Qed. - - -Lemma exit_list_checker_correct pm alive l pc: - exit_list_checker pm alive l = true -> List.In pc l -> exit_checker pm alive pc tt = Some tt. -Proof. - intros EXIT PC; induction l; intuition. - simpl in * |-. rewrite lazy_and_Some_tt_true in EXIT. - firstorder (subst; eauto). -Qed. - -Local Hint Resolve exit_list_checker_correct: core. - -Definition inst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option unit := - match i with - | Icall sig ros args res pc' => - ASSERT list_mem args alive IN - ASSERT reg_sum_mem ros alive IN - exit_checker pm (Regset.add res alive) pc' tt - | Itailcall sig ros args => - ASSERT list_mem args alive IN - ASSERT reg_sum_mem ros alive IN - Some tt - | Ibuiltin ef args res pc' => - ASSERT list_mem (params_of_builtin_args args) alive IN - exit_checker pm (reg_builtin_res res alive) pc' tt - | Ijumptable arg tbl => - ASSERT Regset.mem arg alive IN - ASSERT exit_list_checker pm alive tbl IN - Some tt - | Ireturn optarg => - ASSERT (reg_option_mem optarg) alive IN - Some tt - | _ => - SOME res <- iinst_checker pm alive i IN - exit_checker pm (fst res) (snd res) tt - end. - -Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive: Regset.t) (i: instruction): - inst_checker pm alive i = Some tt -> - c!pc = Some i -> wellformed_path c pm 0 pc. -Proof. - intros CHECK PC. eapply wf_last_node; eauto. - clear c pc PC. intros pc PC. - destruct i; simpl in * |- *; intuition (subst; eauto); - try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). - intros X; exploit exit_checker_res; eauto. - clear X. intros; subst; eauto. -Qed. - -Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := - SOME res <- ipath_checker (path.(psize)) f pm (path.(input_regs)) pc IN - SOME i <- f.(fn_code)!(snd res) IN - inst_checker pm (fst res) i. - -Lemma path_checker_wellformed f pm pc path: - path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. -Proof. - unfold path_checker. - inversion_SOME res. - inversion_SOME i. - intros; eapply ipath_checker_wellformed; eauto. - eapply inst_checker_wellformed; eauto. -Qed. - -Fixpoint list_path_checker f pm (l:list (node*path_info)): bool := - match l with - | nil => true - | (pc, path)::l' => - path_checker f pm pc path &&& list_path_checker f pm l' - end. - -Lemma list_path_checker_correct f pm l: - list_path_checker f pm l = true -> forall e, List.In e l -> path_checker f pm (fst e) (snd e) = Some tt. -Proof. - intros CHECKER e H; induction l as [|(pc & path) l]; intuition. - simpl in * |- *. rewrite lazy_and_Some_tt_true in CHECKER. intuition (subst; auto). -Qed. - -Definition function_checker (f: RTL.function) pm: bool := - pm!(f.(fn_entrypoint)) &&& list_path_checker f pm (PTree.elements pm). - -Lemma function_checker_correct f pm pc path: - function_checker f pm = true -> - pm!pc = Some path -> - path_checker f pm pc path = Some tt. -Proof. - unfold function_checker; rewrite lazy_and_Some_true. - intros (ENTRY & PATH) PC. - exploit list_path_checker_correct; eauto. - - eapply PTree.elements_correct; eauto. - - simpl; auto. -Qed. - -Lemma function_checker_wellformed_path_map f pm: - function_checker f pm = true -> wellformed_path_map f.(fn_code) pm. -Proof. - unfold wellformed_path_map. - intros; eapply path_checker_wellformed; eauto. - intros; eapply function_checker_correct; eauto. -Qed. - -Lemma function_checker_path_entry f pm: - function_checker f pm = true -> path_entry pm (f.(fn_entrypoint)). -Proof. - unfold function_checker; rewrite lazy_and_Some_true; - unfold path_entry. firstorder congruence. -Qed. - -Definition liveness_ok_function (f: function): Prop := - forall pc path, f.(fn_path)!pc = Some path -> path_checker f f.(fn_path) pc path = Some tt. - -Program Definition transf_function (f: RTL.function): { r: res function | forall f', r = OK f' -> liveness_ok_function f' /\ f'.(fn_RTL) = f } := - let pm := build_path_map f in - match function_checker f pm with - | true => OK {| fn_RTL := f; fn_path := pm |} - | false => Error(msg "RTLpathGen: function_checker failed") - end. -Obligation 1. - apply function_checker_path_entry; auto. -Qed. -Obligation 2. - apply function_checker_wellformed_path_map; auto. -Qed. -Obligation 3. - unfold liveness_ok_function; simpl; intros; intuition. - apply function_checker_correct; auto. -Qed. - -Definition transf_fundef (f: RTL.fundef) : res fundef := - transf_partial_fundef (fun f => ` (transf_function f)) f. - -Inductive liveness_ok_fundef: fundef -> Prop := - | liveness_ok_Internal f: liveness_ok_function f -> liveness_ok_fundef (Internal f) - | liveness_ok_External ef: liveness_ok_fundef (External ef). - -Lemma transf_fundef_correct f f': - transf_fundef f = OK f' -> (liveness_ok_fundef f') /\ fundef_RTL f' = f. -Proof. - intros TRANSF; destruct f; simpl; monadInv TRANSF. - - destruct (transf_function f) as [res H]; simpl in * |- *; auto. - destruct (H _ EQ). - intuition subst; auto. apply liveness_ok_Internal; auto. - - intuition. apply liveness_ok_External; auto. -Qed. - -Definition transf_program (p: RTL.program) : res program := - transform_partial_program transf_fundef p. - diff --git a/kvx/lib/RTLpathLivegenaux.ml b/kvx/lib/RTLpathLivegenaux.ml deleted file mode 100644 index dd971db8..00000000 --- a/kvx/lib/RTLpathLivegenaux.ml +++ /dev/null @@ -1,309 +0,0 @@ -open RTL -open RTLpath -open Registers -open Maps -open Camlcoq -open Datatypes -open Kildall -open Lattice - -let debug_flag = ref false - -let dprintf fmt = let open Printf in - match !debug_flag with - | true -> printf fmt - | false -> ifprintf stdout fmt - -let get_some = function -| None -> failwith "Got None instead of Some _" -| Some thing -> thing - -let successors_inst = function -| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> [n] -| Icond (_,_,n1,n2,_) -> [n1; n2] -| Ijumptable (_,l) -> l -| Itailcall _ | Ireturn _ -> [] - -let predicted_successor = function -| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> Some n -| Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> None -| Icond (_,_,n1,n2,p) -> ( - match p with - | Some true -> Some n1 - | Some false -> Some n2 - | None -> None ) -| Ijumptable _ | Itailcall _ | Ireturn _ -> None - -let non_predicted_successors i = - match predicted_successor i with - | None -> successors_inst i - | Some n -> List.filter (fun n' -> n != n') (successors_inst i) - -let rec list_to_regset = function - | [] -> Regset.empty - | r::l -> Regset.add r (list_to_regset l) - -let get_input_regs i = - let empty = Regset.empty in - match i with - | Inop _ -> empty - | Iop (_,lr,_,_) | Iload (_,_,_,lr,_,_) | Icond (_,lr,_,_,_) -> list_to_regset lr - | Istore (_,_,lr,r,_) -> Regset.add r (list_to_regset lr) - | Icall (_, ri, lr, _, _) | Itailcall (_, ri, lr) -> begin - let rs = list_to_regset lr in - match ri with - | Coq_inr _ -> rs - | Coq_inl r -> Regset.add r rs - end - | Ibuiltin (_, lbr, _, _) -> list_to_regset @@ AST.params_of_builtin_args lbr - | Ijumptable (r, _) -> Regset.add r empty - | Ireturn opr -> (match opr with Some r -> Regset.add r empty | None -> empty) - -let get_output_reg i = - match i with - | Inop _ | Istore _ | Icond _ | Itailcall _ | Ijumptable _ | Ireturn _ -> None - | Iop (_, _, r, _) | Iload (_, _, _, _, r, _) | Icall (_, _, _, r, _) -> Some r - | Ibuiltin (_, _, brr, _) -> (match brr with AST.BR r -> Some r | _ -> None) - -(* adapted from Linearizeaux.get_join_points *) -let get_join_points code entry = - let reached = ref (PTree.map (fun n i -> false) code) in - let reached_twice = ref (PTree.map (fun n i -> false) code) in - let rec traverse pc = - if get_some @@ PTree.get pc !reached then begin - if not (get_some @@ PTree.get pc !reached_twice) then - reached_twice := PTree.set pc true !reached_twice - end else begin - reached := PTree.set pc true !reached; - traverse_succs (successors_inst @@ get_some @@ PTree.get pc code) - end - and traverse_succs = function - | [] -> () - | [pc] -> traverse pc - | pc :: l -> traverse pc; traverse_succs l - in traverse entry; !reached_twice - -(* Does not set the input_regs and liveouts field *) -let get_path_map code entry join_points = - let visited = ref (PTree.map (fun n i -> false) code) in - let path_map = ref PTree.empty in - let rec dig_path e = - let psize = ref (-1) in - let path_successors = ref [] in - let rec dig_path_rec n : (path_info * node list) option = - if not (get_some @@ PTree.get n !visited) then - let inst = get_some @@ PTree.get n code in - begin - visited := PTree.set n true !visited; - psize := !psize + 1; - let successor = match predicted_successor inst with - | None -> None - | Some n' -> if get_some @@ PTree.get n' join_points then None else Some n' - in match successor with - | Some n' -> begin - path_successors := !path_successors @ non_predicted_successors inst; - dig_path_rec n' - end - | None -> Some ({ psize = (Camlcoq.Nat.of_int !psize); - input_regs = Regset.empty; output_regs = Regset.empty }, - !path_successors @ successors_inst inst) - end - else None - in match dig_path_rec e with - | None -> () - | Some ret -> - let (path_info, succs) = ret in - begin - path_map := PTree.set e path_info !path_map; - List.iter dig_path succs - end - in begin - dig_path entry; - !path_map - end - -let print_regset rs = begin - dprintf "["; - List.iter (fun n -> dprintf "%d " (P.to_int n)) (Regset.elements rs); - dprintf "]" -end - -let print_ptree_regset pt = begin - dprintf "["; - List.iter (fun (n, rs) -> - dprintf "\n\t"; - dprintf "%d: " (P.to_int n); - print_regset rs - ) (PTree.elements pt); - dprintf "]" -end - -let transfer f pc after = let open Liveness in - match PTree.get pc f.fn_code with - | Some i -> - (match i with - | Inop _ -> after - | Iop (_, args, res, _) -> - reg_list_live args (Regset.remove res after) - | Iload (_, _, _, args, dst, _) -> - reg_list_live args (Regset.remove dst after) - | Istore (_, _, args, src, _) -> - reg_list_live args (Regset.add src after) - | Icall (_, ros, args, res, _) -> - reg_list_live args (reg_sum_live ros (Regset.remove res after)) - | Itailcall (_, ros, args) -> - reg_list_live args (reg_sum_live ros Regset.empty) - | Ibuiltin (_, args, res, _) -> - reg_list_live (AST.params_of_builtin_args args) - (reg_list_dead (AST.params_of_builtin_res res) after) - | Icond (_, args, _, _, _) -> - reg_list_live args after - | Ijumptable (arg, _) -> - Regset.add arg after - | Ireturn optarg -> - reg_option_live optarg Regset.empty) - | None -> Regset.empty - -module RegsetLat = LFSet(Regset) - -module DS = Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward) - -let analyze f = - let liveouts = get_some @@ DS.fixpoint f.fn_code successors_instr (transfer f) in - PTree.map (fun n _ -> let lo = PMap.get n liveouts in transfer f n lo) f.fn_code - -(** OLD CODE - If needed to have our own kildall - -let transfer after = let open Liveness in function - | Inop _ -> after - | Iop (_, args, res, _) -> - reg_list_live args (Regset.remove res after) - | Iload (_, _, _, args, dst, _) -> - reg_list_live args (Regset.remove dst after) - | Istore (_, _, args, src, _) -> - reg_list_live args (Regset.add src after) - | Icall (_, ros, args, res, _) -> - reg_list_live args (reg_sum_live ros (Regset.remove res after)) - | Itailcall (_, ros, args) -> - reg_list_live args (reg_sum_live ros Regset.empty) - | Ibuiltin (_, args, res, _) -> - reg_list_live (AST.params_of_builtin_args args) - (reg_list_dead (AST.params_of_builtin_res res) after) - | Icond (_, args, _, _, _) -> - reg_list_live args after - | Ijumptable (arg, _) -> - Regset.add arg after - | Ireturn optarg -> - reg_option_live optarg Regset.empty - -let get_last_nodes f = - let visited = ref (PTree.map (fun n i -> false) f.fn_code) in - let rec step n = - let inst = get_some @@ PTree.get n f.fn_code in - let successors = successors_inst inst in - if get_some @@ PTree.get n !visited then [] - else begin - -let analyze f = - let liveness = ref (PTree.map (fun n i -> None) f.fn_code) in - let predecessors = Duplicateaux.get_predecessors_rtl f.fn_code in - let last_nodes = get_last_nodes f in - let rec step liveout n = (* liveout is the input_regs from the successor *) - let inst = get_some @@ PTree.get n f.fn_code in - let continue = ref true in - let alive = match get_some @@ PTree.get n !liveness with - | None -> transfer liveout inst - | Some pre_alive -> begin - let union = Regset.union pre_alive liveout in - let new_alive = transfer union inst in - (if Regset.equal pre_alive new_alive then continue := false); - new_alive - end - in begin - liveness := PTree.set n (Some alive) !liveness; - if !continue then - let preds = get_some @@ PTree.get n predecessors in - List.iter (step alive) preds - end - in begin - List.iter (step Regset.empty) last_nodes; - let liveness_noopt = PTree.map (fun n i -> get_some i) !liveness in - begin - debug_flag := true; - dprintf "Liveness: "; print_ptree_regset liveness_noopt; dprintf "\n"; - debug_flag := false; - liveness_noopt - end - end -*) - -let rec traverse code n size = - let inst = get_some @@ PTree.get n code in - if (size == 0) then inst - else - let n' = get_some @@ predicted_successor inst in - traverse code n' (size-1) - -let get_outputs liveness code n pi = - let last_instruction = traverse code n (Camlcoq.Nat.to_int pi.psize) in - let path_last_successors = successors_inst last_instruction in - let list_input_regs = List.map ( - fun n -> get_some @@ PTree.get n liveness - ) path_last_successors in - List.fold_left Regset.union Regset.empty list_input_regs - -let set_pathmap_liveness f pm = - let liveness = analyze f in - let new_pm = ref PTree.empty in - let code = f.fn_code in - begin - dprintf "Liveness: "; print_ptree_regset liveness; dprintf "\n"; - List.iter (fun (n, pi) -> - let inputs = get_some @@ PTree.get n liveness in - let outputs = get_outputs liveness code n pi in - new_pm := PTree.set n - {psize=pi.psize; input_regs=inputs; output_regs=outputs} !new_pm - ) (PTree.elements pm); - !new_pm - end - -let print_true_nodes booltree = begin - dprintf "["; - List.iter (fun (n,b) -> - if b then dprintf "%d " (P.to_int n) - ) (PTree.elements booltree); - dprintf "]"; -end - -let print_path_info pi = begin - dprintf "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); - dprintf "input_regs="; - print_regset pi.input_regs; - dprintf "; output_regs="; - print_regset pi.output_regs; - dprintf ")" -end - -let print_path_map path_map = begin - dprintf "["; - List.iter (fun (n,pi) -> - dprintf "\n\t"; - dprintf "%d: " (P.to_int n); - print_path_info pi - ) (PTree.elements path_map); - dprintf "]" -end - -let build_path_map f = - let code = f.fn_code in - let entry = f.fn_entrypoint in - let join_points = get_join_points code entry in - let path_map = set_pathmap_liveness f @@ get_path_map code entry join_points in - begin - dprintf "Join points: "; - print_true_nodes join_points; - dprintf "\nPath map: "; - print_path_map path_map; - dprintf "\n"; - path_map - end diff --git a/kvx/lib/RTLpathLivegenproof.v b/kvx/lib/RTLpathLivegenproof.v deleted file mode 100644 index 0ba5ed44..00000000 --- a/kvx/lib/RTLpathLivegenproof.v +++ /dev/null @@ -1,736 +0,0 @@ -(** Proofs of the liveness properties from the liveness checker of RTLpathLivengen. -*) - - -Require Import Coqlib. -Require Import Maps. -Require Import Lattice. -Require Import AST. -Require Import Op. -Require Import Registers. -Require Import Globalenvs Smallstep RTL RTLpath RTLpathLivegen. -Require Import Bool Errors Linking Values Events. -Require Import Program. - -Definition match_prog (p: RTL.program) (tp: program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. -Proof. - intros. eapply match_transform_partial_program_contextual; eauto. -Qed. - -Section PRESERVATION. - -Variables prog: RTL.program. -Variables tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tpge := Genv.globalenv tprog. -Let tge := Genv.globalenv (RTLpath.transf_program tprog). - -Lemma symbols_preserved s: Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - rewrite <- (Genv.find_symbol_match TRANSL). - apply (Genv.find_symbol_match (match_prog_RTL tprog)). -Qed. - -Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. -Proof. - unfold Senv.equiv. intuition congruence. -Qed. - -Lemma senv_preserved: Senv.equiv ge tge. -Proof. - eapply senv_transitivity. { eapply (Genv.senv_match TRANSL). } - eapply RTLpath.senv_preserved. -Qed. - -Lemma function_ptr_preserved v f: Genv.find_funct_ptr ge v = Some f -> - exists tf, Genv.find_funct_ptr tpge v = Some tf /\ transf_fundef f = OK tf. -Proof. - intros; apply (Genv.find_funct_ptr_transf_partial TRANSL); eauto. -Qed. - - -Lemma function_ptr_RTL_preserved v f: Genv.find_funct_ptr ge v = Some f -> Genv.find_funct_ptr tge v = Some f. -Proof. - intros; exploit function_ptr_preserved; eauto. - intros (tf & Htf & TRANS). - exploit (Genv.find_funct_ptr_match (match_prog_RTL tprog)); eauto. - intros (cunit & tf0 & X & Y & DUM); subst. - unfold tge. rewrite X. - exploit transf_fundef_correct; eauto. - intuition subst; auto. -Qed. - -Lemma find_function_preserved ros rs fd: - RTL.find_function ge ros rs = Some fd -> RTL.find_function tge ros rs = Some fd. -Proof. - intros H; assert (X: exists tfd, find_function tpge ros rs = Some tfd /\ fd = fundef_RTL tfd). - * destruct ros; simpl in * |- *. - + intros; exploit (Genv.find_funct_match TRANSL); eauto. - intros (cuint & tf & H1 & H2 & H3); subst; repeat econstructor; eauto. - exploit transf_fundef_correct; eauto. - intuition auto. - + rewrite <- (Genv.find_symbol_match TRANSL) in H. - unfold tpge. destruct (Genv.find_symbol _ i); simpl; try congruence. - exploit function_ptr_preserved; eauto. - intros (tf & H1 & H2); subst; repeat econstructor; eauto. - exploit transf_fundef_correct; eauto. - intuition auto. - * destruct X as (tf & X1 & X2); subst. - eapply find_function_RTL_match; eauto. -Qed. - - -Local Hint Resolve symbols_preserved senv_preserved: core. - -Lemma transf_program_RTL_correct: - forward_simulation (RTL.semantics prog) (RTL.semantics (RTLpath.transf_program tprog)). -Proof. - eapply forward_simulation_step with (match_states:=fun (s1 s2:RTL.state) => s1=s2); simpl; eauto. - - eapply senv_preserved. - - (* initial states *) - intros s1 INIT. destruct INIT as [b f m0 ge0 INIT SYMB PTR SIG]. eexists; intuition eauto. - econstructor; eauto. - + intros; eapply (Genv.init_mem_match (match_prog_RTL tprog)). apply (Genv.init_mem_match TRANSL); auto. - + rewrite symbols_preserved. - replace (prog_main (RTLpath.transf_program tprog)) with (prog_main prog). - * eapply SYMB. - * erewrite (match_program_main (match_prog_RTL tprog)). erewrite (match_program_main TRANSL); auto. - + exploit function_ptr_RTL_preserved; eauto. - - intros; subst; auto. - - intros s t s2 STEP s1 H; subst. - eexists; intuition. - destruct STEP. - + (* Inop *) eapply exec_Inop; eauto. - + (* Iop *) eapply exec_Iop; eauto. - erewrite eval_operation_preserved; eauto. - + (* Iload *) eapply exec_Iload; eauto. - erewrite eval_addressing_preserved; eauto. - + (* Iload notrap1 *) eapply exec_Iload_notrap1; eauto. - erewrite eval_addressing_preserved; eauto. - + (* Iload notrap2 *) eapply exec_Iload_notrap2; eauto. - erewrite eval_addressing_preserved; eauto. - + (* Istore *) eapply exec_Istore; eauto. - erewrite eval_addressing_preserved; eauto. - + (* Icall *) - eapply RTL.exec_Icall; eauto. - eapply find_function_preserved; eauto. - + (* Itailcall *) - eapply RTL.exec_Itailcall; eauto. - eapply find_function_preserved; eauto. - + (* Ibuiltin *) - eapply RTL.exec_Ibuiltin; eauto. - * eapply eval_builtin_args_preserved; eauto. - * eapply external_call_symbols_preserved; eauto. - + (* Icond *) - eapply exec_Icond; eauto. - + (* Ijumptable *) - eapply RTL.exec_Ijumptable; eauto. - + (* Ireturn *) - eapply RTL.exec_Ireturn; eauto. - + (* exec_function_internal *) - eapply RTL.exec_function_internal; eauto. - + (* exec_function_external *) - eapply RTL.exec_function_external; eauto. - eapply external_call_symbols_preserved; eauto. - + (* exec_return *) - eapply RTL.exec_return; eauto. -Qed. - -Theorem transf_program_correct: - forward_simulation (RTL.semantics prog) (RTLpath.semantics tprog). -Proof. - eapply compose_forward_simulations. - + eapply transf_program_RTL_correct. - + eapply RTLpath_complete. -Qed. - - -(* Properties used in hypothesis of [RTLpathLiveproofs.step_eqlive] theorem *) -Theorem all_fundef_liveness_ok b f: - Genv.find_funct_ptr tpge b = Some f -> liveness_ok_fundef f. -Proof. - unfold match_prog, match_program in TRANSL. - unfold Genv.find_funct_ptr, tpge; simpl; intro X. - destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. - destruct y as [tf0|]; try congruence. - inversion X as [H1]. subst. clear X. - remember (@Gfun fundef unit f) as f2. - destruct H as [ctx' f1 f2 H0|]; try congruence. - inversion Heqf2 as [H2]. subst; clear Heqf2. - exploit transf_fundef_correct; eauto. - intuition. -Qed. - -End PRESERVATION. - -Local Open Scope lazy_bool_scope. -Local Open Scope option_monad_scope. - -Local Notation ext alive := (fun r => Regset.In r alive). - -Lemma regset_add_spec live r1 r2: Regset.In r1 (Regset.add r2 live) <-> (r1 = r2 \/ Regset.In r1 live). -Proof. - destruct (Pos.eq_dec r1 r2). - - subst. intuition; eapply Regset.add_1; auto. - - intuition. - * right. eapply Regset.add_3; eauto. - * eapply Regset.add_2; auto. -Qed. - -Definition eqlive_reg (alive: Regset.elt -> Prop) (rs1 rs2: regset): Prop := - forall r, (alive r) -> rs1#r = rs2#r. - -Lemma eqlive_reg_refl alive rs: eqlive_reg alive rs rs. -Proof. - unfold eqlive_reg; auto. -Qed. - -Lemma eqlive_reg_symmetry alive rs1 rs2: eqlive_reg alive rs1 rs2 -> eqlive_reg alive rs2 rs1. -Proof. - unfold eqlive_reg; intros; symmetry; auto. -Qed. - -Lemma eqlive_reg_trans alive rs1 rs2 rs3: eqlive_reg alive rs1 rs2 -> eqlive_reg alive rs2 rs3 -> eqlive_reg alive rs1 rs3. -Proof. - unfold eqlive_reg; intros H0 H1 r H. rewrite H0; eauto. -Qed. - -Lemma eqlive_reg_update (alive: Regset.elt -> Prop) rs1 rs2 r v: eqlive_reg (fun r1 => r1 <> r /\ alive r1) rs1 rs2 -> eqlive_reg alive (rs1 # r <- v) (rs2 # r <- v). -Proof. - unfold eqlive_reg; intros EQLIVE r0 ALIVE. - destruct (Pos.eq_dec r r0) as [H|H]. - - subst. rewrite! Regmap.gss. auto. - - rewrite! Regmap.gso; auto. -Qed. - -Lemma eqlive_reg_monotonic (alive1 alive2: Regset.elt -> Prop) rs1 rs2: eqlive_reg alive2 rs1 rs2 -> (forall r, alive1 r -> alive2 r) -> eqlive_reg alive1 rs1 rs2. -Proof. - unfold eqlive_reg; intuition. -Qed. - -Lemma eqlive_reg_triv rs1 rs2: (forall r, rs1#r = rs2#r) <-> eqlive_reg (fun _ => True) rs1 rs2. -Proof. - unfold eqlive_reg; intuition. -Qed. - -Lemma eqlive_reg_triv_trans alive rs1 rs2 rs3: eqlive_reg alive rs1 rs2 -> (forall r, rs2#r = rs3#r) -> eqlive_reg alive rs1 rs3. -Proof. - rewrite eqlive_reg_triv; intros; eapply eqlive_reg_trans; eauto. - eapply eqlive_reg_monotonic; eauto. - simpl; eauto. -Qed. - -Local Hint Resolve Regset.mem_2 Regset.subset_2. - -Lemma lazy_and_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. -Proof. - destruct b1; simpl; intuition. -Qed. - -Lemma list_mem_correct (rl: list reg) (alive: Regset.t): - list_mem rl alive = true -> forall r, List.In r rl -> ext alive r. -Proof. - induction rl; simpl; try rewrite lazy_and_true; intuition subst; auto. -Qed. - -Lemma eqlive_reg_list (alive: Regset.elt -> Prop) args rs1 rs2: eqlive_reg alive rs1 rs2 -> (forall r, List.In r args -> (alive r)) -> rs1##args = rs2##args. -Proof. - induction args; simpl; auto. - intros EQLIVE ALIVE; rewrite IHargs; auto. - unfold eqlive_reg in EQLIVE. - rewrite EQLIVE; auto. -Qed. - -Lemma eqlive_reg_listmem (alive: Regset.t) args rs1 rs2: eqlive_reg (ext alive) rs1 rs2 -> list_mem args alive = true -> rs1##args = rs2##args. -Proof. - intros; eapply eqlive_reg_list; eauto. - intros; eapply list_mem_correct; eauto. -Qed. - -Record eqlive_istate alive (st1 st2: istate): Prop := - { eqlive_continue: icontinue st1 = icontinue st2; - eqlive_ipc: ipc st1 = ipc st2; - eqlive_irs: eqlive_reg alive (irs st1) (irs st2); - eqlive_imem: (imem st1) = (imem st2) }. - -Lemma iinst_checker_eqlive ge sp pm alive i res rs1 rs2 m st1: - eqlive_reg (ext alive) rs1 rs2 -> - iinst_checker pm alive i = Some res -> - istep ge i sp rs1 m = Some st1 -> - exists st2, istep ge i sp rs2 m = Some st2 /\ eqlive_istate (ext (fst res)) st1 st2. -Proof. - intros EQLIVE. - destruct i; simpl; try_simplify_someHyps. - - (* Inop *) - repeat (econstructor; eauto). - - (* Iop *) - inversion_ASSERT; try_simplify_someHyps. - inversion_SOME v. intros EVAL. - erewrite <- eqlive_reg_listmem; eauto. - try_simplify_someHyps. - repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - - (* Iload *) - inversion_ASSERT; try_simplify_someHyps. - destruct t. (* TODO - simplify that proof ? *) - + inversion_SOME a0. intros EVAL. - erewrite <- eqlive_reg_listmem; eauto. - try_simplify_someHyps. - inversion_SOME v; try_simplify_someHyps. - repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto. - destruct (eval_addressing _ _ _ _). - * destruct (Memory.Mem.loadv _ _ _). - ** intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - ** intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - * intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - - (* Istore *) - (repeat inversion_ASSERT); try_simplify_someHyps. - inversion_SOME a0. intros EVAL. - erewrite <- eqlive_reg_listmem; eauto. - rewrite <- (EQLIVE r); auto. - inversion_SOME v; try_simplify_someHyps. - try_simplify_someHyps. - repeat (econstructor; simpl; eauto). - - (* Icond *) - inversion_ASSERT. - inversion_SOME b. intros EVAL. - intros ARGS; erewrite <- eqlive_reg_listmem; eauto. - try_simplify_someHyps. - repeat (econstructor; simpl; eauto). - exploit exit_checker_res; eauto. - intro; subst; simpl. auto. -Qed. - -Lemma iinst_checker_istep_continue ge sp pm alive i res rs m st: - iinst_checker pm alive i = Some res -> - istep ge i sp rs m = Some st -> - icontinue st = true -> - (snd res)=(ipc st). -Proof. - intros; exploit iinst_checker_default_succ; eauto. - erewrite istep_normal_exit; eauto. - congruence. -Qed. - -Lemma exit_checker_eqlive A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res rs1 rs2: - exit_checker pm alive pc v = Some res -> - eqlive_reg (ext alive) rs1 rs2 -> - exists path, pm!pc = Some path /\ eqlive_reg (ext path.(input_regs)) rs1 rs2. -Proof. - unfold exit_checker. - inversion_SOME path. - inversion_ASSERT. try_simplify_someHyps. - repeat (econstructor; eauto). - intros; eapply eqlive_reg_monotonic; eauto. - intros; exploit Regset.subset_2; eauto. -Qed. - -Lemma iinst_checker_eqlive_stopped ge sp pm alive i res rs1 rs2 m st1: - eqlive_reg (ext alive) rs1 rs2 -> - istep ge i sp rs1 m = Some st1 -> - iinst_checker pm alive i = Some res -> - icontinue st1 = false -> - exists path st2, pm!(ipc st1) = Some path /\ istep ge i sp rs2 m = Some st2 /\ eqlive_istate (ext path.(input_regs)) st1 st2. -Proof. - intros EQLIVE. - set (tmp := istep ge i sp rs2). - destruct i; simpl; try_simplify_someHyps; repeat (inversion_ASSERT || inversion_SOME b); try_simplify_someHyps; try congruence. - 1-3: explore_destruct; simpl; try_simplify_someHyps; repeat (inversion_ASSERT || inversion_SOME b); try_simplify_someHyps; try congruence. - (* Icond *) - unfold tmp; clear tmp; simpl. - intros EVAL; erewrite <- eqlive_reg_listmem; eauto. - try_simplify_someHyps. - destruct b eqn:EQb; simpl in * |-; try congruence. - intros; exploit exit_checker_eqlive; eauto. - intros (path & PATH & EQLIVE2). - repeat (econstructor; simpl; eauto). -Qed. - -Lemma ipath_checker_eqlive_normal ge ps (f:function) sp pm: forall alive pc res rs1 rs2 m st1, - eqlive_reg (ext alive) rs1 rs2 -> - ipath_checker ps f pm alive pc = Some res -> - isteps ge ps f sp rs1 m pc = Some st1 -> - icontinue st1 = true -> - exists st2, isteps ge ps f sp rs2 m pc = Some st2 /\ eqlive_istate (ext (fst res)) st1 st2. -Proof. - induction ps as [|ps]; simpl; try_simplify_someHyps. - - repeat (econstructor; simpl; eauto). - - inversion_SOME i; try_simplify_someHyps. - inversion_SOME res0. - inversion_SOME st0. - intros. - exploit iinst_checker_eqlive; eauto. - destruct 1 as (st2 & ISTEP & [CONT PC RS MEM]). - try_simplify_someHyps. - rewrite <- CONT, <- MEM, <- PC. - destruct (icontinue st0) eqn:CONT'. - * intros; exploit iinst_checker_istep_continue; eauto. - rewrite <- PC; intros X; rewrite X in * |-. eauto. - * try_simplify_someHyps. - congruence. -Qed. - -Lemma ipath_checker_isteps_continue ge ps (f:function) sp pm: forall alive pc res rs m st, - ipath_checker ps f pm alive pc = Some res -> - isteps ge ps f sp rs m pc = Some st -> - icontinue st = true -> - (snd res)=(ipc st). -Proof. - induction ps as [|ps]; simpl; try_simplify_someHyps. - inversion_SOME i; try_simplify_someHyps. - inversion_SOME res0. - inversion_SOME st0. - destruct (icontinue st0) eqn:CONT'. - - intros; exploit iinst_checker_istep_continue; eauto. - intros EQ; rewrite EQ in * |-; clear EQ; eauto. - - try_simplify_someHyps; congruence. -Qed. - -Lemma ipath_checker_eqlive_stopped ge ps (f:function) sp pm: forall alive pc res rs1 rs2 m st1, - eqlive_reg (ext alive) rs1 rs2 -> - ipath_checker ps f pm alive pc = Some res -> - isteps ge ps f sp rs1 m pc = Some st1 -> - icontinue st1 = false -> - exists path st2, pm!(ipc st1) = Some path /\ isteps ge ps f sp rs2 m pc = Some st2 /\ eqlive_istate (ext path.(input_regs)) st1 st2. -Proof. - induction ps as [|ps]; simpl; try_simplify_someHyps; try congruence. - inversion_SOME i; try_simplify_someHyps. - inversion_SOME res0. - inversion_SOME st0. - intros. - destruct (icontinue st0) eqn:CONT'; try_simplify_someHyps; intros. - * intros; exploit iinst_checker_eqlive; eauto. - destruct 1 as (st2 & ISTEP & [CONT PC RS MEM]). - exploit iinst_checker_istep_continue; eauto. - intros PC'. - try_simplify_someHyps. - rewrite PC', <- CONT, <- MEM, <- PC, CONT'. - eauto. - * intros; exploit iinst_checker_eqlive_stopped; eauto. - intros EQLIVE; generalize EQLIVE; destruct 1 as (path & st2 & PATH & ISTEP & [CONT PC RS MEM]). - try_simplify_someHyps. - rewrite <- CONT, <- MEM, <- PC, CONT'. - try_simplify_someHyps. -Qed. - -Inductive eqlive_stackframes: stackframe -> stackframe -> Prop := - | eqlive_stackframes_intro path res f sp pc rs1 rs2 - (LIVE: liveness_ok_function f) - (PATH: f.(fn_path)!pc = Some path) - (EQUIV: forall v, eqlive_reg (ext path.(input_regs)) (rs1 # res <- v) (rs2 # res <- v)): - eqlive_stackframes (Stackframe res f sp pc rs1) (Stackframe res f sp pc rs2). - -Inductive eqlive_states: state -> state -> Prop := - | eqlive_states_intro - path st1 st2 f sp pc rs1 rs2 m - (STACKS: list_forall2 eqlive_stackframes st1 st2) - (LIVE: liveness_ok_function f) - (PATH: f.(fn_path)!pc = Some path) - (EQUIV: eqlive_reg (ext path.(input_regs)) rs1 rs2): - eqlive_states (State st1 f sp pc rs1 m) (State st2 f sp pc rs2 m) - | eqlive_states_call st1 st2 f args m - (LIVE: liveness_ok_fundef f) - (STACKS: list_forall2 eqlive_stackframes st1 st2): - eqlive_states (Callstate st1 f args m) (Callstate st2 f args m) - | eqlive_states_return st1 st2 v m - (STACKS: list_forall2 eqlive_stackframes st1 st2): - eqlive_states (Returnstate st1 v m) (Returnstate st2 v m). - - -Section LivenessProperties. - -Variable prog: program. - -Let pge := Genv.globalenv prog. -Let ge := Genv.globalenv (RTLpath.transf_program prog). - -Hypothesis all_fundef_liveness_ok: forall b f, - Genv.find_funct_ptr pge b = Some f -> - liveness_ok_fundef f. - -Lemma find_funct_liveness_ok v fd: - Genv.find_funct pge v = Some fd -> liveness_ok_fundef fd. -Proof. - unfold Genv.find_funct. - destruct v; try congruence. - destruct (Integers.Ptrofs.eq_dec _ _); try congruence. - eapply all_fundef_liveness_ok; eauto. -Qed. - -Lemma find_function_liveness_ok ros rs f: - find_function pge ros rs = Some f -> liveness_ok_fundef f. -Proof. - destruct ros as [r|i]; simpl. - - intros; eapply find_funct_liveness_ok; eauto. - - destruct (Genv.find_symbol pge i); try congruence. - eapply all_fundef_liveness_ok; eauto. -Qed. - -Lemma find_function_eqlive alive ros rs1 rs2: - eqlive_reg (ext alive) rs1 rs2 -> - reg_sum_mem ros alive = true -> - find_function pge ros rs1 = find_function pge ros rs2. -Proof. - intros EQLIVE. - destruct ros; simpl; auto. - intros H; erewrite (EQLIVE r); eauto. -Qed. - -Lemma inst_checker_from_iinst_checker i sp rs m st pm alive: - istep ge i sp rs m = Some st -> - inst_checker pm alive i = (SOME res <- iinst_checker pm alive i IN exit_checker pm (fst res) (snd res) tt). -Proof. - destruct i; simpl; try congruence. -Qed. - -Lemma exit_checker_eqlive_ext1 (pm: path_map) (alive: Regset.t) (pc: node) r rs1 rs2: - exit_checker pm (Regset.add r alive) pc tt = Some tt -> - eqlive_reg (ext alive) rs1 rs2 -> - exists path, pm!pc = Some path /\ (forall v, eqlive_reg (ext path.(input_regs)) (rs1 # r <- v) (rs2 # r <- v)). -Proof. - unfold exit_checker. - inversion_SOME path. - inversion_ASSERT. try_simplify_someHyps. - repeat (econstructor; eauto). - intros; eapply eqlive_reg_update; eauto. - eapply eqlive_reg_monotonic; eauto. - intros r0 [X1 X2]; exploit Regset.subset_2; eauto. - rewrite regset_add_spec. intuition subst. -Qed. - -Local Hint Resolve in_or_app: local. -Lemma eqlive_eval_builtin_args alive rs1 rs2 sp m args vargs: - eqlive_reg alive rs1 rs2 -> - Events.eval_builtin_args ge (fun r => rs1 # r) sp m args vargs -> - (forall r, List.In r (params_of_builtin_args args) -> alive r) -> - Events.eval_builtin_args ge (fun r => rs2 # r) sp m args vargs. -Proof. - unfold Events.eval_builtin_args. - intros EQLIVE; induction 1 as [|a1 al b1 bl EVAL1 EVALL]; simpl. - { econstructor; eauto. } - intro X. - assert (X1: eqlive_reg (fun r => In r (params_of_builtin_arg a1)) rs1 rs2). - { eapply eqlive_reg_monotonic; eauto with local. } - lapply IHEVALL; eauto with local. - clear X IHEVALL; intro X. econstructor; eauto. - generalize X1; clear EVALL X1 X. - induction EVAL1; simpl; try (econstructor; eauto; fail). - - intros X1; erewrite X1; [ econstructor; eauto | eauto ]. - - intros; econstructor. - + eapply IHEVAL1_1; eauto. - eapply eqlive_reg_monotonic; eauto. - simpl; intros; eauto with local. - + eapply IHEVAL1_2; eauto. - eapply eqlive_reg_monotonic; eauto. - simpl; intros; eauto with local. - - intros; econstructor. - + eapply IHEVAL1_1; eauto. - eapply eqlive_reg_monotonic; eauto. - simpl; intros; eauto with local. - + eapply IHEVAL1_2; eauto. - eapply eqlive_reg_monotonic; eauto. - simpl; intros; eauto with local. -Qed. - -Lemma exit_checker_eqlive_builtin_res (pm: path_map) (alive: Regset.t) (pc: node) rs1 rs2 (res:builtin_res reg): - exit_checker pm (reg_builtin_res res alive) pc tt = Some tt -> - eqlive_reg (ext alive) rs1 rs2 -> - exists path, pm!pc = Some path /\ (forall vres, eqlive_reg (ext path.(input_regs)) (regmap_setres res vres rs1) (regmap_setres res vres rs2)). -Proof. - destruct res; simpl. - - intros; exploit exit_checker_eqlive_ext1; eauto. - - intros; exploit exit_checker_eqlive; eauto. - intros (path & PATH & EQLIVE). - eexists; intuition eauto. - - intros; exploit exit_checker_eqlive; eauto. - intros (path & PATH & EQLIVE). - eexists; intuition eauto. -Qed. - -Lemma exit_list_checker_eqlive (pm: path_map) (alive: Regset.t) (tbl: list node) rs1 rs2 pc: forall n, - exit_list_checker pm alive tbl = true -> - eqlive_reg (ext alive) rs1 rs2 -> - list_nth_z tbl n = Some pc -> - exists path, pm!pc = Some path /\ eqlive_reg (ext path.(input_regs)) rs1 rs2. -Proof. - induction tbl; simpl. - - intros; try congruence. - - intros n; rewrite lazy_and_Some_tt_true; destruct (zeq n 0) eqn: Hn. - * try_simplify_someHyps; intuition. - exploit exit_checker_eqlive; eauto. - * intuition. eapply IHtbl; eauto. -Qed. - -Lemma inst_checker_eqlive (f: function) sp alive pc i rs1 rs2 m stk1 stk2 t s1: - list_forall2 eqlive_stackframes stk1 stk2 -> - eqlive_reg (ext alive) rs1 rs2 -> - liveness_ok_function f -> - (fn_code f) ! pc = Some i -> - path_last_step ge pge stk1 f sp pc rs1 m t s1 -> - inst_checker (fn_path f) alive i = Some tt -> - exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. -Proof. - intros STACKS EQLIVE LIVENESS PC; - destruct 1 as [i' sp pc rs1 m st1| - sp pc rs1 m sig ros args res pc' fd| - st1 pc rs1 m sig ros args fd m'| - sp pc rs1 m ef args res pc' vargs t vres m'| - sp pc rs1 m arg tbl n pc' | - st1 pc rs1 m optr m']; - try_simplify_someHyps. - + (* istate *) - intros PC ISTEP. erewrite inst_checker_from_iinst_checker; eauto. - inversion_SOME res. - intros. - destruct (icontinue st1) eqn: CONT. - - (* CONT => true *) - exploit iinst_checker_eqlive; eauto. - destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - exploit exit_checker_eqlive; eauto. - intros (path & PATH & EQLIVE2). - eapply eqlive_states_intro; eauto. - erewrite <- iinst_checker_istep_continue; eauto. - - (* CONT => false *) - intros; exploit iinst_checker_eqlive_stopped; eauto. - destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - eapply eqlive_states_intro; eauto. - + (* Icall *) - repeat inversion_ASSERT. intros. - exploit exit_checker_eqlive_ext1; eauto. - intros (path & PATH & EQLIVE2). - eexists; split. - - eapply exec_Icall; eauto. - erewrite <- find_function_eqlive; eauto. - - erewrite eqlive_reg_listmem; eauto. - eapply eqlive_states_call; eauto. - eapply find_function_liveness_ok; eauto. - repeat (econstructor; eauto). - + (* Itailcall *) - repeat inversion_ASSERT. intros. - eexists; split. - - eapply exec_Itailcall; eauto. - erewrite <- find_function_eqlive; eauto. - - erewrite eqlive_reg_listmem; eauto. - eapply eqlive_states_call; eauto. - eapply find_function_liveness_ok; eauto. - + (* Ibuiltin *) - repeat inversion_ASSERT. intros. - exploit exit_checker_eqlive_builtin_res; eauto. - intros (path & PATH & EQLIVE2). - eexists; split. - - eapply exec_Ibuiltin; eauto. - eapply eqlive_eval_builtin_args; eauto. - intros; eapply list_mem_correct; eauto. - - repeat (econstructor; simpl; eauto). - + (* Ijumptable *) - repeat inversion_ASSERT. intros. - exploit exit_list_checker_eqlive; eauto. - intros (path & PATH & EQLIVE2). - eexists; split. - - eapply exec_Ijumptable; eauto. - erewrite <- EQLIVE; eauto. - - repeat (econstructor; simpl; eauto). - + (* Ireturn *) - repeat inversion_ASSERT. intros. - eexists; split. - - eapply exec_Ireturn; eauto. - - destruct optr; simpl in * |- *. - * erewrite (EQLIVE r); eauto. - eapply eqlive_states_return; eauto. - * eapply eqlive_states_return; eauto. -Qed. - -Lemma path_step_eqlive path stk1 f sp rs1 m pc t s1 stk2 rs2: - path_step ge pge (psize path) stk1 f sp rs1 m pc t s1 -> - list_forall2 eqlive_stackframes stk1 stk2 -> - eqlive_reg (ext (input_regs path)) rs1 rs2 -> - liveness_ok_function f -> - (fn_path f) ! pc = Some path -> - exists s2, path_step ge pge (psize path) stk2 f sp rs2 m pc t s2 /\ eqlive_states s1 s2. -Proof. - intros STEP STACKS EQLIVE LIVE PC. - unfold liveness_ok_function in LIVE. - exploit LIVE; eauto. - unfold path_checker. - inversion_SOME res; (* destruct res as [alive pc']. *) intros ICHECK. (* simpl. *) - inversion_SOME i; intros PC'. - destruct STEP as [st ISTEPS CONT|]. - - (* early_exit *) - intros; exploit ipath_checker_eqlive_stopped; eauto. - destruct 1 as (path2 & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - eapply eqlive_states_intro; eauto. - - (* normal_exit *) - intros; exploit ipath_checker_eqlive_normal; eauto. - destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). - exploit ipath_checker_isteps_continue; eauto. - intros PC3; rewrite <- PC3, <- PC2 in * |-. - exploit inst_checker_eqlive; eauto. - intros (s2 & LAST_STEP & EQLIVE2). - eexists; split; eauto. - eapply exec_normal_exit; eauto. - rewrite <- PC3, <- MEM; auto. -Qed. - -Theorem step_eqlive t s1 s1' s2: - step ge pge s1 t s1' -> - eqlive_states s1 s2 -> - exists s2', step ge pge s2 t s2' /\ eqlive_states s1' s2'. -Proof. - destruct 1 as [path stack f sp rs m pc t s PATH STEP | | | ]. - - intros EQLIVE; inv EQLIVE; simplify_someHyps. - intro PATH. - exploit path_step_eqlive; eauto. - intros (s2 & STEP2 & EQUIV2). - eexists; split; eauto. - eapply exec_path; eauto. - - intros EQLIVE; inv EQLIVE; inv LIVE. - exploit initialize_path. { eapply fn_entry_point_wf. } - intros (path & Hpath). - eexists; split. - * eapply exec_function_internal; eauto. - * eapply eqlive_states_intro; eauto. - eapply eqlive_reg_refl. - - intros EQLIVE; inv EQLIVE. - eexists; split. - * eapply exec_function_external; eauto. - * eapply eqlive_states_return; eauto. - - intros EQLIVE; inv EQLIVE. - inversion STACKS as [|s1 st1 s' s2 STACK STACKS']; subst; clear STACKS. - inv STACK. - exists (State s2 f sp pc (rs2 # res <- vres) m); split. - * apply exec_return. - * eapply eqlive_states_intro; eauto. -Qed. - -End LivenessProperties. diff --git a/kvx/lib/RTLpathSE_impl.v b/kvx/lib/RTLpathSE_impl.v deleted file mode 100644 index afc9785e..00000000 --- a/kvx/lib/RTLpathSE_impl.v +++ /dev/null @@ -1,1631 +0,0 @@ -(** Implementation and refinement of the symbolic execution - *) - -Require Import Coqlib Maps Floats. -Require Import AST Integers Values Events Memory Globalenvs Smallstep. -Require Import Op Registers. -Require Import RTL RTLpath. -Require Import Errors Duplicate. -Require Import RTLpathSE_theory. -Require Import Axioms. - -Local Open Scope error_monad_scope. -Local Open Scope option_monad_scope. - -(** * TODO: refine symbolic values/symbolic memories with hash-consed symbolic values *) - -(** * Implementation of local symbolic internal states - definitions and core simulation properties *) - -(** name : Hash-consed Symbolic Internal state local. Later on we will use the - refinement to introduce hash consing *) -Record hsistate_local := - { - (** [hsi_lsmem] represents the list of smem symbolic evaluations. - The first one of the list is the current smem *) - hsi_lsmem:> list smem; - (** For the values in registers: - 1) we store a list of sval evaluations - 2) we encode the symbolic regset by a PTree *) - hsi_ok_lsval: list sval; - hsi_sreg:> PTree.t sval - }. - -Definition hsi_sreg_get (hst: PTree.t sval) r: sval := - match PTree.get r hst with - | None => Sinput r - | Some sv => sv - end. - -(* NB: short cut *) -Definition hsi_sreg_eval ge sp (hst: PTree.t sval) r rs0 m0: option val := - match PTree.get r hst with - | None => Some (Regmap.get r rs0) - | Some sv => seval_sval ge sp sv rs0 m0 - end. - -Lemma hsi_sreg_eval_correct ge sp hst r rs0 m0: - hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (hsi_sreg_get hst r) rs0 m0. -Proof. - unfold hsi_sreg_eval, hsi_sreg_get; destruct (PTree.get r hst); simpl; auto. -Qed. - -Definition hsi_smem_get (hst: list smem): smem := - match hst with - | nil => Sinit - | sm::_ => sm - end. - -(* NB: short cut *) -Definition hsi_smem_eval ge sp (hst: list smem) rs0 m0 : option mem := - match hst with - | nil => Some m0 - | sm::_ => seval_smem ge sp sm rs0 m0 - end. - -Lemma hsi_smem_eval_correct ge sp hst rs0 m0: - hsi_smem_eval ge sp hst rs0 m0 = seval_smem ge sp (hsi_smem_get hst) rs0 m0. -Proof. - unfold hsi_smem_eval, hsi_smem_get; destruct hst; simpl; auto. -Qed. - - -(* negation of sabort_local *) -Definition sok_local (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) (st: sistate_local): Prop := - (st.(si_pre) ge sp rs0 m0) - /\ seval_smem ge sp st.(si_smem) rs0 m0 <> None - /\ forall (r: reg), seval_sval ge sp (si_sreg st r) rs0 m0 <> None. - -Lemma ssem_local_sok ge sp rs0 m0 st rs m: - ssem_local ge sp st rs0 m0 rs m -> sok_local ge sp rs0 m0 st. -Proof. - unfold sok_local, ssem_local. - intuition congruence. -Qed. - -Definition hsok_local ge sp rs0 m0 (hst: hsistate_local) : Prop := - (forall sv, List.In sv (hsi_ok_lsval hst) -> seval_sval ge sp sv rs0 m0 <> None) - /\ (forall sm, List.In sm (hsi_lsmem hst) -> seval_smem ge sp sm rs0 m0 <> None). - -(* refinement link between a (st: sistate_local) and (hst: hsistate_local) *) -Definition hsilocal_refines ge sp rs0 m0 (hst: hsistate_local) (st: sistate_local) := - (sok_local ge sp rs0 m0 st <-> hsok_local ge sp rs0 m0 hst) - /\ (hsok_local ge sp rs0 m0 hst -> hsi_smem_eval ge sp hst rs0 m0 = seval_smem ge sp st.(si_smem) rs0 m0) - /\ (hsok_local ge sp rs0 m0 hst -> forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (si_sreg st r) rs0 m0). - -Lemma ssem_local_refines_hok ge sp rs0 m0 hst st rs m: - ssem_local ge sp st rs0 m0 rs m -> hsilocal_refines ge sp rs0 m0 hst st -> hsok_local ge sp rs0 m0 hst. -Proof. - intros H0 (H1 & _ & _). apply H1. eapply ssem_local_sok. eauto. -Qed. - -Definition is_subset {A: Type} (lv2 lv1: list A) := forall v, In v lv2 -> In v lv1. - -Definition hsilocal_simu_core (hst1 hst2: hsistate_local) := - is_subset (hsi_lsmem hst2) (hsi_lsmem hst1) - /\ is_subset (hsi_ok_lsval hst2) (hsi_ok_lsval hst1) - /\ (forall r, hsi_sreg_get hst2 r = hsi_sreg_get hst1 r) - /\ hsi_smem_get hst1 = hsi_smem_get hst2. - -Lemma hsilocal_simu_core_nofail ge1 ge2 sp rs0 m0 hst1 hst2: - hsilocal_simu_core hst1 hst2 -> - (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> - hsok_local ge1 sp rs0 m0 hst1 -> - hsok_local ge2 sp rs0 m0 hst2. -Proof. - intros (MEMOK & RSOK & _ & _) GFS (OKV & OKM). constructor. - - intros sv INS. apply RSOK in INS. apply OKV in INS. erewrite seval_preserved; eauto. - - intros sm INS. apply MEMOK in INS. apply OKM in INS. erewrite smem_eval_preserved; eauto. -Qed. - -Remark istate_simulive_reflexive dm is: istate_simulive (fun _ : Regset.elt => True) dm is is. -Proof. - unfold istate_simulive. - repeat (constructor; auto). -Qed. - -Theorem hsilocal_simu_core_correct hst1 hst2 ge1 ge2 sp rs0 m0 rs m st1 st2: - hsilocal_simu_core hst1 hst2 -> - hsilocal_refines ge1 sp rs0 m0 hst1 st1 -> - hsilocal_refines ge2 sp rs0 m0 hst2 st2 -> - (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> - ssem_local ge1 sp st1 rs0 m0 rs m -> - ssem_local ge2 sp st2 rs0 m0 rs m. -Proof. - intros CORE HREF1 HREF2 GFS SEML. - exploit ssem_local_refines_hok; eauto. intro HOK1. - exploit hsilocal_simu_core_nofail; eauto. intro HOK2. - destruct SEML as (PRE & MEMEQ & RSEQ). - constructor; [|constructor]. - + destruct HREF2 as (OKEQ & _ & _). rewrite <- OKEQ in HOK2. apply HOK2. - + destruct HREF2 as (_ & MEMEQ2 & _). destruct HREF1 as (_ & MEMEQ1 & _). - destruct CORE as (_ & _ & _ & MEMEQ3). - rewrite <- MEMEQ2; auto. rewrite hsi_smem_eval_correct. rewrite <- MEMEQ3. - erewrite smem_eval_preserved; [| eapply GFS]. - rewrite <- hsi_smem_eval_correct. rewrite MEMEQ1; auto. - + intro r. destruct HREF2 as (_ & _ & A). destruct HREF1 as (_ & _ & B). - destruct CORE as (_ & _ & C & _). rewrite <- A; auto. rewrite hsi_sreg_eval_correct. - rewrite C. erewrite seval_preserved; [| eapply GFS]. rewrite <- hsi_sreg_eval_correct. - rewrite B; auto. -Qed. - -(* Syntax and semantics of symbolic exit states *) -(* TODO: add hash-consing *) -Record hsistate_exit := mk_hsistate_exit - { hsi_cond: condition; hsi_scondargs: list_sval; hsi_elocal: hsistate_local; hsi_ifso: node }. - -Definition hsiexit_simu_core dm f (hse1 hse2: hsistate_exit) := - (exists path, (fn_path f) ! (hsi_ifso hse1) = Some path) - /\ dm ! (hsi_ifso hse2) = Some (hsi_ifso hse1) - /\ hsi_cond hse1 = hsi_cond hse2 - /\ hsi_scondargs hse1 = hsi_scondargs hse2 (* FIXME - should there be something about okvals ? *) - /\ hsilocal_simu_core (hsi_elocal hse1) (hsi_elocal hse2). - -Definition hsiexit_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit) := OK tt (* TODO *). - -Theorem hsiexit_simu_coreb_correct hse1 hse2 dm f: - hsiexit_simu_coreb dm f hse1 hse2 = OK tt -> - hsiexit_simu_core dm f hse1 hse2. -Proof. -Admitted. - -(** NB: we split the refinement relation between a "static" part -- independendent of the initial context - and a "dynamic" part -- that depends on it -*) -Definition hsiexit_refines_stat (hext: hsistate_exit) (ext: sistate_exit): Prop := - hsi_cond hext = si_cond ext - /\ hsi_ifso hext = si_ifso ext. - -Definition hsok_exit ge sp rs m hse := hsok_local ge sp rs m (hsi_elocal hse). - -Definition hsiexit_refines_dyn ge sp rs0 m0 (hext: hsistate_exit) (ext: sistate_exit): Prop := - hsilocal_refines ge sp rs0 m0 (hsi_elocal hext) (si_elocal ext) - /\ seval_condition ge sp (hsi_cond hext) (hsi_scondargs hext) (hsi_smem_get (hsi_elocal hext)) rs0 m0 - = seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs0 m0. - -Definition hsiexit_simu dm f (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, - hsiexit_refines_stat hse1 se1 -> - hsiexit_refines_stat hse2 se2 -> - hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> - hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> - siexit_simu dm f ctx se1 se2. - -Lemma hsiexit_simu_core_nofail dm f hse1 hse2 ge1 ge2 sp rs m: - hsiexit_simu_core dm f hse1 hse2 -> - (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> - hsok_exit ge1 sp rs m hse1 -> - hsok_exit ge2 sp rs m hse2. -Proof. - intros CORE GFS HOK1. - destruct CORE as (_ & _ & _ & _ & CORE). - eapply hsilocal_simu_core_nofail; eauto. -Qed. - -Theorem hsiexit_simu_core_correct dm f hse1 hse2 ctx: - hsiexit_simu_core dm f hse1 hse2 -> - hsiexit_simu dm f ctx hse1 hse2. -Proof. - intros SIMUC (* HOK1 *) st1 st2 HREF1 HREF2 HDYN1 HDYN2. - assert (SEVALC: - seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond st1) (si_scondargs st1) (si_smem (si_elocal st1)) - (the_rs0 ctx) (the_m0 ctx) = - seval_condition (the_ge2 ctx) (the_sp ctx) (si_cond st2) (si_scondargs st2) (si_smem (si_elocal st2)) - (the_rs0 ctx) (the_m0 ctx)). - { destruct HDYN1 as (_ & SCOND1). rewrite <- SCOND1 by assumption. clear SCOND1. - destruct HDYN2 as (_ & SCOND2). rewrite <- SCOND2 by assumption. clear SCOND2. - destruct SIMUC as (_ & _ & CONDEQ & ARGSEQ & LSIMU). destruct LSIMU as (_ & _ & _ & MEMEQ). - rewrite CONDEQ. rewrite ARGSEQ. rewrite MEMEQ. erewrite <- seval_condition_preserved; eauto. - eapply ctx. } - constructor; [assumption|]. intros is1 SSEME. - assert (HOK1: hsok_exit (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1). { - unfold hsok_exit. destruct SSEME as (_ & SSEML & _). apply ssem_local_sok in SSEML. - destruct HDYN1 as (LREF & _). destruct LREF as (OKEQ & _ & _). rewrite <- OKEQ. assumption. } - exploit hsiexit_simu_core_nofail. 2: eapply ctx. all: eauto. intro HOK2. - exists (mk_istate (icontinue is1) (si_ifso st2) (irs is1) (imem is1)). simpl. constructor. - - constructor; [|constructor]. - + rewrite <- SEVALC. destruct SSEME as (SCOND & _ & _). assumption. - + destruct SSEME as (_ & SLOC & _). destruct SIMUC as (_ & _ & _ & _ & LSIMU). - destruct HDYN1 as (LREF1 & _). destruct HDYN2 as (LREF2 & _). - eapply hsilocal_simu_core_correct; eauto. apply ctx. - + reflexivity. - - unfold istate_simu. destruct (icontinue is1) eqn:ICONT. - * constructor; [|constructor]; simpl; auto. - constructor; auto. - * simpl. destruct SIMUC as ((path & PATH) & REVEQ & _ & _ & _ & _). - assert (PCEQ: hsi_ifso hse1 = ipc is1). { destruct SSEME as (_ & _ & PCEQ). destruct HREF1 as (_ & IFSO). congruence. } - exists path. constructor; [|constructor]. - + congruence. - + constructor; [|constructor]; simpl; auto. - constructor; auto. - + destruct HREF2 as (_ & IFSO). congruence. -Qed. - -Remark hsiexit_simu_siexit dm f ctx hse1 hse2 se1 se2: - hsiexit_simu dm f ctx hse1 hse2 -> - hsiexit_refines_stat hse1 se1 -> - hsiexit_refines_stat hse2 se2 -> - hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> - hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> - siexit_simu dm f ctx se1 se2. -Proof. - auto. -Qed. - -Definition hsiexits_simu dm f (ctx: simu_proof_context f) lhse1 lhse2: Prop := - list_forall2 (hsiexit_simu dm f ctx) lhse1 lhse2. - -Definition hsiexits_simu_core dm f lhse1 lhse2: Prop := - list_forall2 (hsiexit_simu_core dm f) lhse1 lhse2. - -Theorem hsiexits_simu_core_correct dm f lhse1 lhse2 ctx: - hsiexits_simu_core dm f lhse1 lhse2 -> - hsiexits_simu dm f ctx lhse1 lhse2. -Proof. - induction 1; [constructor|]. - constructor; [|apply IHlist_forall2; assumption]. - apply hsiexit_simu_core_correct; assumption. -Qed. - -Definition hsiexits_refines_stat lhse lse := - list_forall2 hsiexit_refines_stat lhse lse. - -Definition hsiexits_refines_dyn ge sp rs0 m0 lhse se := - list_forall2 (hsiexit_refines_dyn ge sp rs0 m0) lhse se. - -(** * Syntax and Semantics of symbolic internal state *) -Record hsistate := { hsi_pc: node; hsi_exits: list hsistate_exit; hsi_local: hsistate_local }. - -Definition hsistate_simu_core dm f (hse1 hse2: hsistate) := - dm ! (hsi_pc hse2) = Some (hsi_pc hse1) - /\ list_forall2 (hsiexit_simu_core dm f) (hsi_exits hse1) (hsi_exits hse2) - /\ hsilocal_simu_core (hsi_local hse1) (hsi_local hse2). - -Definition hsistate_refines_stat (hst: hsistate) (st:sistate): Prop := - hsi_pc hst = si_pc st - /\ hsiexits_refines_stat (hsi_exits hst) (si_exits st). - -Definition hsistate_refines_dyn ge sp rs0 m0 (hst: hsistate) (st:sistate): Prop := - hsiexits_refines_dyn ge sp rs0 m0 (hsi_exits hst) (si_exits st) - /\ hsilocal_refines ge sp rs0 m0 (hsi_local hst) (si_local st). - -Definition hsistate_simu dm f (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, - hsistate_refines_stat hst1 st1 -> - hsistate_refines_stat hst2 st2 -> - hsistate_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst1 st1 -> - hsistate_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst2 st2 -> - sistate_simu dm f st1 st2 ctx. - -Lemma siexits_simu_all_fallthrough dm f ctx: forall lse1 lse2, - siexits_simu dm f lse1 lse2 ctx -> - all_fallthrough (the_ge1 ctx) (the_sp ctx) lse1 (the_rs0 ctx) (the_m0 ctx) -> - all_fallthrough (the_ge2 ctx) (the_sp ctx) lse2 (the_rs0 ctx) (the_m0 ctx). -Proof. - induction 1; [unfold all_fallthrough; contradiction|]. - intros X ext INEXT. eapply all_fallthrough_revcons in X. destruct X as (SEVAL & ALLFU). - apply IHlist_forall2 in ALLFU. - destruct H as (CONDSIMU & _). - inv INEXT; [|eauto]. - erewrite <- CONDSIMU; eauto. -Qed. - -Lemma hsiexits_simu_siexits dm f ctx lhse1 lhse2: - hsiexits_simu dm f ctx lhse1 lhse2 -> - forall lse1 lse2, - hsiexits_refines_stat lhse1 lse1 -> - hsiexits_refines_stat lhse2 lse2 -> - hsiexits_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse1 lse1 -> - hsiexits_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse2 lse2 -> - siexits_simu dm f lse1 lse2 ctx. -Proof. - induction 1. - - intros. inv H. inv H0. constructor. - - intros lse1 lse2 SREF1 SREF2 DREF1 DREF2. inv SREF1. inv SREF2. inv DREF1. inv DREF2. - constructor; [| eapply IHlist_forall2; eauto]. - eapply hsiexit_simu_siexit; eauto. -Qed. - -Lemma siexits_simu_all_fallthrough_upto dm f ctx lse1 lse2: - siexits_simu dm f lse1 lse2 ctx -> forall ext1 lx1, - all_fallthrough_upto_exit (the_ge1 ctx) (the_sp ctx) ext1 lx1 lse1 (the_rs0 ctx) (the_m0 ctx) -> - exists ext2 lx2, - all_fallthrough_upto_exit (the_ge2 ctx) (the_sp ctx) ext2 lx2 lse2 (the_rs0 ctx) (the_m0 ctx) - /\ length lx1 = length lx2. -Proof. - induction 1. - - intros. destruct H as (ITAIL & ALLFU). eapply is_tail_false in ITAIL. contradiction. - - intros ext1 lx1 ALLFUE. - destruct ALLFUE as (ITAIL & ALLFU). inv ITAIL. - + eexists; eexists. - constructor; [| eapply list_forall2_length; eauto]. - constructor; [econstructor | eapply siexits_simu_all_fallthrough; eauto]. - + exploit IHlist_forall2; [constructor; eauto|]. - intros (ext2 & lx2 & ALLFUE2 & LENEQ). - eexists; eexists. constructor; eauto. - eapply all_fallthrough_upto_exit_cons; eauto. -Qed. - -Lemma list_forall2_nth_error {A} (l1 l2: list A) P: - list_forall2 P l1 l2 -> - forall x1 x2 n, - nth_error l1 n = Some x1 -> - nth_error l2 n = Some x2 -> - P x1 x2. -Proof. - induction 1. - - intros. rewrite nth_error_nil in H. discriminate. - - intros x1 x2 n. destruct n as [|n]; simpl. - + intros. inv H1. inv H2. assumption. - + apply IHlist_forall2. -Qed. - -Lemma is_tail_length {A} (l1 l2: list A): - is_tail l1 l2 -> - (length l1 <= length l2)%nat. -Proof. - induction l2. - - intro. destruct l1; auto. apply is_tail_false in H. contradiction. - - intros ITAIL. inv ITAIL; auto. - apply IHl2 in H1. clear IHl2. simpl. omega. -Qed. - -Lemma is_tail_nth_error {A} (l1 l2: list A) x: - is_tail (x::l1) l2 -> - nth_error l2 ((length l2) - length l1 - 1) = Some x. -Proof. - induction l2. - - intro ITAIL. apply is_tail_false in ITAIL. contradiction. - - intros ITAIL. assert (length (a::l2) = S (length l2)) by auto. rewrite H. clear H. - assert (forall n n', ((S n) - n' - 1)%nat = (n - n')%nat) by (intros; omega). rewrite H. clear H. - inv ITAIL. - + assert (forall n, (n - n)%nat = 0%nat) by (intro; omega). rewrite H. - simpl. reflexivity. - + exploit IHl2; eauto. intros. clear IHl2. - assert (forall n n', (n > n')%nat -> (n - n')%nat = S (n - n' - 1)%nat) by (intros; omega). - exploit (is_tail_length (x::l1)); eauto. intro. simpl in H2. - assert ((length l2 > length l1)%nat) by omega. clear H2. - rewrite H0; auto. -Qed. - -Theorem hsistate_simu_core_correct dm f hst1 hst2 ctx: - hsistate_simu_core dm f hst1 hst2 -> - hsistate_simu dm f hst1 hst2 ctx. -Proof. - intros SIMUC st1 st2 HREF1 HREF2 DREF1 DREF2 is1 SEMI. - destruct HREF1 as (PCREF1 & EREF1). destruct HREF2 as (PCREF2 & EREF2). - destruct DREF1 as (DEREF1 & LREF1). destruct DREF2 as (DEREF2 & LREF2). - destruct SIMUC as (PCSIMU & ESIMU & LSIMU). - exploit hsiexits_simu_core_correct; eauto. intro HESIMU. - unfold ssem_internal in SEMI. destruct (icontinue _) eqn:ICONT. - - destruct SEMI as (SSEML & PCEQ & ALLFU). - exploit hsilocal_simu_core_correct; eauto; [apply ctx|]. intro SSEML2. - exists (mk_istate (icontinue is1) (si_pc st2) (irs is1) (imem is1)). constructor. - + unfold ssem_internal. simpl. rewrite ICONT. constructor; [assumption | constructor; [reflexivity |]]. - eapply siexits_simu_all_fallthrough; eauto. eapply hsiexits_simu_siexits; eauto. - + unfold istate_simu. rewrite ICONT. constructor; [simpl; assumption | constructor; [| reflexivity]]. - constructor. - - destruct SEMI as (ext & lx & SSEME & ALLFU). - assert (SESIMU: siexits_simu dm f (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). - exploit siexits_simu_all_fallthrough_upto; eauto. intros (ext2 & lx2 & ALLFU2 & LENEQ). - assert (EXTSIMU: siexit_simu dm f ctx ext ext2). { - eapply list_forall2_nth_error; eauto. - - destruct ALLFU as (ITAIL & _). eapply is_tail_nth_error; eauto. - - destruct ALLFU2 as (ITAIL & _). eapply is_tail_nth_error in ITAIL. - assert (LENEQ': length (si_exits st1) = length (si_exits st2)) by (eapply list_forall2_length; eauto). - congruence. } - destruct EXTSIMU as (CONDEVAL & EXTSIMU). - apply EXTSIMU in SSEME. clear EXTSIMU. destruct SSEME as (is2 & SSEME2 & ISIMU). - exists (mk_istate (icontinue is1) (ipc is2) (irs is2) (imem is2)). constructor. - + unfold ssem_internal. simpl. rewrite ICONT. exists ext2, lx2. constructor; assumption. - + unfold istate_simu in *. rewrite ICONT in *. destruct ISIMU as (path & PATHEQ & ISIMULIVE & DMEQ). - destruct ISIMULIVE as (CONTEQ & REGEQ & MEMEQ). - exists path. repeat (constructor; auto). -Qed. - -(* Definition hfinal_refines hfv fv := forall pge ge sp npc stk f rs0 m0 rs' m' t s', - ssem_final pge ge sp npc stk f rs0 m0 hfv rs' m' t s' <-> ssem_final pge ge sp npc stk f rs0 m0 fv rs' m' t s'. *) - -(* FIXME - might be too strong, let's change it later.. *) -Definition hfinal_refines (hfv fv: sfval) := hfv = fv. - -Remark hfinal_refines_snone: hfinal_refines Snone Snone. -Proof. - reflexivity. -Qed. - -Definition hfinal_simu_core (dm: PTree.t node) (f: RTLpath.function) (hf1 hf2: sfval): Prop := - match hf1 with - | Scall sig1 svos1 lsv1 res1 pc1 => - match hf2 with - | Scall sig2 svos2 lsv2 res2 pc2 => - dm ! pc2 = Some pc1 /\ sig1 = sig2 /\ svos1 = svos2 /\ lsv1 = lsv2 /\ res1 = res2 - | _ => False - end - | Sbuiltin ef1 lbs1 br1 pc1 => - match hf2 with - | Sbuiltin ef2 lbs2 br2 pc2 => - dm ! pc2 = Some pc1 /\ ef1 = ef2 /\ lbs1 = lbs2 /\ br1 = br2 - | _ => False - end - | Sjumptable sv1 lpc1 => - match hf2 with - | Sjumptable sv2 lpc2 => - ptree_get_list dm lpc2 = Some lpc1 /\ sv1 = sv2 - | _ => False - end - (* Snone, Stailcall, Sreturn *) - | _ => hf1 = hf2 - end. - -Lemma svident_simu_refl f ctx s: - svident_simu f ctx s s. -Proof. - destruct s; constructor; [| reflexivity]. - erewrite <- seval_preserved; [| eapply ctx]. constructor. -Qed. - -Theorem hfinal_simu_core_correct dm f ctx opc1 opc2 hf1 hf2 f1 f2: - hfinal_simu_core dm f hf1 hf2 -> - hfinal_refines hf1 f1 -> - hfinal_refines hf2 f2 -> - dm ! opc2 = Some opc1 -> - sfval_simu dm f opc1 opc2 ctx f1 f2. -Proof. - intros CORE FREF1 FREF2 OPCEQ. - rewrite <- FREF1. rewrite <- FREF2. clear FREF1. clear FREF2. (* FIXME - to change when the refinement is more complex *) - destruct hf1. - (* Snone *) - - simpl in CORE. rewrite <- CORE. constructor. assumption. - (* Scall *) - - simpl in CORE. destruct hf2; try contradiction. destruct CORE as (PCEQ & ? & ? & ? & ?). subst. - constructor; [assumption | apply svident_simu_refl|]. - erewrite <- list_sval_eval_preserved; [| eapply ctx]. constructor. - (* Stailcall *) - - simpl in CORE. rewrite <- CORE. constructor; [apply svident_simu_refl|]. - erewrite <- list_sval_eval_preserved; [| eapply ctx]. constructor. - (* Sbuiltin *) - - simpl in CORE. destruct hf2; try contradiction. destruct CORE as (PCEQ & ? & ? & ?). subst. - constructor; [assumption | reflexivity]. - (* Sjumptable *) - - simpl in CORE. destruct hf2; try contradiction. destruct CORE as (PCEQ & ?). subst. - constructor; [assumption|]. - erewrite <- seval_preserved; [| eapply ctx]. constructor. - (* Sreturn *) - - simpl in CORE. subst. constructor. -Qed. - -Record hsstate := { hinternal:> hsistate; hfinal: sfval }. - -Definition hsstate_refines (hst: hsstate) (st:sstate): Prop := - hsistate_refines_stat (hinternal hst) (internal st) - /\ (forall ge sp rs0 m0, hsistate_refines_dyn ge sp rs0 m0 (hinternal hst) (internal st)) - /\ hfinal_refines (hfinal hst) (final st). - -Definition hsstate_simu_core (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := - hsistate_simu_core dm f (hinternal hst1) (hinternal hst2) - /\ hfinal_simu_core dm f (hfinal hst1) (hfinal hst2). - -Definition hsstate_simu dm f (hst1 hst2: hsstate) ctx: Prop := - forall st1 st2, - hsstate_refines hst1 st1 -> - hsstate_refines hst2 st2 -> sstate_simu dm f st1 st2 ctx. - -Theorem hsstate_simu_core_correct dm f ctx hst1 hst2: - hsstate_simu_core dm f hst1 hst2 -> - hsstate_simu dm f hst1 hst2 ctx. -Proof. - intros (SCORE & FSIMU). intros st1 st2 HREF1 HREF2. - destruct HREF1 as (SREF1 & DREF1 & FREF1). destruct HREF2 as (SREF2 & DREF2 & FREF2). - assert (PCEQ: dm ! (hsi_pc hst2) = Some (hsi_pc hst1)) by apply SCORE. - eapply hsistate_simu_core_correct in SCORE. - eapply hfinal_simu_core_correct in FSIMU; eauto. - constructor; [apply SCORE; auto|]. - destruct SREF1 as (PC1 & _). destruct SREF2 as (PC2 & _). rewrite <- PC1. rewrite <- PC2. - eapply FSIMU. -Qed. - -(** * Verificators of *_simu_core properties *) - -(* WARNING: ce code va bouger pas mal quand on aura le hash-consing ! *) -Fixpoint sval_simub (sv1 sv2: sval) := - match sv1 with - | Sinput r => - match sv2 with - | Sinput r' => if (Pos.eq_dec r r') then OK tt else Error (msg "sval_simub: Sinput different registers") - | _ => Error (msg "sval_simub: Sinput expected") - end - | Sop op lsv sm => - match sv2 with - | Sop op' lsv' sm' => - if (eq_operation op op') then - do _ <- list_sval_simub lsv lsv'; - smem_simub sm sm' - else Error (msg "sval_simub: different operations in Sop") - | _ => Error (msg "sval_simub: Sop expected") - end - | Sload sm trap chk addr lsv => - match sv2 with - | Sload sm' trap' chk' addr' lsv' => - if (trapping_mode_eq trap trap') then - if (chunk_eq chk chk') then - if (eq_addressing addr addr') then - do _ <- smem_simub sm sm'; - list_sval_simub lsv lsv' - else Error (msg "sval_simub: addressings do not match") - else Error (msg "sval_simub: chunks do not match") - else Error (msg "sval_simub: trapping modes do not match") - (* FIXME - should be refined once we introduce non trapping loads *) - | _ => Error (msg "sval_simub: Sload expected") - end - end -with list_sval_simub (lsv1 lsv2: list_sval) := - match lsv1 with - | Snil => - match lsv2 with - | Snil => OK tt - | _ => Error (msg "list_sval_simub: lists of different lengths (lsv2 is bigger)") - end - | Scons sv1 lsv1 => - match lsv2 with - | Snil => Error (msg "list_sval_simub: lists of different lengths (lsv1 is bigger)") - | Scons sv2 lsv2 => - do _ <- sval_simub sv1 sv2; - list_sval_simub lsv1 lsv2 - end - end -with smem_simub (sm1 sm2: smem) := - match sm1 with - | Sinit => - match sm2 with - | Sinit => OK tt - | _ => Error (msg "smem_simub: Sinit expected") - end - | Sstore sm chk addr lsv sv => - match sm2 with - | Sstore sm' chk' addr' lsv' sv' => - if (chunk_eq chk chk') then - if (eq_addressing addr addr') then - do _ <- smem_simub sm sm'; - do _ <- list_sval_simub lsv lsv'; - sval_simub sv sv' - else Error (msg "smem_simub: addressings do not match") - else Error (msg "smem_simub: chunks not match") - | _ => Error (msg "smem_simub: Sstore expected") - end - end. - -Lemma sval_simub_correct sv1: forall sv2, - sval_simub sv1 sv2 = OK tt -> sv1 = sv2. -Proof. - induction sv1 using sval_mut with - (P0 := fun lsv1 => forall lsv2, list_sval_simub lsv1 lsv2 = OK tt -> lsv1 = lsv2) - (P1 := fun sm1 => forall sm2, smem_simub sm1 sm2 = OK tt -> sm1 = sm2); simpl; auto. - (* Sinput *) - - destruct sv2; try discriminate. - destruct (Pos.eq_dec r r0); [congruence|discriminate]. - (* Sop *) - - destruct sv2; try discriminate. - destruct (eq_operation _ _); [|discriminate]. subst. - intro. explore. apply IHsv1 in EQ. apply IHsv0 in EQ0. congruence. - (* Sload *) - - destruct sv2; try discriminate. - destruct (trapping_mode_eq _ _); [|discriminate]. - destruct (chunk_eq _ _); [|discriminate]. - destruct (eq_addressing _ _); [|discriminate]. - intro. explore. assert (sm = sm0) by auto. assert (lsv = lsv0) by auto. - congruence. - (* Snil *) - - destruct lsv2; [|discriminate]. congruence. - (* Scons *) - - destruct lsv2; [discriminate|]. intro. explore. - apply IHsv1 in EQ. apply IHsv0 in EQ0. congruence. - (* Sinit *) - - destruct sm2; [|discriminate]. congruence. - (* Sstore *) - - destruct sm2; [discriminate|]. - destruct (chunk_eq _ _); [|discriminate]. - destruct (eq_addressing _ _); [|discriminate]. - intro. explore. - assert (sm = sm2) by auto. assert (lsv = lsv0) by auto. assert (sv1 = srce) by auto. - congruence. -Qed. - -Lemma list_sval_simub_correct lsv1: forall lsv2, - list_sval_simub lsv1 lsv2 = OK tt -> lsv1 = lsv2. -Proof. - induction lsv1; simpl; auto. - - destruct lsv2; try discriminate. reflexivity. - - destruct lsv2; try discriminate. intro. explore. - apply sval_simub_correct in EQ. assert (lsv1 = lsv2) by auto. - congruence. -Qed. - -Lemma smem_simub_correct sm1: forall sm2, - smem_simub sm1 sm2 = OK tt -> sm1 = sm2. -Proof. - induction sm1; simpl; auto. - - destruct sm2; try discriminate. reflexivity. - - destruct sm2; try discriminate. - destruct (chunk_eq _ _); [|discriminate]. - destruct (eq_addressing _ _); [|discriminate]. intro. explore. - apply sval_simub_correct in EQ2. apply list_sval_simub_correct in EQ1. - apply IHsm1 in EQ. congruence. -Qed. - -Definition is_structural {A: Type} (cmp: A -> A -> bool) := - forall x y, cmp x y = true -> x = y. - -Fixpoint is_part_of {A: Type} (cmp: A -> A -> bool) (elt: A) (lv: list A): bool := - match lv with - | nil => false - | v::lv => if (cmp elt v) then true else is_part_of cmp elt lv - end. - -Lemma is_part_of_correct {A: Type} cmp lv (e: A): - is_structural cmp -> - is_part_of cmp e lv = true -> - In e lv. -Proof. - induction lv. - - intros. simpl in H0. discriminate. - - intros. simpl in H0. destruct (cmp e a) eqn:CMP. - + apply H in CMP. subst. constructor; auto. - + right. apply IHlv; assumption. -Qed. - -(* Checks if lv2 is a subset of lv1 *) -Fixpoint is_subsetb {A: Type} (cmp: A -> A -> bool) (lv2 lv1: list A): bool := - match lv2 with - | nil => true - | v2 :: lv2 => if (is_part_of cmp v2 lv1) then is_subsetb cmp lv2 lv1 - else false - end. - -Lemma is_subset_cons {A: Type} (x: A) lv lx: - In x lv /\ is_subset lx lv -> is_subset (x::lx) lv. -Proof. - intros (ISIN & ISSUB). unfold is_subset. - intros. inv H. - - assumption. - - apply ISSUB. assumption. -Qed. - -Lemma is_subset_correct {A: Type} cmp (lv2 lv1: list A): - is_structural cmp -> - is_subsetb cmp lv2 lv1 = true -> - is_subset lv2 lv1. -Proof. - induction lv2. - - simpl. intros. intro. intro. apply in_nil in H1. contradiction. - - intros. simpl in H0. apply is_subset_cons. - explore. apply is_part_of_correct in EQ; [|assumption]. - apply IHlv2 in H0; [|assumption]. constructor; assumption. -Qed. - -Definition simub_bool {A: Type} (simub: A -> A -> res unit) (sv1 sv2: A) := - match simub sv1 sv2 with - | OK tt => true - | _ => false - end. - -Lemma simub_bool_correct {A: Type} simub (sv1 sv2: A): - (forall x y, simub x y = OK tt -> x = y) -> - simub_bool simub sv1 sv2 = true -> sv1 = sv2. -Proof. - intros. unfold simub_bool in H0. destruct (simub sv1 sv2) eqn:SIMU; explore. - - apply H. assumption. - - discriminate. -Qed. - -Definition hsilocal_simu_coreb hst1 hst2 := - if (is_subsetb (simub_bool smem_simub) (hsi_lsmem hst2) (hsi_lsmem hst1)) then - if (is_subsetb (simub_bool sval_simub) (hsi_ok_lsval hst2) (hsi_ok_lsval hst1)) then - (* TODO - compare on the whole ptree *) OK tt - else Error (msg "hsi_ok_lsval sets aren't included") - else Error (msg "hsi_lsmem sets aren't included"). - -Theorem hsilocal_simu_coreb_correct hst1 hst2: - hsilocal_simu_coreb hst1 hst2 = OK tt -> - hsilocal_simu_core hst1 hst2. -Proof. -Admitted. - -(* Definition hsiexit_simub (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit) := - if (eq_condition (hsi_cond hse1) (hsi_cond hse2)) then - do _ <- list_sval_simub (hsi_scondargs hse1) (hsi_scondargs hse2); - do _ <- hsilocal_simub dm f (hsi_elocal hse1) (hsi_elocal hse2); - revmap_check_single dm (hsi_ifso hse1) (hsi_ifso hse2) - else Error (msg "siexit_simub: conditions do not match") -. *) - -(* Fixpoint hsiexits_simub (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := - match lhse1 with - | nil => - match lhse2 with - | nil => OK tt - | _ => Error (msg "siexists_simub: sle1 and sle2 lengths do not match") - end - | hse1 :: lhse1 => - match lhse2 with - | nil => Error (msg "siexits_simub: sle1 and sle2 lengths do not match") - | hse2 :: lhse2 => - do _ <- hsiexit_simub dm f hse1 hse2; - do _ <- hsiexits_simub dm f lhse1 lhse2; - OK tt - end - end. *) - -(* Lemma hsiexits_simub_correct dm f ctx lhse1: forall lhse2, - hsiexits_simub dm f lhse1 lhse2 = OK tt -> - hsiexits_simu dm f ctx lhse1 lhse2. -Proof. -(* induction lhse1. - - simpl. intros. destruct lhse2; try discriminate. intros se1 se2 HEREFS1 HEREFS2 _ _. - inv HEREFS1. inv HEREFS2. constructor. - - (* simpl. *) unfold hsiexits_simub. intros. destruct lhse2; try discriminate. explore. - fold hsiexits_simub in EQ1. - eapply hsiexit_simub_correct in EQ. apply IHlhse1 in EQ1. - intros se1 se2 HEREFS1 HEREFS2 HEREFD1 HEREFD2. inv HEREFS1. inv HEREFS2. inv HEREFD1. inv HEREFD2. constructor; auto. - apply EQ1; assumption. *) -Admitted. - *) - -(* TODO *) -Definition hsiexits_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := OK tt. - -Theorem hsiexits_simu_coreb_correct dm f lhse1 lhse2: - hsiexits_simu_coreb dm f lhse1 lhse2 = OK tt -> - hsiexits_simu_core dm f lhse1 lhse2. -Proof. -Admitted. - -Definition hsistate_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate) := OK tt. (* TODO *) - -Theorem hsistate_simu_coreb_correct dm f hse1 hse2: - hsistate_simu_coreb dm f hse1 hse2 = OK tt -> - hsistate_simu_core dm f hse1 hse2. -Proof. -Admitted. - -Definition hsstate_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := OK tt. (* TODO *) - -Theorem hsstate_simu_coreb_correct dm f hst1 hst2: - hsstate_simu_coreb dm f hst1 hst2 = OK tt -> - hsstate_simu_core dm f hst1 hst2. -Proof. -Admitted. - -Definition hfinal_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hf1 hf2: sfval) := OK tt. (* TODO *) - -Theorem hfinal_simu_coreb_correct dm f hf1 hf2: - hfinal_simu_coreb dm f hf1 hf2 = OK tt -> - hfinal_simu_core dm f hf1 hf2. -Proof. -Admitted. - -Lemma hsistate_refines_stat_pceq st hst: - hsistate_refines_stat hst st -> - (hsi_pc hst) = (si_pc st). -Proof. - unfold hsistate_refines_stat; intuition. -Qed. - -Lemma hsistate_refines_dyn_local_refines ge sp rs0 m0 hst st: - hsistate_refines_dyn ge sp rs0 m0 hst st -> - hsilocal_refines ge sp rs0 m0 (hsi_local hst) (si_local st). -Proof. - unfold hsistate_refines_dyn; intuition. -Qed. - - - -Local Hint Resolve hsistate_refines_dyn_local_refines: core. - - - -(** * Symbolic execution of one internal step - TODO: to refine symbolic values/symbolic memories with hash-consed symbolic values -*) - -(** ** Assignment of memory *) -Definition hslocal_set_smem (hst:hsistate_local) (sm:smem) := - {| hsi_lsmem := sm::hsi_lsmem hst; - hsi_ok_lsval := hsi_ok_lsval hst; - hsi_sreg:= hsi_sreg hst - |}. - -Lemma sok_local_set_mem ge sp rs0 m0 st sm: - sok_local ge sp rs0 m0 (slocal_set_smem st sm) - <-> (sok_local ge sp rs0 m0 st /\ seval_smem ge sp sm rs0 m0 <> None). -Proof. - unfold slocal_set_smem, sok_local; simpl; intuition (subst; eauto). -Qed. - -Lemma hsok_local_set_mem ge sp rs0 m0 hst sm: - hsok_local ge sp rs0 m0 (hslocal_set_smem hst sm) - <-> (hsok_local ge sp rs0 m0 hst /\ seval_smem ge sp sm rs0 m0 <> None). -Proof. - unfold hslocal_set_smem, hsok_local; simpl; intuition (subst; eauto). -Qed. - -Lemma hslocal_set_mem_correct ge sp rs0 m0 hst st hsm sm: - hsilocal_refines ge sp rs0 m0 hst st -> - (hsok_local ge sp rs0 m0 hst -> seval_smem ge sp hsm rs0 m0 = seval_smem ge sp sm rs0 m0) -> - hsilocal_refines ge sp rs0 m0 (hslocal_set_smem hst hsm) (slocal_set_smem st sm). -Proof. - intros LOCREF. intros SMEMEQ. - destruct LOCREF as (OKEQ & SMEMEQ' & REGEQ). constructor; [| constructor ]. - - rewrite hsok_local_set_mem. - rewrite sok_local_set_mem. - constructor. - + intros (OKL & SMEMN). constructor. 2: rewrite SMEMEQ; auto. - all: rewrite <- OKEQ; assumption. - + intros (HOKL & HSMEM). rewrite OKEQ. constructor; auto. - rewrite <- SMEMEQ; auto. - - rewrite! hsok_local_set_mem. intros (HOKL & HSMEM). - simpl. apply SMEMEQ; assumption. - - rewrite hsok_local_set_mem. intros (HOKL & HSMEM). - simpl. intuition congruence. -Qed. - -(** ** Assignment of local state *) - -Definition hsist_set_local (hst: hsistate) (pc: node) (hnxt: hsistate_local): hsistate := - {| hsi_pc := pc; hsi_exits := hst.(hsi_exits); hsi_local:= hnxt |}. - -Lemma hsist_set_local_correct_stat hst st pc hnxt nxt: - hsistate_refines_stat hst st -> - hsistate_refines_stat (hsist_set_local hst pc hnxt) (sist_set_local st pc nxt). -Proof. - unfold hsistate_refines_stat; simpl; intuition. -Qed. - -Lemma hsist_set_local_correct_dyn ge sp rs0 m0 hst st pc hnxt nxt: - hsistate_refines_dyn ge sp rs0 m0 hst st -> - hsilocal_refines ge sp rs0 m0 hnxt nxt -> - hsistate_refines_dyn ge sp rs0 m0 (hsist_set_local hst pc hnxt) (sist_set_local st pc nxt). -Proof. - unfold hsistate_refines_dyn; simpl; intuition. -Qed. - -(** ** Assignment of registers *) - -(* locally new symbolic values during symbolic execution *) -Inductive root_sval: Type := -| Rop (op:operation) -| Rload (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) -. - -Definition root_apply (rsv: root_sval) (lsv: list sval) (sm: smem): sval := - match rsv with - | Rop op => Sop op (list_sval_inj lsv) sm - | Rload trap chunk addr => Sload sm trap chunk addr (list_sval_inj lsv) - end. -Coercion root_apply: root_sval >-> Funclass. - -Local Open Scope lazy_bool_scope. - -(* NB: return [false] if the rsv cannot fail *) -Definition may_trap (rsv: root_sval) (lsv: list sval) (sm: smem): bool := - match rsv with - | Rop op => is_trapping_op op ||| negb (Nat.eqb (length lsv) (args_of_operation op)) (* cf. lemma is_trapping_op_sound *) - | Rload TRAP _ _ => true - | _ => false - end. - -Lemma lazy_orb_negb_false (b1 b2:bool): - (b1 ||| negb b2) = false <-> (b1 = false /\ b2 = true). -Proof. - unfold negb; explore; simpl; intuition (try congruence). -Qed. - -(* not used yet *) -Lemma may_trap_correct (ge: RTL.genv) (sp:val) (rsv: root_sval) (rs0: regset) (m0: mem) (lsv: list sval) (sm: smem): - may_trap rsv lsv sm = false -> - seval_list_sval ge sp (list_sval_inj lsv) rs0 m0 <> None -> - seval_smem ge sp sm rs0 m0 <> None -> - seval_sval ge sp (rsv lsv sm) rs0 m0 <> None. -Proof. - destruct rsv; simpl; try congruence. - - rewrite lazy_orb_negb_false. intros (TRAP1 & TRAP2) OK1 OK2. - explore; try congruence. - eapply is_trapping_op_sound; eauto. - admit. (* TODO *) - - intros X OK1 OK2. - explore; try congruence. -Admitted. - -(* simplify a symbolic value before assignment to a register *) -Definition simplify (rsv: root_sval) lsv sm: sval := - match rsv with - | Rload TRAP chunk addr => Sload sm NOTRAP chunk addr (list_sval_inj lsv) - | Rop op => - match is_move_operation op lsv with - | Some arg => arg (* optimization of Omove *) - | None => - if op_depends_on_memory op then - rsv lsv sm - else - Sop op (list_sval_inj lsv) Sinit (* magically remove the dependency on sm ! *) - end - | _ => rsv lsv sm - end. - -Lemma simplify_correct (rsv: root_sval) lsv sm (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) v: - seval_sval ge sp (rsv lsv sm) rs0 m0 = Some v -> - seval_sval ge sp (simplify rsv lsv sm) rs0 m0 = Some v. -Proof. - destruct rsv; simpl; auto. - - (* Rop *) - destruct (seval_list_sval _ _ _ _) as [args|] eqn: Hargs; try congruence. - destruct (seval_smem _ _ _ _) as [m|] eqn: Hm; try congruence. - intros Hv. - destruct (is_move_operation _ _) eqn: Hmove. - + exploit is_move_operation_correct; eauto. - intros (Hop & Hlsv); subst; simpl in *. - explore. auto. - + clear Hmove; destruct (op_depends_on_memory op) eqn: Hop; simpl; explore; try congruence. - inversion Hargs; subst. - erewrite op_depends_on_memory_correct; eauto. - - (* Rload *) - destruct trap; simpl; auto. - destruct (seval_list_sval _ _ _ _) as [args|] eqn: Hargs; try congruence. - destruct (eval_addressing _ _ _ _) as [a|] eqn: Ha; try congruence. - destruct (seval_smem _ _ _ _) as [m|] eqn: Hm; try congruence. - intros H; rewrite H; auto. -Qed. - -Definition red_PTree_set (r:reg) (sv: sval) (hst: PTree.t sval): PTree.t sval := - match sv with - | Sinput r' => - if Pos.eq_dec r r' - then PTree.remove r' hst - else PTree.set r sv hst - | _ => PTree.set r sv hst - end. - -Lemma red_PTree_set_correct (r:reg) (sv: sval) (hst: PTree.t sval) ge sp rs0 m0: - hsi_sreg_eval ge sp (red_PTree_set r sv hst) r rs0 m0 = hsi_sreg_eval ge sp (PTree.set r sv hst) r rs0 m0. -Proof. - destruct sv; simpl; auto. - destruct (Pos.eq_dec r r0); auto. - subst; unfold hsi_sreg_eval. - rewrite PTree.grs, PTree.gss; simpl; auto. -Qed. - -(* naive version: -@Cyril: éventuellement, tu peux utiliser la version naive dans un premier temps pour simplifier les preuves... - -Definition naive_hslocal_set_sreg (hst:hsistate_local) (r:reg) (rsv:root_sval) lsv sm := - let sv := rsv lsv sm in - {| hsi_lsmem := hsi_lsmem hst; - hsi_ok_lsval := sv::(hsi_ok_lsval hst); - hsi_sreg:= PTree.set r sv (hsi_sreg hst) |}. -*) - -Definition hslocal_set_sreg (hst:hsistate_local) (r:reg) (rsv:root_sval) lsv sm := - {| hsi_lsmem := hsi_lsmem hst; - hsi_ok_lsval := if may_trap rsv lsv sm then (rsv lsv sm)::(hsi_ok_lsval hst) else hsi_ok_lsval hst; - hsi_sreg := red_PTree_set r (simplify rsv lsv sm) (hsi_sreg hst) |}. - -Definition ok_args ge sp rs0 m0 hst lsv sm := - hsok_local ge sp rs0 m0 hst -> - (seval_list_sval ge sp (list_sval_inj lsv) rs0 m0 <> None /\ seval_smem ge sp sm rs0 m0 <> None). - -Lemma hslocal_set_sreg_correct ge sp rs0 m0 hst st r (rsv:root_sval) lsv sm sv': - hsilocal_refines ge sp rs0 m0 hst st -> - (forall ge sp rs0 m0, - ok_args ge sp rs0 m0 hst lsv sm -> - (hsok_local ge sp rs0 m0 hst -> seval_sval ge sp sv' rs0 m0 = seval_sval ge sp (rsv lsv sm) rs0 m0) ) -> - hsilocal_refines ge sp rs0 m0 (hslocal_set_sreg hst r rsv lsv sm) (slocal_set_sreg st r sv'). -Admitted. - -(** ** Execution of one instruction *) - -Definition hsiexec_inst (i: instruction) (hst: hsistate): option hsistate := - match i with - | Inop pc' => - Some (hsist_set_local hst pc' hst.(hsi_local)) - | Iop op args dst pc' => - let prev := hst.(hsi_local) in - let vargs := List.map (hsi_sreg_get prev) args in - let next := hslocal_set_sreg prev dst (Rop op) vargs (hsi_smem_get prev) in - Some (hsist_set_local hst pc' next) - | Iload trap chunk addr args dst pc' => - let prev := hst.(hsi_local) in - let vargs := List.map (hsi_sreg_get prev) args in - let next := hslocal_set_sreg prev dst (Rload trap chunk addr) vargs (hsi_smem_get prev) in - Some (hsist_set_local hst pc' next) - | Istore chunk addr args src pc' => - let prev := hst.(hsi_local) in - let vargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in - let next := hslocal_set_smem prev (Sstore (hsi_smem_get prev) chunk addr vargs (hsi_sreg_get prev src)) in - Some (hsist_set_local hst pc' next) - | Icond cond args ifso ifnot _ => - let prev := hst.(hsi_local) in - let vargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in - let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in - Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |} - | _ => None (* TODO jumptable ? *) - end. - -Local Hint Resolve hsist_set_local_correct_stat - hsist_set_local_correct_dyn hslocal_set_mem_correct: core. - -Lemma seval_sval_refines ge sp rs0 m0 hst st p: - hsok_local ge sp rs0 m0 hst -> - hsilocal_refines ge sp rs0 m0 hst st -> - seval_sval ge sp (hsi_sreg_get hst p) rs0 m0 = seval_sval ge sp (si_sreg st p) rs0 m0. -Proof. - intros OKL HREF. destruct HREF as (_ & _ & RSEQ). - rewrite <- hsi_sreg_eval_correct; eauto. -Qed. - -Lemma seval_list_sval_refines ge sp rs0 m0 hst st l: - hsok_local ge sp rs0 m0 hst -> - hsilocal_refines ge sp rs0 m0 hst st -> - seval_list_sval ge sp (list_sval_inj (map (hsi_sreg_get hst) l)) rs0 m0 = - seval_list_sval ge sp (list_sval_inj (map (si_sreg st) l)) rs0 m0. -Proof. - intros OKL HLREF. destruct HLREF as (_ & _ & RSEQ). - induction l; simpl; auto. - erewrite <- RSEQ; auto. - rewrite IHl. - rewrite <- hsi_sreg_eval_correct. - reflexivity. -Qed. - -Lemma seval_smem_refines ge sp rs0 m0 hst st : - hsok_local ge sp rs0 m0 hst -> - hsilocal_refines ge sp rs0 m0 hst st -> - seval_smem ge sp (hsi_smem_get hst) rs0 m0 = seval_smem ge sp (si_smem st) rs0 m0. -Proof. - intros OKL HLREF. destruct HLREF as (_ & MSEQ & _). - rewrite <- hsi_smem_eval_correct. - auto. -Qed. - -Lemma seval_condition_refines hst st ge sp cond args rs m: - hsok_local ge sp rs m hst -> - hsilocal_refines ge sp rs m hst st -> - seval_condition ge sp cond args (hsi_smem_get hst) rs m - = seval_condition ge sp cond args (si_smem st) rs m. - Proof. - intros HOK (OKEQ & MEMEQ & RSEQ). unfold seval_condition. - rewrite <- MEMEQ; auto. rewrite hsi_smem_eval_correct. reflexivity. -Qed. - -Lemma hsiexec_inst_correct_None i hst st: - hsiexec_inst i hst = None -> siexec_inst i st = None. -Proof. - destruct i; simpl; congruence. -Qed. - - -Lemma hsiexec_inst_correct_stat i hst hst' st: - hsiexec_inst i hst = Some hst' -> - exists st', siexec_inst i st = Some st' - /\ (hsistate_refines_stat hst st -> hsistate_refines_stat hst' st'). -Proof. - destruct i; simpl; intros STEPI; inversion_clear STEPI; discriminate || eexists; split; eauto. - (* TODO *) -Admitted. - -Lemma hsiexec_inst_correct_dyn ge sp rs0 m0 i hst st hst' st': - hsiexec_inst i hst = Some hst' -> - siexec_inst i st = Some st' -> - hsistate_refines_dyn ge sp rs0 m0 hst st -> hsistate_refines_dyn ge sp rs0 m0 hst' st'. -Proof. - destruct i; simpl; intros STEP1 STEP2; inversion_clear STEP1; - inversion_clear STEP2; discriminate || (intro REF; eauto). - - (* Iop *) - eapply hsist_set_local_correct_dyn; eauto. - eapply hslocal_set_sreg_correct; eauto. - + simpl. admit. (* TODO *) - - (* Iload *) - eapply hsist_set_local_correct_dyn; eauto. - eapply hslocal_set_sreg_correct; eauto. - + simpl. admit. (* TODO *) - - (* Istore *) - eapply hsist_set_local_correct_dyn; eauto. - eapply hslocal_set_mem_correct; eauto. - intros. simpl. - erewrite seval_list_sval_refines; eauto. - erewrite seval_smem_refines; eauto. - erewrite seval_sval_refines; eauto. - - (* Icond *) - admit. (* TODO *) -Admitted. - - -Fixpoint hsiexec_path (path:nat) (f: function) (hst: hsistate): option hsistate := - match path with - | O => Some hst - | S p => - SOME i <- (fn_code f)!(hst.(hsi_pc)) IN - SOME hst1 <- hsiexec_inst i hst IN - hsiexec_path p f hst1 - end. - -Lemma hsiexec_path_correct_stat ps f hst hst' st: - hsiexec_path ps f hst = Some hst' -> - hsistate_refines_stat hst st -> - exists st', siexec_path ps f st = Some st' /\ hsistate_refines_stat hst' st'. -Proof. -Admitted. - -Lemma hsiexec_path_correct_dyn ge sp rs0 m0 ps f hst hst' st st': - hsiexec_path ps f hst = Some hst' -> - siexec_path ps f st = Some st' -> - hsistate_refines_stat hst st -> - hsistate_refines_stat hst' st' -> - hsistate_refines_dyn ge sp rs0 m0 hst st - -> hsistate_refines_dyn ge sp rs0 m0 hst' st'. -Proof. -Admitted. - - -Definition hsexec_final (i: instruction) (prev: hsistate_local): sfval := - match i with - | Icall sig ros args res pc => - let svos := sum_left_map (hsi_sreg_get prev) ros in - let sargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in - Scall sig svos sargs res pc - | Itailcall sig ros args => - let svos := sum_left_map (hsi_sreg_get prev) ros in - let sargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in - Stailcall sig svos sargs - | Ibuiltin ef args res pc => - let sargs := List.map (builtin_arg_map (hsi_sreg_get prev)) args in - Sbuiltin ef sargs res pc - | Ireturn or => - let sor := SOME r <- or IN Some (hsi_sreg_get prev r) in - Sreturn sor - | Ijumptable reg tbl => - let sv := hsi_sreg_get prev reg in - Sjumptable sv tbl - | _ => Snone - end. - -(* Lemma local_refines_sreg_get hsl sl ge sp rs0 m0: - hsistate_local_refines hsl sl -> - sok_local ge sp sl rs0 m0 -> - hsi_sreg_get hsl = si_sreg sl. -Proof. - intros HREF SOKL. apply functional_extensionality. intro r. - destruct (HREF ge sp rs0 m0) as (OKEQ & MEMEQ & RSEQ). - apply OKEQ in SOKL. pose (RSEQ SOKL r) as EQ. - unfold hsi_sreg_get. -Admitted. *) - -Lemma sfind_function_conserves hsl sl pge ge sp s rs0 m0: - hsilocal_refines ge sp rs0 m0 hsl sl -> - sfind_function pge ge sp (sum_left_map (hsi_sreg_get hsl) s) rs0 m0 = - sfind_function pge ge sp (sum_left_map (si_sreg sl) s) rs0 m0. -Admitted. - -Lemma hsexec_final_correct hsl sl i: - (forall ge sp rs0 m0, hsilocal_refines ge sp rs0 m0 hsl sl) -> - hsexec_final i hsl = sexec_final i sl. -Proof. -(* destruct i; simpl; intros HLREF; try (apply hfinal_refines_snone). - (* Scall *) - - constructor. - + intro. inv H. constructor; auto. - ++ erewrite <- sfind_function_conserves; eauto. - ++ erewrite <- seval_list_sval_refines; eauto. - + intro. inv H. constructor; auto. - ++ erewrite sfind_function_conserves; eauto. - ++ erewrite seval_list_sval_refines; eauto. - (* Stailcall *) - - admit. - (* Sbuiltin *) - - admit. - (* Sjumptable *) - - admit. - (* Sreturn *) - - admit. *) -Admitted. - - -Definition init_hsistate_local := {| hsi_lsmem := Sinit::nil; - hsi_ok_lsval := nil; hsi_sreg := PTree.empty sval |}. - -Remark init_hsistate_local_correct ge sp rs0 m0: - hsilocal_refines ge sp rs0 m0 init_hsistate_local init_sistate_local. -Proof. - constructor; constructor; simpl. - - intro. destruct H as (_ & SMEM & SVAL). constructor; [contradiction|]. - intros. destruct H; [|contradiction]. subst. discriminate. - - intro. destruct H as (SVAL & SMEM). constructor; [simpl; auto|]. - constructor; simpl; discriminate. - - intros; simpl; reflexivity. - - intros. simpl. unfold hsi_sreg_eval. rewrite PTree.gempty. reflexivity. -Qed. - -Definition init_hsistate pc := {| hsi_pc := pc; hsi_exits := nil; hsi_local := init_hsistate_local |}. - -Remark init_hsistate_correct_stat pc: - hsistate_refines_stat (init_hsistate pc) (init_sistate pc). -Proof. - constructor; constructor; simpl; auto. -Qed. - -Remark init_hsistate_correct_dyn ge sp rs0 m0 pc: - hsistate_refines_dyn ge sp rs0 m0 (init_hsistate pc) (init_sistate pc). -Proof. - constructor; simpl; auto. - - apply list_forall2_nil. - - apply init_hsistate_local_correct. -Qed. - -Definition hsexec (f: function) (pc:node): option hsstate := - SOME path <- (fn_path f)!pc IN - SOME hst <- hsiexec_path path.(psize) f (init_hsistate pc) IN - SOME i <- (fn_code f)!(hst.(hsi_pc)) IN - Some (match hsiexec_inst i hst with - | Some hst' => {| hinternal := hst'; hfinal := Snone |} - | None => {| hinternal := hst; hfinal := hsexec_final i hst.(hsi_local) |} - end). - -Local Hint Resolve init_hsistate_correct_stat init_hsistate_correct_dyn hsexec_final_correct - hsiexec_inst_correct_dyn hsiexec_path_correct_dyn hfinal_refines_snone: core. - -Lemma hsexec_correct f pc hst: - hsexec f pc = Some hst -> - exists st, sexec f pc = Some st /\ hsstate_refines hst st. -Proof. - unfold hsexec. intro. explore_hyp. - unfold sexec. - rewrite EQ. - exploit hsiexec_path_correct_stat; eauto. - intros (st0 & SPATH & REF0). - generalize REF0; intros (PC0 & XREF0). rewrite SPATH. - erewrite <- PC0. rewrite EQ1. - destruct (hsiexec_inst i h) eqn:HINST. - + exploit hsiexec_inst_correct_stat; eauto. - intros (st1 & EQ2 & PC2 & REF2). - - split; eauto. - - rewrite EQ2. - repeat (econstructor; simpl; eauto). - + erewrite hsiexec_inst_correct_None; eauto. - repeat (econstructor; simpl; eauto). - unfold hfinal_refines. simpl; eauto. -Qed. - -(** * The simulation test of concrete symbolic execution *) - -Definition revmap_check_single (dm: PTree.t node) (n tn: node) : res unit := - match dm ! tn with - | None => Error (msg "revmap_check_single: no mapping for tn") - | Some res => if (Pos.eq_dec n res) then OK tt - else Error (msg "revmap_check_single: n and res do not match") - end. - -Lemma revmap_check_single_correct dm n tn: - revmap_check_single dm n tn = OK tt -> - dm ! tn = Some n. -Proof. - unfold revmap_check_single. explore; try discriminate. congruence. -Qed. - - -Local Hint Resolve genv_match ssem_local_refines_hok: core. - -Fixpoint revmap_check_list (dm: PTree.t node) (ln ln': list node): res unit := - match ln with - | nil => - match ln' with - | nil => OK tt - | _ => Error (msg "revmap_check_list: lists have different lengths") - end - | n::ln => - match ln' with - | nil => Error (msg "revmap_check_list: lists have different lengths") - | n'::ln' => do _ <- revmap_check_single dm n n'; revmap_check_list dm ln ln' - end - end. - -Lemma revmap_check_list_correct dm ln: forall ln', - revmap_check_list dm ln ln' = OK tt -> - ptree_get_list dm ln' = Some ln. -Proof. - induction ln. - - simpl. intros. destruct ln'; try discriminate. constructor; auto. - - simpl. intros; destruct ln'; try discriminate. explore. - apply IHln in EQ0. apply revmap_check_single_correct in EQ. - simpl. rewrite EQ. rewrite EQ0. reflexivity. -Qed. - -Definition svos_simub (svos1 svos2: sval + ident) := - match svos1 with - | inl sv1 => - match svos2 with - | inl sv2 => sval_simub sv1 sv2 - | _ => Error (msg "svos_simub: expected sval") - end - | inr id1 => - match svos2 with - | inr id2 => - if (ident_eq id1 id2) then OK tt - else Error (msg "svos_simub: ids do not match") - | _ => Error (msg "svos_simub: expected id") - end - end. - -Lemma svos_simub_correct svos1 svos2: - svos_simub svos1 svos2 = OK tt -> - svos1 = svos2. -Proof. - destruct svos1. - - simpl. destruct svos2; [|discriminate]. - intro. exploit sval_simub_correct; eauto. congruence. - - simpl. destruct svos2; [discriminate|]. - intro. explore. reflexivity. -Qed. - -Fixpoint builtin_arg_simub (bs bs': builtin_arg sval) := - match bs with - | BA sv => - match bs' with - | BA sv' => sval_simub sv sv' - | _ => Error (msg "builtin_arg_simub: BA expected") - end - | BA_int n => - match bs' with - | BA_int n' => if (Integers.int_eq n n') then OK tt else Error (msg "builtin_arg_simub: integers do not match") - | _ => Error (msg "buitin_arg_simub: BA_int expected") - end - | BA_long n => - match bs' with - | BA_long n' => if (int64_eq n n') then OK tt else Error (msg "builtin_arg_simub: integers do not match") - | _ => Error (msg "buitin_arg_simub: BA_long expected") - end - | BA_float f => - match bs' with - | BA_float f' => if (float_eq f f') then OK tt else Error (msg "builtin_arg_simub: floats do not match") - | _ => Error (msg "builtin_arg_simub: BA_float expected") - end - | BA_single f => - match bs' with - | BA_single f' => if (float32_eq f f') then OK tt else Error (msg "builtin_arg_simub: floats do not match") - | _ => Error (msg "builtin_arg_simub: BA_single expected") - end - | BA_loadstack chk ptr => - match bs' with - | BA_loadstack chk' ptr' => - if (chunk_eq chk chk') then - if (ptrofs_eq ptr ptr') then OK tt - else Error (msg "builtin_arg_simub: ptr do not match") - else Error (msg "builtin_arg_simub: chunks do not match") - | _ => Error (msg "builtin_arg_simub: BA_loadstack expected") - end - | BA_addrstack ptr => - match bs' with - | BA_addrstack ptr' => if (ptrofs_eq ptr ptr') then OK tt else Error (msg "builtin_arg_simub: ptr do not match") - | _ => Error (msg "builtin_arg_simub: BA_addrstack expected") - end - | BA_loadglobal chk id ofs => - match bs' with - | BA_loadglobal chk' id' ofs' => - if (chunk_eq chk chk') then - if (ident_eq id id') then - if (ptrofs_eq ofs ofs') then OK tt - else Error (msg "builtin_arg_simub: offsets do not match") - else Error (msg "builtin_arg_simub: identifiers do not match") - else Error (msg "builtin_arg_simub: chunks do not match") - | _ => Error (msg "builtin_arg_simub: BA_loadglobal expected") - end - | BA_addrglobal id ofs => - match bs' with - | BA_addrglobal id' ofs' => - if (ident_eq id id') then - if (ptrofs_eq ofs ofs') then OK tt - else Error (msg "builtin_arg_simub: offsets do not match") - else Error (msg "builtin_arg_simub: identifiers do not match") - | _ => Error (msg "builtin_arg_simub: BA_addrglobal expected") - end - | BA_splitlong lo hi => - match bs' with - | BA_splitlong lo' hi' => do _ <- builtin_arg_simub lo lo'; builtin_arg_simub hi hi' - | _ => Error (msg "builtin_arg_simub: BA_splitlong expected") - end - | BA_addptr b1 b2 => - match bs' with - | BA_addptr b1' b2' => do _ <- builtin_arg_simub b1 b1'; builtin_arg_simub b2 b2' - | _ => Error (msg "builtin_arg_simub: BA_addptr expected") - end - end. - -Lemma builtin_arg_simub_correct b1: forall b2, - builtin_arg_simub b1 b2 = OK tt -> b1 = b2. -Proof. - induction b1; simpl; destruct b2; try discriminate; auto; intros; try (explore; congruence). - - apply sval_simub_correct in H. congruence. - - explore. assert (b1_1 = b2_1) by auto. assert (b1_2 = b2_2) by auto. congruence. - - explore. assert (b1_1 = b2_1) by auto. assert (b1_2 = b2_2) by auto. congruence. -Qed. - -Fixpoint list_builtin_arg_simub lbs1 lbs2 := - match lbs1 with - | nil => - match lbs2 with - | nil => OK tt - | _ => Error (msg "list_builtin_arg_simub: lists of different lengths (lbs2 is bigger)") - end - | bs1::lbs1 => - match lbs2 with - | nil => Error (msg "list_builtin_arg_simub: lists of different lengths (lbs1 is bigger)") - | bs2::lbs2 => - do _ <- builtin_arg_simub bs1 bs2; - list_builtin_arg_simub lbs1 lbs2 - end - end. - -Lemma list_builtin_arg_simub_correct lsb1: forall lsb2, - list_builtin_arg_simub lsb1 lsb2 = OK tt -> lsb1 = lsb2. -Proof. - induction lsb1; intros; simpl; destruct lsb2; try discriminate; auto. - simpl in H. explore. apply builtin_arg_simub_correct in EQ. - assert (lsb1 = lsb2) by auto. congruence. -Qed. - -(* WARNING: ce code va bouger pas mal quand on aura le hash-consing ! *) -Definition sfval_simub (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (fv1 fv2: sfval) := - match fv1 with - | Snone => - match fv2 with - | Snone => revmap_check_single dm pc1 pc2 - | _ => Error (msg "sfval_simub: Snone expected") - end - | Scall sig svos lsv res pc1 => - match fv2 with - | Scall sig2 svos2 lsv2 res2 pc2 => - do _ <- revmap_check_single dm pc1 pc2; - if (signature_eq sig sig2) then - if (Pos.eq_dec res res2) then - do _ <- svos_simub svos svos2; - list_sval_simub lsv lsv2 - else Error (msg "sfval_simub: Scall res do not match") - else Error (msg "sfval_simub: Scall different signatures") - | _ => Error (msg "sfval_simub: Scall expected") - end - | Stailcall sig svos lsv => - match fv2 with - | Stailcall sig' svos' lsv' => - if (signature_eq sig sig') then - do _ <- svos_simub svos svos'; - list_sval_simub lsv lsv' - else Error (msg "sfval_simub: signatures do not match") - | _ => Error (msg "sfval_simub: Stailcall expected") - end - | Sbuiltin ef lbs br pc => - match fv2 with - | Sbuiltin ef' lbs' br' pc' => - if (external_function_eq ef ef') then - if (builtin_res_eq_pos br br') then - do _ <- revmap_check_single dm pc pc'; - list_builtin_arg_simub lbs lbs' - else Error (msg "sfval_simub: builtin res do not match") - else Error (msg "sfval_simub: external functions do not match") - | _ => Error (msg "sfval_simub: Sbuiltin expected") - end - | Sjumptable sv ln => - match fv2 with - | Sjumptable sv' ln' => - do _ <- revmap_check_list dm ln ln'; sval_simub sv sv' - | _ => Error (msg "sfval_simub: Sjumptable expected") - end - | Sreturn osv => - match fv2 with - | Sreturn osv' => - match osv with - | Some sv => - match osv' with - | Some sv' => sval_simub sv sv' - | None => Error (msg "sfval_simub sv' expected") - end - | None => - match osv' with - | Some sv' => Error (msg "None expected") - | None => OK tt - end - end - | _ => Error (msg "sfval_simub: Sreturn expected") - end - end. - -Lemma sfval_simub_correct dm f pc1 pc2 fv1 fv2 ctx: - sfval_simub dm f pc1 pc2 fv1 fv2 = OK tt -> - sfval_simu dm f pc1 pc2 ctx fv1 fv2. -Proof. - unfold sfval_simub. destruct fv1. - (* Snone *) - - destruct fv2; try discriminate. intro. - apply revmap_check_single_correct in H. constructor; auto. - (* Scall *) - - destruct fv2; try discriminate. intro. explore. - apply svos_simub_correct in EQ3. apply list_sval_simub_correct in EQ4. - subst. apply revmap_check_single_correct in EQ. constructor; auto. - + admit. - + admit. - (* Stailcall *) - - destruct fv2; try discriminate. intro. explore. - apply svos_simub_correct in EQ0. apply list_sval_simub_correct in EQ1. - subst. constructor; auto. - + admit. - + admit. - (* Sbuiltin *) - - destruct fv2; try discriminate. intro. explore. - apply revmap_check_single_correct in EQ1. apply list_builtin_arg_simub_correct in EQ2. - subst. constructor; auto. - (* Sjumptable *) - - destruct fv2; try discriminate. intro. explore. - apply revmap_check_list_correct in EQ. apply sval_simub_correct in EQ0. subst. - constructor; auto. - admit. - (* Sreturn *) - - destruct fv2; try discriminate. destruct o; destruct o0; try discriminate. - + intro. apply sval_simub_correct in H. subst. constructor; auto. - + constructor; auto. -Admitted. - -Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node) := - let (pc2, pc1) := m in - match (hsexec f pc1) with - | None => Error (msg "simu_check_single: hsexec f pc1 failed") - | Some hst1 => - match (hsexec tf pc2) with - | None => Error (msg "simu_check_single: hsexec tf pc2 failed") - | Some hst2 => hsstate_simu_coreb dm f hst1 hst2 - end - end. - -Lemma simu_check_single_correct dm tf f pc1 pc2: - simu_check_single dm f tf (pc2, pc1) = OK tt -> - sexec_simu dm f tf pc1 pc2. -Proof. - unfold simu_check_single. intro. - unfold sexec_simu. - intros st1 SEXEC. - explore. - exploit hsexec_correct; eauto. - intros (st2 & SEXEC2 & REF2). - clear EQ0. (* now, useless in principle and harmful for the next [exploit] *) - exploit hsexec_correct; eauto. - intros (st0 & SEXEC1 & REF1). - rewrite SEXEC1 in SEXEC; inversion SEXEC; subst. - eexists; split; eauto. - intros ctx. eapply hsstate_simu_coreb_correct in H. - eapply hsstate_simu_core_correct; eauto. -Qed. - -Fixpoint simu_check_rec (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) lm := - match lm with - | nil => OK tt - | m :: lm => do u1 <- simu_check_single dm f tf m; - do u2 <- simu_check_rec dm f tf lm; - OK tt - end. - -Lemma simu_check_rec_correct dm f tf pc1 pc2: forall lm, - simu_check_rec dm f tf lm = OK tt -> - In (pc2, pc1) lm -> - sexec_simu dm f tf pc1 pc2. -Proof. - induction lm. - - simpl. intuition. - - simpl. intros. explore. destruct H0. - + subst. eapply simu_check_single_correct; eauto. - + eapply IHlm; assumption. -Qed. - -Definition simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) := - simu_check_rec dm f tf (PTree.elements dm). - -Lemma simu_check_correct dm f tf: - simu_check dm f tf = OK tt -> - forall pc1 pc2, dm ! pc2 = Some pc1 -> - sexec_simu dm f tf pc1 pc2. -Proof. - unfold simu_check. intros. eapply PTree.elements_correct in H0. - eapply simu_check_rec_correct; eassumption. -Qed. \ No newline at end of file diff --git a/kvx/lib/RTLpathSE_impl_junk.v b/kvx/lib/RTLpathSE_impl_junk.v deleted file mode 100644 index 1b4efad7..00000000 --- a/kvx/lib/RTLpathSE_impl_junk.v +++ /dev/null @@ -1,736 +0,0 @@ -(** Implementation and refinement of the symbolic execution - -* a JUNK VERSION WITHOUT ANY FORMAL PROOF !!! - - *) - -Require Import Coqlib Maps Floats. -Require Import AST Integers Values Events Memory Globalenvs Smallstep. -Require Import Op Registers. -Require Import RTL RTLpath. -Require Import Errors Duplicate. -Require Import RTLpathSE_theory. -Require Import Axioms. - -Local Open Scope error_monad_scope. -Local Open Scope option_monad_scope. - -Require Export Impure.ImpHCons. -Export Notations. -Import HConsing. - -Local Open Scope impure. - -Import ListNotations. -Local Open Scope list_scope. - -(** * Implementation of Data-structure use in Hash-consing *) - -(** ** Implementation of symbolic values/symbolic memories with hash-consing data *) - -Inductive hsval := - | HSinput (r: reg) (hid:hashcode) - | HSop (op:operation) (hlsv: hlist_sval) (hsm: hsmem) (hid:hashcode) - | HSload (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval) (hid:hashcode) -with hlist_sval := - | HSnil (hid:hashcode) - | HScons (hsv: hsval) (hlsv: hlist_sval) (hid:hashcode) -(* symbolic memory *) -with hsmem := - | HSinit (hid:hashcode) - | HSstore (hsm: hsmem) (chunk:memory_chunk) (addr:addressing) (hlsv:hlist_sval) (srce: hsval) (hid:hashcode). - -Scheme hsval_mut := Induction for hsval Sort Prop -with hlist_sval_mut := Induction for hlist_sval Sort Prop -with hsmem_mut := Induction for hsmem Sort Prop. - -Definition hsval_get_hid (hsv: hsval): hashcode := - match hsv with - | HSinput _ hid => hid - | HSop _ _ _ hid => hid - | HSload _ _ _ _ _ hid => hid - end. - -Definition hlist_sval_get_hid (hlsv: hlist_sval): hashcode := - match hlsv with - | HSnil hid => hid - | HScons _ _ hid => hid - end. - -Definition hsmem_get_hid (hsm: hsmem ): hashcode := - match hsm with - | HSinit hid => hid - | HSstore _ _ _ _ _ hid => hid - end. - -Definition hsval_set_hid (hsv: hsval) (hid: hashcode): hsval := - match hsv with - | HSinput r _ => HSinput r hid - | HSop o hlsv hsm _ => HSop o hlsv hsm hid - | HSload hsm trap chunk addr hlsv _ => HSload hsm trap chunk addr hlsv hid - end. - -Definition hlist_sval_set_hid (hlsv: hlist_sval) (hid: hashcode): hlist_sval := - match hlsv with - | HSnil _ => HSnil hid - | HScons hsv hlsv _ => HScons hsv hlsv hid - end. - -Definition hsmem_set_hid (hsm: hsmem ) (hid: hashcode): hsmem := - match hsm with - | HSinit _ => HSinit hid - | HSstore hsm chunk addr hlsv srce _ => HSstore hsm chunk addr hlsv srce hid - end. - -(* Now, we build the hash-Cons value from a "hash_eq". - -Informal specification: - [hash_eq] must be consistent with the "hashed" constructors defined above. - -We expect that hashinfo values in the code of these "hashed" constructors verify: - - (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) -*) - -Definition hsval_hash_eq (sv1 sv2: hsval): ?? bool := - match sv1, sv2 with - | HSinput r1 _, HSinput r2 _ => struct_eq r1 r2 (* NB: really need a struct_eq here ? *) - | HSop op1 lsv1 sm1 _, HSop op2 lsv2 sm2 _ => - DO b1 <~ phys_eq lsv1 lsv2;; - DO b2 <~ phys_eq sm1 sm2;; - if b1 && b2 - then struct_eq op1 op2 (* NB: really need a struct_eq here ? *) - else RET false - | HSload sm1 trap1 chk1 addr1 lsv1 _, HSload sm2 trap2 chk2 addr2 lsv2 _ => - DO b1 <~ phys_eq lsv1 lsv2;; - DO b2 <~ phys_eq sm1 sm2;; - DO b3 <~ struct_eq trap1 trap2;; - DO b4 <~ struct_eq chk1 chk2;; - if b1 && b2 && b3 && b4 - then struct_eq addr1 addr2 - else RET false - | _,_ => RET false - end. - -Definition hlist_sval_hash_eq (lsv1 lsv2: hlist_sval): ?? bool := - match lsv1, lsv2 with - | HSnil _, HSnil _ => RET true - | HScons sv1 lsv1' _, HScons sv2 lsv2' _ => - DO b <~ phys_eq lsv1' lsv2';; - if b - then phys_eq sv1 sv2 - else RET false - | _,_ => RET false - end. - -Definition hsmem_hash_eq (sm1 sm2: hsmem): ?? bool := - match sm1, sm2 with - | HSinit _, HSinit _ => RET true - | HSstore sm1 chk1 addr1 lsv1 sv1 _, HSstore sm2 chk2 addr2 lsv2 sv2 _ => - DO b1 <~ phys_eq lsv1 lsv2;; - DO b2 <~ phys_eq sm1 sm2;; - DO b3 <~ phys_eq sv1 sv2;; - DO b4 <~ struct_eq chk1 chk2;; - if b1 && b2 && b3 && b4 - then struct_eq addr1 addr2 - else RET false - | _,_ => RET false - end. - -Definition hSVAL: hashP hsval := {| hash_eq := hsval_hash_eq; get_hid:=hsval_get_hid; set_hid:=hsval_set_hid |}. -Definition hLSVAL: hashP hlist_sval := {| hash_eq := hlist_sval_hash_eq; get_hid:= hlist_sval_get_hid; set_hid:= hlist_sval_set_hid |}. -Definition hSMEM: hashP hsmem := {| hash_eq := hsmem_hash_eq; get_hid:= hsmem_get_hid; set_hid:= hsmem_set_hid |}. - -Program Definition mk_hash_params: Dict.hash_params hsval := - {| - Dict.test_eq := phys_eq; - Dict.hashing := fun (ht: hsval) => RET (hsval_get_hid ht); - Dict.log := fun _ => RET () (* NB no log *) |}. -Obligation 1. - wlp_simplify. -Qed. - - -(* Symbolic final value -- from hash-consed values -It does not seem useful to hash-consed these final values (because they are final). -*) -Inductive hsfval := - | HSnone - | HScall (sig:signature) (svos: hsval + ident) (lsv:hlist_sval) (res:reg) (pc:node) - | HStailcall (sig:signature) (svos: hsval + ident) (lsv:hlist_sval) - | HSbuiltin (ef:external_function) (sargs: list (builtin_arg hsval)) (res: builtin_res reg) (pc:node) - | HSjumptable (sv: hsval) (tbl: list node) - | HSreturn (res:option hsval) -. - -(** ** Implementation of symbolic states -*) - -(** name : Hash-consed Symbolic Internal state local. *) -Record hsistate_local := - { - (** [hsi_smem] represents the current smem symbolic evaluations. - (we can recover the previous one from smem) *) - hsi_smem:> hsmem; - (** For the values in registers: - 1) we store a list of sval evaluations - 2) we encode the symbolic regset by a PTree *) - hsi_ok_lsval: list hsval; - hsi_sreg:> PTree.t hsval - }. - -(* Syntax and semantics of symbolic exit states *) -Record hsistate_exit := mk_hsistate_exit - { hsi_cond: condition; hsi_scondargs: hlist_sval; hsi_elocal: hsistate_local; hsi_ifso: node }. - - -(** ** Syntax and Semantics of symbolic internal state *) -Record hsistate := { hsi_pc: node; hsi_exits: list hsistate_exit; hsi_local: hsistate_local }. - -(** ** Syntax and Semantics of symbolic state *) -Record hsstate := { hinternal:> hsistate; hfinal: hsfval }. - - -(** * Implementation of symbolic execution *) -Section CanonBuilding. - -Variable hC_hsval: hashinfo hsval -> ?? hsval. -(*Hypothesis hC_hsval_correct: TODO *) - -Variable hC_hlist_sval: hashinfo hlist_sval -> ?? hlist_sval. -(*Hypothesis hC_hlist_sval_correct: TODO *) - -Variable hC_hsmem: hashinfo hsmem -> ?? hsmem. -(*Hypothesis hC_hsval_correct: TODO *) - -(* First, we wrap constructors for hashed values !*) - -Definition hSinput_hcodes (r: reg) := - DO hc <~ hash 1;; - DO hv <~ hash r;; - RET [hc;hv]. -Extraction Inline hSinput_hcodes. - -Definition hSinput (r:reg): ?? hsval := - DO hv <~ hSinput_hcodes r;; - hC_hsval {| hdata:=HSinput r unknown_hid; hcodes :=hv; |}. - - -Definition hSop_hcodes (op:operation) (hlsv: hlist_sval) (hsm: hsmem) := - DO hc <~ hash 2;; - DO hv <~ hash op;; - RET [hc;hv;hlist_sval_get_hid hlsv; hsmem_get_hid hsm]. -Extraction Inline hSop_hcodes. - -Definition hSop (op:operation) (hlsv: hlist_sval) (hsm: hsmem): ?? hsval := - DO hv <~ hSop_hcodes op hlsv hsm;; - hC_hsval {| hdata:=HSop op hlsv hsm unknown_hid; hcodes :=hv |}. - - -Definition hSload_hcodes (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval):= - DO hc <~ hash 3;; - DO hv1 <~ hash trap;; - DO hv2 <~ hash chunk;; - DO hv3 <~ hash addr;; - RET [hc;hsmem_get_hid hsm;hv1;hv2;hv3;hlist_sval_get_hid hlsv]. -Extraction Inline hSload_hcodes. - -Definition hSload (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval): ?? hsval := - DO hv <~ hSload_hcodes hsm trap chunk addr hlsv;; - hC_hsval {| hdata:=HSload hsm trap chunk addr hlsv unknown_hid; hcodes :=hv |}. - - -Definition hSnil (_: unit): ?? hlist_sval := - hC_hlist_sval {| hdata:=HSnil unknown_hid; hcodes := nil |}. - -Definition hScons (hsv: hsval) (hlsv: hlist_sval): ?? hlist_sval := - hC_hlist_sval {| hdata:=HScons hsv hlsv unknown_hid; hcodes := [hsval_get_hid hsv; hlist_sval_get_hid hlsv] |}. - -Definition hSinit (_: unit): ?? hsmem := - hC_hsmem {| hdata:=HSinit unknown_hid; hcodes := nil |}. - -Definition hSstore_hcodes (hsm: hsmem) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval) (srce: hsval):= - DO hv1 <~ hash chunk;; - DO hv2 <~ hash addr;; - RET [hsmem_get_hid hsm;hv1;hv2;hlist_sval_get_hid hlsv;hsval_get_hid srce]. -Extraction Inline hSstore_hcodes. - -Definition hSstore (hsm: hsmem) (chunk:memory_chunk) (addr:addressing) (hlsv:hlist_sval) (srce: hsval): ?? hsmem := - DO hv <~ hSstore_hcodes hsm chunk addr hlsv srce;; - hC_hsmem {| hdata:=HSstore hsm chunk addr hlsv srce unknown_hid; hcodes := hv |}. - - -Definition hsi_sreg_get (hst: PTree.t hsval) r: ?? hsval := - match PTree.get r hst with - | None => hSinput r - | Some sv => RET sv - end. - -Fixpoint hlist_args (hst: PTree.t hsval) (l: list reg): ?? hlist_sval := - match l with - | nil => hSnil() - | r::l => - DO v <~ hsi_sreg_get hst r;; - DO hlsv <~ hlist_args hst l;; - hScons v hlsv - end. - -(** ** Assignment of memory *) -Definition hslocal_store (hst:hsistate_local) chunk addr args src: ?? hsistate_local := - let pt := hst.(hsi_sreg) in - DO hargs <~ hlist_args pt args;; - DO hsrc <~ hsi_sreg_get pt src;; - DO hm <~ hSstore hst chunk addr hargs hsrc;; - RET {| hsi_smem := hm; - hsi_ok_lsval := hsi_ok_lsval hst; - hsi_sreg:= hsi_sreg hst - |}. - -(** ** Assignment of local state *) - -Definition hsist_set_local (hst: hsistate) (pc: node) (hnxt: hsistate_local): hsistate := - {| hsi_pc := pc; hsi_exits := hst.(hsi_exits); hsi_local:= hnxt |}. - -(** ** Assignment of registers *) - -(* locally new symbolic values during symbolic execution *) -Inductive root_sval: Type := -| Rop (op:operation) -| Rload (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) -. - -Definition root_apply (rsv: root_sval) (lsv: list reg) (hst: hsistate_local) : ?? hsval := - DO hlsv <~ hlist_args hst lsv;; - match rsv with - | Rop op => hSop op hlsv hst - | Rload trap chunk addr => hSload hst trap chunk addr hlsv - end. - -Local Open Scope lazy_bool_scope. - -(* NB: return [false] if the rsv cannot fail *) -Definition may_trap (rsv: root_sval) (lsv: list reg): bool := - match rsv with - | Rop op => is_trapping_op op ||| negb (Nat.eqb (length lsv) (args_of_operation op)) (* cf. lemma is_trapping_op_sound *) - | Rload TRAP _ _ => true - | _ => false - end. - -(* simplify a symbolic value before assignment to a register *) -Definition simplify (rsv: root_sval) (lsv: list reg) (hst: hsistate_local): ?? hsval := - match rsv with - | Rop op => - match is_move_operation op lsv with - | Some arg => hsi_sreg_get hst arg (* optimization of Omove *) - | None => - DO hsi <~ hSinit ();; - DO hlsv <~ hlist_args hst lsv;; - hSop op hlsv hsi (* magically remove the dependency on sm ! *) - end - | Rload _ chunk addr => - DO hlsv <~ hlist_args hst lsv;; - hSload hst NOTRAP chunk addr hlsv - end. - -Definition red_PTree_set (r:reg) (sv: hsval) (hst: PTree.t hsval): PTree.t hsval := - match sv with - | HSinput r' _ => - if Pos.eq_dec r r' - then PTree.remove r' hst - else PTree.set r sv hst - | _ => PTree.set r sv hst - end. - -Definition hslocal_set_sreg (hst:hsistate_local) (r:reg) (rsv:root_sval) lsv: ?? hsistate_local := - DO hsiok <~ - (if may_trap rsv lsv - then DO hv <~ root_apply rsv lsv hst;; RET (hv::(hsi_ok_lsval hst)) - else RET (hsi_ok_lsval hst));; - DO simp <~ simplify rsv lsv hst;; - RET {| hsi_smem := hst; - hsi_ok_lsval := hsiok; - hsi_sreg := red_PTree_set r simp (hsi_sreg hst) |}. - -(** ** Execution of one instruction *) - -Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) := - match i with - | Inop pc' => - RET (Some (hsist_set_local hst pc' hst.(hsi_local))) - | Iop op args dst pc' => - DO next <~ hslocal_set_sreg hst.(hsi_local) dst (Rop op) args;; - RET (Some (hsist_set_local hst pc' next)) - | Iload trap chunk addr args dst pc' => - DO next <~ hslocal_set_sreg hst.(hsi_local) dst (Rload trap chunk addr) args;; - RET (Some (hsist_set_local hst pc' next)) - | Istore chunk addr args src pc' => - DO next <~ hslocal_store hst.(hsi_local) chunk addr args src;; - RET (Some (hsist_set_local hst pc' next)) - | Icond cond args ifso ifnot _ => - let prev := hst.(hsi_local) in - DO vargs <~ hlist_args prev args ;; - let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in - RET (Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |}) - | _ => RET None (* TODO jumptable ? *) - end. - -Definition some_or_fail {A} (o: option A) (msg: pstring): ?? A := - match o with - | Some x => RET x - | None => FAILWITH msg - end. - -Fixpoint hsiexec_path (path:nat) (f: function) (hst: hsistate): ?? hsistate := - match path with - | O => RET hst - | S p => - DO i <~ some_or_fail ((fn_code f)!(hst.(hsi_pc))) "hsiexec_path.internal_error.1";; - DO ohst1 <~ hsiexec_inst i hst;; - DO hst1 <~ some_or_fail ohst1 "hsiexec_path.internal_error.2";; - hsiexec_path p f hst1 - end. - -Fixpoint hbuiltin_arg (hst: PTree.t hsval) (arg : builtin_arg reg): ?? builtin_arg hsval := - match arg with - | BA r => - DO v <~ hsi_sreg_get hst r;; - RET (BA v) - | BA_int n => RET (BA_int n) - | BA_long n => RET (BA_long n) - | BA_float f0 => RET (BA_float f0) - | BA_single s => RET (BA_single s) - | BA_loadstack chunk ptr => RET (BA_loadstack chunk ptr) - | BA_addrstack ptr => RET (BA_addrstack ptr) - | BA_loadglobal chunk id ptr => RET (BA_loadglobal chunk id ptr) - | BA_addrglobal id ptr => RET (BA_addrglobal id ptr) - | BA_splitlong ba1 ba2 => - DO v1 <~ hbuiltin_arg hst ba1;; - DO v2 <~ hbuiltin_arg hst ba2;; - RET (BA_splitlong v1 v2) - | BA_addptr ba1 ba2 => - DO v1 <~ hbuiltin_arg hst ba1;; - DO v2 <~ hbuiltin_arg hst ba2;; - RET (BA_addptr v1 v2) - end. - -Fixpoint hbuiltin_args (hst: PTree.t hsval) (args: list (builtin_arg reg)): ?? list (builtin_arg hsval) := - match args with - | nil => RET nil - | a::l => - DO ha <~ hbuiltin_arg hst a;; - DO hl <~ hbuiltin_args hst l;; - RET (ha::hl) - end. - -Definition hsum_left (hst: PTree.t hsval) (ros: reg + ident): ?? (hsval + ident) := - match ros with - | inl r => DO hr <~ hsi_sreg_get hst r;; RET (inl hr) - | inr s => RET (inr s) - end. - -Definition hsexec_final (i: instruction) (hst: PTree.t hsval): ?? hsfval := - match i with - | Icall sig ros args res pc => - DO svos <~ hsum_left hst ros;; - DO sargs <~ hlist_args hst args;; - RET (HScall sig svos sargs res pc) - | Itailcall sig ros args => - DO svos <~ hsum_left hst ros;; - DO sargs <~ hlist_args hst args;; - RET (HStailcall sig svos sargs) - | Ibuiltin ef args res pc => - DO sargs <~ hbuiltin_args hst args;; - RET (HSbuiltin ef sargs res pc) - | Ijumptable reg tbl => - DO sv <~ hsi_sreg_get hst reg;; - RET (HSjumptable sv tbl) - | Ireturn or => - match or with - | Some r => DO hr <~ hsi_sreg_get hst r;; RET (HSreturn (Some hr)) - | None => RET (HSreturn None) - end - | _ => RET (HSnone) - end. - -Definition init_hsistate_local (_:unit): ?? hsistate_local - := DO hm <~ hSinit ();; - RET {| hsi_smem := hm; hsi_ok_lsval := nil; hsi_sreg := PTree.empty hsval |}. - -Definition init_hsistate pc: ?? hsistate - := DO hst <~ init_hsistate_local ();; - RET {| hsi_pc := pc; hsi_exits := nil; hsi_local := hst |}. - -Definition hsexec (f: function) (pc:node): ?? hsstate := - DO path <~ some_or_fail ((fn_path f)!pc) "hsexec.internal_error.1";; - DO hinit <~ init_hsistate pc;; - DO hst <~ hsiexec_path path.(psize) f hinit;; - DO i <~ some_or_fail ((fn_code f)!(hst.(hsi_pc))) "hsexec.internal_error.2";; - DO ohst <~ hsiexec_inst i hst;; - match ohst with - | Some hst' => RET {| hinternal := hst'; hfinal := HSnone |} - | None => DO hsvf <~ hsexec_final i hst.(hsi_local);; - RET {| hinternal := hst; hfinal := hsvf |} - end. - -End CanonBuilding. - -(** * The simulation test of concrete hash-consed symbolic execution *) - -Definition phys_check {A} (x y:A) (msg: pstring): ?? unit := - DO b <~ phys_eq x y;; - assert_b b msg;; - RET tt. - -Definition struct_check {A} (x y:A) (msg: pstring): ?? unit := - DO b <~ struct_eq x y;; - assert_b b msg;; - RET tt. - -Definition option_eq_check {A} (o1 o2: option A): ?? unit := - match o1, o2 with - | Some x1, Some x2 => phys_check x1 x2 "option_eq_check: data physically differ" - | None, None => RET tt - | _, _ => FAILWITH "option_eq_check: structure differs" - end. - -Lemma option_eq_check_correct A (o1 o2: option A): WHEN option_eq_check o1 o2 ~> _ THEN o1=o2. -Proof. - wlp_simplify. -Qed. -Global Opaque option_eq_check. -Global Hint Resolve option_eq_check_correct:wlp. - -Import PTree. - -Fixpoint PTree_eq_check {A} (d1 d2: PTree.t A): ?? unit := - match d1, d2 with - | Leaf, Leaf => RET tt - | Node l1 o1 r1, Node l2 o2 r2 => - option_eq_check o1 o2;; - PTree_eq_check l1 l2;; - PTree_eq_check r1 r2 - | _, _ => FAILWITH "PTree_eq_check: some key is absent" - end. - -Lemma PTree_eq_check_correct A d1: forall (d2: t A), - WHEN PTree_eq_check d1 d2 ~> _ THEN forall x, PTree.get x d1 = PTree.get x d2. -Proof. - induction d1 as [|l1 Hl1 o1 r1 Hr1]; destruct d2 as [|l2 o2 r2]; simpl; - wlp_simplify. destruct x; simpl; auto. -Qed. -Global Opaque PTree_eq_check. - -Fixpoint PTree_frame_eq_check {A} (frame: list positive) (d1 d2: PTree.t A): ?? unit := - match frame with - | nil => RET tt - | k::l => - option_eq_check (PTree.get k d1) (PTree.get k d2);; - PTree_frame_eq_check l d1 d2 - end. - -Lemma PTree_frame_eq_check_correct A l (d1 d2: t A): - WHEN PTree_frame_eq_check l d1 d2 ~> _ THEN forall x, List.In x l -> PTree.get x d1 = PTree.get x d2. -Proof. - induction l as [|k l]; simpl; wlp_simplify. - subst; auto. -Qed. -Global Opaque PTree_frame_eq_check. - -Definition hsilocal_simu_check hst1 hst2 : ?? unit := - phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_simu_check: hsi_smem sets aren't equiv";; - Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; - PTree_eq_check (hsi_sreg hst1) (hsi_sreg hst2). - -Definition revmap_check_single (dm: PTree.t node) (n tn: node) : ?? unit := - DO res <~ some_or_fail (dm ! tn) "revmap_check_single: no mapping for tn";; - struct_check n res "revmap_check_single: n and res are physically different". - -Definition hsilocal_frame_simu_check frame hst1 hst2 : ?? unit := - phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_frame_simu_check: hsi_smem sets aren't equiv";; - Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; - PTree_frame_eq_check frame (hsi_sreg hst1) (hsi_sreg hst2). - -Definition hsiexit_simu_check (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit): ?? unit := - struct_check (hsi_cond hse1) (hsi_cond hse2) "hsiexit_simu_check: conditions do not match";; - phys_check (hsi_scondargs hse1) (hsi_scondargs hse2) "hsiexit_simu_check: args do not match";; - revmap_check_single dm (hsi_ifso hse1) (hsi_ifso hse2);; - DO path <~ some_or_fail ((fn_path f) ! (hsi_ifso hse1)) "hsiexit_simu_check: internal error";; - hsilocal_frame_simu_check (Regset.elements path.(input_regs)) (hsi_elocal hse1) (hsi_elocal hse2). - -Fixpoint hsiexits_simu_check (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := - match lhse1,lhse2 with - | nil, nil => RET tt - | hse1 :: lhse1, hse2 :: lhse2 => - hsiexit_simu_check dm f hse1 hse2;; - hsiexits_simu_check dm f lhse1 lhse2 - | _, _ => FAILWITH "siexists_simu_check: lengths do not match" - end. - -Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsistate) := - hsilocal_simu_check (hsi_local hst1) (hsi_local hst2);; - hsiexits_simu_check dm f (hsi_exits hst1) (hsi_exits hst2). - -Fixpoint revmap_check_list (dm: PTree.t node) (ln ln': list node): ?? unit := - match ln, ln' with - | nil, nil => RET tt - | n::ln, n'::ln' => - revmap_check_single dm n n';; - revmap_check_list dm ln ln' - | _, _ => FAILWITH "revmap_check_list: lists have different lengths" - end. - -Definition svos_simu_check (svos1 svos2: hsval + ident) := - match svos1, svos2 with - | inl sv1, inl sv2 => phys_check sv1 sv2 "svos_simu_check: sval mismatch" - | inr id1, inr id2 => phys_check id1 id2 "svos_simu_check: symbol mismatch" - | _, _ => FAILWITH "svos_simu_check: type mismatch" - end. - -Fixpoint builtin_arg_simu_check (bs bs': builtin_arg hsval) := - match bs, bs' with - | BA sv, BA sv' => phys_check sv sv' "builtin_arg_simu_check: sval mismatch" - | BA_splitlong lo hi, BA_splitlong lo' hi' => - builtin_arg_simu_check lo lo';; - builtin_arg_simu_check hi hi' - | BA_addptr b1 b2, BA_addptr b1' b2' => - builtin_arg_simu_check b1 b1';; - builtin_arg_simu_check b2 b2' - | _, _ => struct_check bs bs' "builtin_arg_simu_check: basic mismatch" - end. - -Fixpoint list_builtin_arg_simu_check lbs1 lbs2 := - match lbs1, lbs2 with - | nil, nil => RET tt - | bs1::lbs1, bs2::lbs2 => - builtin_arg_simu_check bs1 bs2;; - list_builtin_arg_simu_check lbs1 lbs2 - | _, _ => FAILWITH "list_builtin_arg_simu_check: length mismatch" - end. - -Definition sfval_simu_check (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (fv1 fv2: hsfval) := - match fv1, fv2 with - | HSnone, HSnone => revmap_check_single dm pc1 pc2 - | HScall sig1 svos1 lsv1 res1 pc1, HScall sig2 svos2 lsv2 res2 pc2 => - revmap_check_single dm pc1 pc2;; - phys_check sig1 sig2 "sfval_simu_check: Scall different signatures";; - phys_check res1 res2 "sfval_simu_check: Scall res do not match";; - svos_simu_check svos1 svos2;; - phys_check lsv1 lsv2 "sfval_simu_check: Scall args do not match" - | HStailcall sig1 svos1 lsv1, HStailcall sig2 svos2 lsv2 => - phys_check sig1 sig2 "sfval_simu_check: Stailcall different signatures";; - svos_simu_check svos1 svos2;; - phys_check lsv1 lsv2 "sfval_simu_check: Stailcall args do not match" - | HSbuiltin ef1 lbs1 br1 pc1, HSbuiltin ef2 lbs2 br2 pc2 => - revmap_check_single dm pc1 pc2;; - phys_check ef1 ef2 "sfval_simu_check: builtin ef do not match";; - phys_check br1 br2 "sfval_simu_check: builtin br do not match";; - list_builtin_arg_simu_check lbs1 lbs2 - | HSjumptable sv ln, HSjumptable sv' ln' => - revmap_check_list dm ln ln';; - phys_check sv sv' "sfval_simu_check: Sjumptable sval do not match" - | HSreturn osv1, HSreturn osv2 => - option_eq_check osv1 osv2 - | _, _ => FAILWITH "sfval_simu_check: structure mismatch" - end. - -Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := - hsistate_simu_check dm f (hinternal hst1) (hinternal hst2);; - sfval_simu_check dm f (hsi_pc hst1) (hsi_pc hst2) (hfinal hst1) (hfinal hst2). - -Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node): ?? unit := - let (pc2, pc1) := m in - (* creating the hash-consing tables *) - DO hC_sval <~ hCons hSVAL;; - DO hC_hlist_sval <~ hCons hLSVAL;; - DO hC_hsmem <~ hCons hSMEM;; - let hsexec := hsexec hC_sval.(hC) hC_hlist_sval.(hC) hC_hsmem.(hC) in - (* performing the hash-consed executions *) - DO hst1 <~ hsexec f pc1;; - DO hst2 <~ hsexec tf pc2;; - (* comparing the executions *) - hsstate_simu_check dm f hst1 hst2. - -Lemma simu_check_single_correct dm tf f pc1 pc2: - WHEN simu_check_single dm f tf (pc2, pc1) ~> _ THEN - sexec_simu dm f tf pc1 pc2. -Admitted. -Global Opaque simu_check_single. -Global Hint Resolve simu_check_single_correct: wlp. - -Fixpoint simu_check_rec (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) lm : ?? unit := - match lm with - | nil => RET tt - | m :: lm => - simu_check_single dm f tf m;; - simu_check_rec dm f tf lm - end. - -Lemma simu_check_rec_correct dm f tf lm: - WHEN simu_check_rec dm f tf lm ~> _ THEN - forall pc1 pc2, In (pc2, pc1) lm -> sexec_simu dm f tf pc1 pc2. -Proof. - induction lm; wlp_simplify. - match goal with - | X: (_,_) = (_,_) |- _ => inversion X; subst - end. - subst; eauto. -Qed. -Global Opaque simu_check_rec. -Global Hint Resolve simu_check_rec_correct: wlp. - -Definition imp_simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function): ?? unit := - simu_check_rec dm f tf (PTree.elements dm);; - println("simu_check OK!"). - -Local Hint Resolve PTree.elements_correct: core. -Lemma imp_simu_check_correct dm f tf: - WHEN imp_simu_check dm f tf ~> _ THEN - forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2. -Proof. - wlp_simplify. -Qed. -Global Opaque imp_simu_check. -Global Hint Resolve imp_simu_check_correct: wlp. - -Program Definition aux_simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function): ?? bool := - DO r <~ - (TRY - imp_simu_check dm f tf;; - RET true - CATCH_FAIL s, _ => - println ("simu_check_failure:" +; s);; - RET false - ENSURE (fun b => b=true -> forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2));; - RET (`r). -Obligation 1. - split; wlp_simplify. discriminate. -Qed. - -Lemma aux_simu_check_correct dm f tf: - WHEN aux_simu_check dm f tf ~> b THEN - b=true -> forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2. -Proof. - unfold aux_simu_check; wlp_simplify. - destruct exta; simpl; auto. -Qed. - -(* Coerce aux_simu_check into a pure function (this is a little unsafe like all oracles in CompCert). *) - -Import UnsafeImpure. - -Definition simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) : res unit := - match unsafe_coerce (aux_simu_check dm f tf) with - | Some true => OK tt - | _ => Error (msg "simu_check has failed") - end. - -Lemma simu_check_correct dm f tf: - simu_check dm f tf = OK tt -> - forall pc1 pc2, dm ! pc2 = Some pc1 -> - sexec_simu dm f tf pc1 pc2. -Proof. - unfold simu_check. - destruct (unsafe_coerce (aux_simu_check dm f tf)) as [[|]|] eqn:Hres; simpl; try discriminate. - intros; eapply aux_simu_check_correct; eauto. - eapply unsafe_coerce_not_really_correct; eauto. -Qed. \ No newline at end of file diff --git a/kvx/lib/RTLpathSE_theory.v b/kvx/lib/RTLpathSE_theory.v deleted file mode 100644 index 5002b7c5..00000000 --- a/kvx/lib/RTLpathSE_theory.v +++ /dev/null @@ -1,1778 +0,0 @@ -(* A theory of symbolic execution on RTLpath - -NB: an efficient implementation with hash-consing will be defined in RTLpathSE_impl.v - -*) - -Require Import Coqlib Maps Floats. -Require Import AST Integers Values Events Memory Globalenvs Smallstep. -Require Import Op Registers. -Require Import RTL RTLpath. -Require Import Errors Duplicate. - -Local Open Scope error_monad_scope. - -(* Enhanced from kvx/Asmblockgenproof.v *) -Ltac explore_hyp := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => (let EQ1 := fresh "EQ" in (destruct var eqn:EQ1; try discriminate)) - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - | [ H : Some _ = Some _ |- _ ] => inv H - | [ x : unit |- _ ] => destruct x - end. - -Ltac explore := explore_hyp; - repeat match goal with - | [ |- context[if ?b then _ else _] ] => (let EQ1 := fresh "IEQ" in destruct b eqn:EQ1) - | [ |- context[match ?m with | _ => _ end] ] => (let DEQ1 := fresh "DEQ" in destruct m eqn:DEQ1) - | [ |- context[match ?m as _ return _ with | _ => _ end]] => (let DREQ1 := fresh "DREQ" in destruct m eqn:DREQ1) - end. - -(* Ltac explore := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => (let EQ1 := fresh "EQ" in (destruct var eqn:EQ1; try discriminate)) - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => (let EQ1 := fresh "IEQ" in destruct b eqn:EQ1) - | [ |- context[match ?m with | _ => _ end] ] => (let DEQ1 := fresh "DEQ" in destruct m eqn:DEQ1) - | [ |- context[match ?m as _ return _ with | _ => _ end]] => (let DREQ1 := fresh "DREQ" in destruct m eqn:DREQ1) - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - | [ H : Some _ = Some _ |- _ ] => inv H - | [ x : unit |- _ ] => destruct x - end. *) - -(** * Syntax and semantics of symbolic values *) - -(* symbolic value *) -Inductive sval := - | Sinput (r: reg) - | Sop (op:operation) (lsv: list_sval) (sm: smem) - | Sload (sm: smem) (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) (lsv:list_sval) -with list_sval := - | Snil - | Scons (sv: sval) (lsv: list_sval) -(* symbolic memory *) -with smem := - | Sinit - | Sstore (sm: smem) (chunk:memory_chunk) (addr:addressing) (lsv:list_sval) (srce: sval). - -Scheme sval_mut := Induction for sval Sort Prop -with list_sval_mut := Induction for list_sval Sort Prop -with smem_mut := Induction for smem Sort Prop. - -Fixpoint list_sval_inj (l: list sval): list_sval := - match l with - | nil => Snil - | v::l => Scons v (list_sval_inj l) - end. - -Local Open Scope option_monad_scope. - -Fixpoint seval_sval (ge: RTL.genv) (sp:val) (sv: sval) (rs0: regset) (m0: mem): option val := - match sv with - | Sinput r => Some (rs0#r) - | Sop op l sm => - SOME args <- seval_list_sval ge sp l rs0 m0 IN - SOME m <- seval_smem ge sp sm rs0 m0 IN - eval_operation ge sp op args m - | Sload sm trap chunk addr lsv => - match trap with - | TRAP => - SOME args <- seval_list_sval ge sp lsv rs0 m0 IN - SOME a <- eval_addressing ge sp addr args IN - SOME m <- seval_smem ge sp sm rs0 m0 IN - Mem.loadv chunk m a - | NOTRAP => - SOME args <- seval_list_sval ge sp lsv rs0 m0 IN - match (eval_addressing ge sp addr args) with - | None => Some (default_notrap_load_value chunk) - | Some a => - SOME m <- seval_smem ge sp sm rs0 m0 IN - match (Mem.loadv chunk m a) with - | None => Some (default_notrap_load_value chunk) - | Some val => Some val - end - end - end - end -with seval_list_sval (ge: RTL.genv) (sp:val) (lsv: list_sval) (rs0: regset) (m0: mem): option (list val) := - match lsv with - | Snil => Some nil - | Scons sv lsv' => - SOME v <- seval_sval ge sp sv rs0 m0 IN - SOME lv <- seval_list_sval ge sp lsv' rs0 m0 IN - Some (v::lv) - end -with seval_smem (ge: RTL.genv) (sp:val) (sm: smem) (rs0: regset) (m0: mem): option mem := - match sm with - | Sinit => Some m0 - | Sstore sm chunk addr lsv srce => - SOME args <- seval_list_sval ge sp lsv rs0 m0 IN - SOME a <- eval_addressing ge sp addr args IN - SOME m <- seval_smem ge sp sm rs0 m0 IN - SOME sv <- seval_sval ge sp srce rs0 m0 IN - Mem.storev chunk m a sv - end. - -(* Syntax and Semantics of local symbolic internal states *) -(* [si_pre] is a precondition on initial ge, sp, rs0, m0 *) -Record sistate_local := { si_pre: RTL.genv -> val -> regset -> mem -> Prop; si_sreg: reg -> sval; si_smem: smem }. - -(* Predicate on which (rs, m) is a possible final state after evaluating [st] on (rs0, m0) *) -Definition ssem_local (ge: RTL.genv) (sp:val) (st: sistate_local) (rs0: regset) (m0: mem) (rs: regset) (m: mem): Prop := - st.(si_pre) ge sp rs0 m0 - /\ seval_smem ge sp st.(si_smem) rs0 m0 = Some m - /\ forall (r:reg), seval_sval ge sp (st.(si_sreg) r) rs0 m0 = Some (rs#r). - -Definition sabort_local (ge: RTL.genv) (sp:val) (st: sistate_local) (rs0: regset) (m0: mem): Prop := - ~(st.(si_pre) ge sp rs0 m0) - \/ seval_smem ge sp st.(si_smem) rs0 m0 = None - \/ exists (r: reg), seval_sval ge sp (st.(si_sreg) r) rs0 m0 = None. - -(* Syntax and semantics of symbolic exit states *) -Record sistate_exit := mk_sistate_exit - { si_cond: condition; si_scondargs: list_sval; si_elocal: sistate_local; si_ifso: node }. - -Definition seval_condition ge sp (cond: condition) (lsv: list_sval) (sm: smem) rs0 m0 : option bool := - SOME args <- seval_list_sval ge sp lsv rs0 m0 IN - SOME m <- seval_smem ge sp sm rs0 m0 IN - eval_condition cond args m. - -Definition all_fallthrough ge sp (lx: list sistate_exit) rs0 m0: Prop := - forall ext, List.In ext lx -> - seval_condition ge sp ext.(si_cond) ext.(si_scondargs) ext.(si_elocal).(si_smem) rs0 m0 = Some false. - -Lemma all_fallthrough_revcons ge sp ext rs m lx: - all_fallthrough ge sp (ext::lx) rs m -> - seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs m = Some false - /\ all_fallthrough ge sp lx rs m. -Proof. - intros ALLFU. constructor. - - assert (In ext (ext::lx)) by (constructor; auto). apply ALLFU in H. assumption. - - intros ext' INEXT. assert (In ext' (ext::lx)) by (apply in_cons; auto). - apply ALLFU in H. assumption. -Qed. - -(** Semantic of an exit in pseudo code: - if si_cond (si_condargs) - si_elocal; goto if_so - else () -*) - -Definition ssem_exit (ge: RTL.genv) (sp: val) (ext: sistate_exit) (rs: regset) (m: mem) rs' m' (pc': node) : Prop := - seval_condition ge sp (si_cond ext) (si_scondargs ext) ext.(si_elocal).(si_smem) rs m = Some true - /\ ssem_local ge sp (si_elocal ext) rs m rs' m' - /\ (si_ifso ext) = pc'. - -(* Either an abort on the condition evaluation OR an abort on the sistate_local IF the condition was true *) -Definition sabort_exit (ge: RTL.genv) (sp: val) (ext: sistate_exit) (rs: regset) (m: mem) : Prop := - let sev_cond := seval_condition ge sp (si_cond ext) (si_scondargs ext) ext.(si_elocal).(si_smem) rs m in - sev_cond = None - \/ (sev_cond = Some true /\ sabort_local ge sp ext.(si_elocal) rs m). - -(** * Syntax and Semantics of symbolic internal state *) -Record sistate := { si_pc: node; si_exits: list sistate_exit; si_local: sistate_local }. - -Definition all_fallthrough_upto_exit ge sp ext lx' lx rs m : Prop := - is_tail (ext::lx') lx /\ all_fallthrough ge sp lx' rs m. - -(** Semantic of a sistate in pseudo code: - si_exit1; si_exit2; ...; si_exitn; - si_local; goto si_pc *) - -(* Note: in RTLpath, is.(icontinue) = false iff we took an early exit *) - -Definition ssem_internal (ge: RTL.genv) (sp:val) (st: sistate) (rs: regset) (m: mem) (is: istate): Prop := - if (is.(icontinue)) - then - ssem_local ge sp st.(si_local) rs m is.(irs) is.(imem) - /\ st.(si_pc) = is.(ipc) - /\ all_fallthrough ge sp st.(si_exits) rs m - else exists ext lx, - ssem_exit ge sp ext rs m is.(irs) is.(imem) is.(ipc) - /\ all_fallthrough_upto_exit ge sp ext lx st.(si_exits) rs m. - -Definition sabort (ge: RTL.genv) (sp: val) (st: sistate) (rs: regset) (m: mem): Prop := - (* No early exit was met but we aborted on the si_local *) - (all_fallthrough ge sp st.(si_exits) rs m /\ sabort_local ge sp st.(si_local) rs m) - (* OR we aborted on an evaluation of one of the early exits *) - \/ (exists ext lx, all_fallthrough_upto_exit ge sp ext lx st.(si_exits) rs m /\ sabort_exit ge sp ext rs m). - -Definition ssem_internal_opt ge sp (st: sistate) rs0 m0 (ois: option istate): Prop := - match ois with - | Some is => ssem_internal ge sp st rs0 m0 is - | None => sabort ge sp st rs0 m0 - end. - -Definition ssem_internal_opt2 ge sp (ost: option sistate) rs0 m0 (ois: option istate) : Prop := - match ost with - | Some st => ssem_internal_opt ge sp st rs0 m0 ois - | None => ois=None - end. - -(** * An internal state represents a parallel program ! - - We prove below that the semantics [ssem_internal_opt] is deterministic. - - *) - -Definition istate_eq ist1 ist2 := - ist1.(icontinue) = ist2.(icontinue) /\ - ist1.(ipc) = ist2.(ipc) /\ - (forall r, (ist1.(irs)#r) = ist2.(irs)#r) /\ - ist1.(imem) = ist2.(imem). - -Lemma all_fallthrough_noexit ge sp ext lx rs0 m0 rs m pc: - ssem_exit ge sp ext rs0 m0 rs m pc -> - In ext lx -> - all_fallthrough ge sp lx rs0 m0 -> - False. -Proof. - Local Hint Resolve is_tail_in: core. - intros SSEM INE ALLF. - destruct SSEM as (SSEM & SSEM'). - unfold all_fallthrough in ALLF. rewrite ALLF in SSEM; eauto. - discriminate. -Qed. - -Lemma ssem_internal_exclude_incompatible_continue ge sp st rs m is1 is2: - is1.(icontinue) = true -> - is2.(icontinue) = false -> - ssem_internal ge sp st rs m is1 -> - ssem_internal ge sp st rs m is2 -> - False. -Proof. - Local Hint Resolve all_fallthrough_noexit: core. - unfold ssem_internal. - intros CONT1 CONT2. - rewrite CONT1, CONT2; simpl. - intuition eauto. - destruct H0 as (ext & lx & SSEME & ALLFU). - destruct ALLFU as (ALLFU & ALLFU'). - eapply all_fallthrough_noexit; eauto. -Qed. - -Lemma ssem_internal_determ_continue ge sp st rs m is1 is2: - ssem_internal ge sp st rs m is1 -> - ssem_internal ge sp st rs m is2 -> - is1.(icontinue) = is2.(icontinue). -Proof. - Local Hint Resolve ssem_internal_exclude_incompatible_continue: core. - destruct (Bool.bool_dec is1.(icontinue) is2.(icontinue)) as [|H]; auto. - intros H1 H2. assert (absurd: False); intuition. - destruct (icontinue is1) eqn: His1, (icontinue is2) eqn: His2; eauto. -Qed. - -Lemma ssem_local_determ ge sp st rs0 m0 rs1 m1 rs2 m2: - ssem_local ge sp st rs0 m0 rs1 m1 -> - ssem_local ge sp st rs0 m0 rs2 m2 -> - (forall r, rs1#r = rs2#r) /\ m1 = m2. -Proof. - unfold ssem_local. intuition try congruence. - generalize (H5 r); rewrite H4; congruence. -Qed. - -(* TODO: lemma to move in Coqlib *) -Lemma is_tail_bounded_total {A} (l1 l2 l3: list A): is_tail l1 l3 -> is_tail l2 l3 - -> is_tail l1 l2 \/ is_tail l2 l1. -Proof. - Local Hint Resolve is_tail_cons: core. - induction 1 as [|i l1 l3 T1 IND]; simpl; auto. - intros T2; inversion T2; subst; auto. -Qed. - -Lemma exit_cond_determ ge sp rs0 m0 l1 l2: - is_tail l1 l2 -> forall ext1 lx1 ext2 lx2, - l1=(ext1 :: lx1) -> - l2=(ext2 :: lx2) -> - all_fallthrough ge sp lx1 rs0 m0 -> - seval_condition ge sp (si_cond ext1) (si_scondargs ext1) (si_smem (si_elocal ext1)) rs0 m0 = Some true -> - all_fallthrough ge sp lx2 rs0 m0 -> - ext1=ext2. -Proof. - destruct 1 as [l1|i l1 l3 T1]; intros ext1 lx1 ext2 lx2 EQ1 EQ2; subst; - inversion EQ2; subst; auto. - intros D1 EVAL NYE. - Local Hint Resolve is_tail_in: core. - unfold all_fallthrough in NYE. - rewrite NYE in EVAL; eauto. - try congruence. -Qed. - -Lemma ssem_exit_determ ge sp ext rs0 m0 rs1 m1 pc1 rs2 m2 pc2: - ssem_exit ge sp ext rs0 m0 rs1 m1 pc1 -> - ssem_exit ge sp ext rs0 m0 rs2 m2 pc2 -> - pc1 = pc2 /\ (forall r, rs1#r = rs2#r) /\ m1 = m2. -Proof. - Local Hint Resolve exit_cond_determ eq_sym: core. - intros SSEM1 SSEM2. destruct SSEM1 as (SEVAL1 & SLOC1 & PCEQ1). destruct SSEM2 as (SEVAL2 & SLOC2 & PCEQ2). subst. - destruct (ssem_local_determ ge sp (si_elocal ext) rs0 m0 rs1 m1 rs2 m2); auto. -Qed. - -Remark is_tail_inv_left {A: Type} (a a': A) l l': - is_tail (a::l) (a'::l') -> - (a = a' /\ l = l') \/ (In a l' /\ is_tail l (a'::l')). -Proof. - intros. inv H. - - left. eauto. - - right. econstructor. - + eapply is_tail_in; eauto. - + eapply is_tail_cons_left; eauto. -Qed. - -Lemma ssem_internal_determ ge sp st rs m is1 is2: - ssem_internal ge sp st rs m is1 -> - ssem_internal ge sp st rs m is2 -> - istate_eq is1 is2. -Proof. - unfold istate_eq. - intros SEM1 SEM2. - exploit (ssem_internal_determ_continue ge sp st rs m is1 is2); eauto. - intros CONTEQ. unfold ssem_internal in * |-. rewrite CONTEQ in * |- *. - destruct (icontinue is2). - - destruct (ssem_local_determ ge sp (si_local st) rs m (irs is1) (imem is1) (irs is2) (imem is2)); - intuition (try congruence). - - destruct SEM1 as (ext1 & lx1 & SSEME1 & ALLFU1). destruct SEM2 as (ext2 & lx2 & SSEME2 & ALLFU2). - destruct ALLFU1 as (ALLFU1 & ALLFU1'). destruct ALLFU2 as (ALLFU2 & ALLFU2'). - destruct SSEME1 as (SSEME1 & SSEME1' & SSEME1''). destruct SSEME2 as (SSEME2 & SSEME2' & SSEME2''). - assert (X:ext1=ext2). - { destruct (is_tail_bounded_total (ext1 :: lx1) (ext2 :: lx2) (si_exits st)) as [TAIL|TAIL]; eauto. } - subst. destruct (ssem_local_determ ge sp (si_elocal ext2) rs m (irs is1) (imem is1) (irs is2) (imem is2)); auto. - intuition. congruence. -Qed. - -Lemma ssem_local_exclude_sabort_local ge sp loc rs m rs' m': - ssem_local ge sp loc rs m rs' m' -> -(* all_fallthrough ge sp (si_exits st) rs m -> *) - sabort_local ge sp loc rs m -> - False. -Proof. - intros SIML (* ALLF *) ABORT. inv SIML. destruct H0 as (H0 & H0'). - inversion ABORT as [ABORT1 | [ABORT2 | ABORT3]]; [ | | inv ABORT3]; congruence. -Qed. - -(* TODO: remove this JUNK ? -Lemma ssem_local_exclude_sabort_exit ge sp st ext lx rs m rs' m': - ssem_local ge sp (si_local st) rs m rs' m' -> - all_fallthrough ge sp (si_exits st) rs m -> - is_tail (ext :: lx) (si_exits st) -> - sabort_exit ge sp ext rs m -> - False. -Proof. - intros SSEML ALLF TAIL ABORT. - inv ABORT. - - exploit ALLF; eauto. congruence. - - (* FIXME Problem : if we have a ssem_local, this means we ONLY evaluated the conditions, - but we NEVER actually evaluated the si_elocal from the sistate_exit ! So we cannot prove - a lack of abort on the si_elocal.. We must change the definitions *) -Abort. -*) - -Lemma ssem_local_exclude_sabort ge sp st rs m rs' m': - ssem_local ge sp (si_local st) rs m rs' m' -> - all_fallthrough ge sp (si_exits st) rs m -> - sabort ge sp st rs m -> - False. -Proof. - intros SIML ALLF ABORT. - inv ABORT. - - intuition; eapply ssem_local_exclude_sabort_local; eauto. - - destruct H as (ext & lx & ALLFU & SABORT). - destruct ALLFU as (TAIL & _). eapply is_tail_in in TAIL. - eapply ALLF in TAIL. - destruct SABORT as [CONDFAIL | (CONDTRUE & ABORTL)]; congruence. -Qed. - -Lemma ssem_exit_fallthrough_upto_exit ge sp ext ext' lx lx' exits rs m rs' m' pc': - ssem_exit ge sp ext rs m rs' m' pc' -> - all_fallthrough_upto_exit ge sp ext lx exits rs m -> - all_fallthrough_upto_exit ge sp ext' lx' exits rs m -> - is_tail (ext'::lx') (ext::lx). -Proof. - intros SSEME ALLFU ALLFU'. - destruct ALLFU as (ISTAIL & ALLFU). destruct ALLFU' as (ISTAIL' & ALLFU'). - destruct (is_tail_bounded_total (ext::lx) (ext'::lx') exits); eauto. - inv H. - - econstructor; eauto. - - eapply is_tail_in in H2. eapply ALLFU' in H2. - destruct SSEME as (SEVAL & _). congruence. -Qed. - -Lemma ssem_exit_exclude_sabort_exit ge sp ext rs m rs' m' pc': - ssem_exit ge sp ext rs m rs' m' pc' -> - sabort_exit ge sp ext rs m -> - False. -Proof. - intros A B. destruct A as (A & A' & A''). inv B. - - congruence. - - destruct H as (_ & H). eapply ssem_local_exclude_sabort_local; eauto. -Qed. - -Lemma ssem_exit_exclude_sabort ge sp ext st lx rs m rs' m' pc': - ssem_exit ge sp ext rs m rs' m' pc' -> - all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs m -> - sabort ge sp st rs m -> - False. -Proof. - intros SSEM ALLFU ABORT. - inv ABORT. - - destruct H as (ALLF & _). destruct ALLFU as (TAIL & _). - eapply is_tail_in in TAIL. - destruct SSEM as (SEVAL & _ & _). - eapply ALLF in TAIL. congruence. - - destruct H as (ext' & lx' & ALLFU' & ABORT). - exploit ssem_exit_fallthrough_upto_exit; eauto. intros ITAIL. - destruct ALLFU as (ALLFU1 & ALLFU2). destruct ALLFU' as (ALLFU1' & ALLFU2'). - exploit (is_tail_inv_left ext' ext lx' lx); eauto. intro. inv H. - + inv H0. eapply ssem_exit_exclude_sabort_exit; eauto. - + destruct H0 as (INE & TAIL). eapply ALLFU2 in INE. destruct ABORT as [ABORT | (ABORT & ABORT')]; congruence. -Qed. - -Lemma ssem_internal_exclude_sabort ge sp st rs m is: - sabort ge sp st rs m -> - ssem_internal ge sp st rs m is -> False. -Proof. - intros ABORT SEM. - unfold ssem_internal in SEM. destruct icontinue. - - destruct SEM as (SEM1 & SEM2 & SEM3). - eapply ssem_local_exclude_sabort; eauto. - - destruct SEM as (ext & lx & SEM1 & SEM2). eapply ssem_exit_exclude_sabort; eauto. -Qed. - -Definition istate_eq_opt ist1 oist := - exists ist2, oist = Some ist2 /\ istate_eq ist1 ist2. - -Lemma ssem_internal_opt_determ ge sp st rs m ois is: - ssem_internal_opt ge sp st rs m ois -> - ssem_internal ge sp st rs m is -> - istate_eq_opt is ois. -Proof. - destruct ois as [is1|]; simpl; eauto. - - intros; eexists; intuition; eapply ssem_internal_determ; eauto. - - intros; exploit ssem_internal_exclude_sabort; eauto. destruct 1. -Qed. - -(** * Symbolic execution of one internal step *) - -Definition slocal_set_sreg (st:sistate_local) (r:reg) (sv:sval) := - {| si_pre:=(fun ge sp rs m => seval_sval ge sp (st.(si_sreg) r) rs m <> None /\ (st.(si_pre) ge sp rs m)); - si_sreg:=fun y => if Pos.eq_dec r y then sv else st.(si_sreg) y; - si_smem:= st.(si_smem)|}. - -Definition slocal_set_smem (st:sistate_local) (sm:smem) := - {| si_pre:=(fun ge sp rs m => seval_smem ge sp st.(si_smem) rs m <> None /\ (st.(si_pre) ge sp rs m)); - si_sreg:= st.(si_sreg); - si_smem:= sm |}. - -Definition sist_set_local (st: sistate) (pc: node) (nxt: sistate_local): sistate := - {| si_pc := pc; si_exits := st.(si_exits); si_local:= nxt |}. - - -Definition siexec_inst (i: instruction) (st: sistate): option sistate := - match i with - | Inop pc' => - Some (sist_set_local st pc' st.(si_local)) - | Iop op args dst pc' => - let prev := st.(si_local) in - let vargs := list_sval_inj (List.map prev.(si_sreg) args) in - let next := slocal_set_sreg prev dst (Sop op vargs prev.(si_smem)) in - Some (sist_set_local st pc' next) - | Iload trap chunk addr args dst pc' => - let prev := st.(si_local) in - let vargs := list_sval_inj (List.map prev.(si_sreg) args) in - let next := slocal_set_sreg prev dst (Sload prev.(si_smem) trap chunk addr vargs) in - Some (sist_set_local st pc' next) - | Istore chunk addr args src pc' => - let prev := st.(si_local) in - let vargs := list_sval_inj (List.map prev.(si_sreg) args) in - let next := slocal_set_smem prev (Sstore prev.(si_smem) chunk addr vargs (prev.(si_sreg) src)) in - Some (sist_set_local st pc' next) - | Icond cond args ifso ifnot _ => - let prev := st.(si_local) in - let vargs := list_sval_inj (List.map prev.(si_sreg) args) in - let ex := {| si_cond:=cond; si_scondargs:=vargs; si_elocal := prev; si_ifso := ifso |} in - Some {| si_pc := ifnot; si_exits := ex::st.(si_exits); si_local := prev |} - | _ => None (* TODO jumptable ? *) - end. - - -Lemma seval_list_sval_inj ge sp l rs0 m0 (sreg: reg -> sval) rs: - (forall r : reg, seval_sval ge sp (sreg r) rs0 m0 = Some (rs # r)) -> - seval_list_sval ge sp (list_sval_inj (map sreg l)) rs0 m0 = Some (rs ## l). -Proof. - intros H; induction l as [|r l]; simpl; auto. - inversion_SOME v. - inversion_SOME lv. - generalize (H r). - try_simplify_someHyps. -Qed. - -Lemma slocal_set_sreg_preserves_sabort_local ge sp st rs0 m0 r sv: - sabort_local ge sp st rs0 m0 -> - sabort_local ge sp (slocal_set_sreg st r sv) rs0 m0. -Proof. - unfold sabort_local. simpl; intuition. - destruct H as [r1 H]. destruct (Pos.eq_dec r r1) as [TEST|TEST] eqn: HTEST. - - subst; rewrite H; intuition. - - right. right. exists r1. rewrite HTEST. auto. -Qed. - -Lemma slocal_set_smem_preserves_sabort_local ge sp st rs0 m0 m: - sabort_local ge sp st rs0 m0 -> - sabort_local ge sp (slocal_set_smem st m) rs0 m0. -Proof. - unfold sabort_local. simpl; intuition. -Qed. - -Lemma all_fallthrough_upto_exit_cons ge sp ext lx ext' exits rs m: - all_fallthrough_upto_exit ge sp ext lx exits rs m -> - all_fallthrough_upto_exit ge sp ext lx (ext'::exits) rs m. -Proof. - intros. inv H. econstructor; eauto. -Qed. - -Lemma all_fallthrough_cons ge sp exits rs m ext: - all_fallthrough ge sp exits rs m -> - seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs m = Some false -> - all_fallthrough ge sp (ext::exits) rs m. -Proof. - intros. unfold all_fallthrough in *. intros. - inv H1; eauto. -Qed. - -Lemma siexec_inst_preserves_sabort i ge sp rs m st st': - siexec_inst i st = Some st' -> - sabort ge sp st rs m -> sabort ge sp st' rs m. -Proof. - intros SISTEP ABORT. - destruct i; simpl in SISTEP; try discriminate; inv SISTEP; unfold sabort; simpl. - (* NOP *) - * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. - - left. constructor; eauto. - - right. exists ext0, lx0. constructor; eauto. - (* OP *) - * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. - - left. constructor; eauto. eapply slocal_set_sreg_preserves_sabort_local; eauto. - - right. exists ext0, lx0. constructor; eauto. - (* LOAD *) - * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. - - left. constructor; eauto. eapply slocal_set_sreg_preserves_sabort_local; eauto. - - right. exists ext0, lx0. constructor; eauto. - (* STORE *) - * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. - - left. constructor; eauto. eapply slocal_set_smem_preserves_sabort_local; eauto. - - right. exists ext0, lx0. constructor; eauto. - (* COND *) - * remember ({| si_cond := _; si_scondargs := _; si_elocal := _; si_ifso := _ |}) as ext. - destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. - - destruct (seval_condition ge sp (si_cond ext) (si_scondargs ext) - (si_smem (si_elocal ext)) rs m) eqn:SEVAL; [destruct b|]. - (* case true *) - + right. exists ext, (si_exits st). - constructor. - ++ constructor. econstructor; eauto. eauto. - ++ unfold sabort_exit. right. constructor; eauto. - subst. simpl. eauto. - (* case false *) - + left. constructor; eauto. eapply all_fallthrough_cons; eauto. - (* case None *) - + right. exists ext, (si_exits st). constructor. - ++ constructor. econstructor; eauto. eauto. - ++ unfold sabort_exit. left. eauto. - - right. exists ext0, lx0. constructor; eauto. eapply all_fallthrough_upto_exit_cons; eauto. -Qed. - -Lemma siexec_inst_WF i st: - siexec_inst i st = None -> default_succ i = None. -Proof. - destruct i; simpl; unfold sist_set_local; simpl; congruence. -Qed. - -Lemma siexec_inst_default_succ i st st': - siexec_inst i st = Some st' -> default_succ i = Some (st'.(si_pc)). -Proof. - destruct i; simpl; unfold sist_set_local; simpl; try congruence; - intro H; inversion_clear H; simpl; auto. -Qed. - - -Lemma seval_list_sval_inj_not_none ge sp st rs0 m0 rs: forall l, - (forall r, List.In r l -> seval_sval ge sp (si_sreg (si_local st) r) rs0 m0 = Some rs # r) -> - seval_list_sval ge sp (list_sval_inj (map (si_sreg (si_local st)) l)) rs0 m0 = None -> - False. -Proof. - induction l. - - intros. simpl in H0. discriminate. - - intros ALLR. simpl. - inversion_SOME v. - + intro SVAL. inversion_SOME lv; [discriminate|]. - assert (forall r : reg, In r l -> seval_sval ge sp (si_sreg (si_local st) r) rs0 m0 = Some rs # r). - { intros r INR. eapply ALLR. right. assumption. } - intro SVALLIST. intro. eapply IHl; eauto. - + intros. exploit (ALLR a); [constructor; eauto|]. congruence. -Qed. - -Lemma siexec_inst_correct ge sp i st rs0 m0 rs m: - ssem_local ge sp st.(si_local) rs0 m0 rs m -> - all_fallthrough ge sp st.(si_exits) rs0 m0 -> - ssem_internal_opt2 ge sp (siexec_inst i st) rs0 m0 (istep ge i sp rs m). -Proof. - intros (PRE & MEM & REG) NYE. - destruct i; simpl; auto. - + (* Nop *) - constructor; [|constructor]; simpl; auto. - constructor; auto. - + (* Op *) - inversion_SOME v; intros OP; simpl. - - constructor; [|constructor]; simpl; auto. - constructor; simpl; auto. - * constructor; auto. congruence. - * constructor; auto. - intro r0. destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. - subst. rewrite Regmap.gss; simpl; auto. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. - - left. constructor; simpl; auto. - unfold sabort_local. right. right. - simpl. exists r. destruct (Pos.eq_dec r r); try congruence. - simpl. erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. - + (* LOAD *) - inversion_SOME a0; intro ADD. - { inversion_SOME v; intros LOAD; simpl. - - explore_destruct; unfold ssem_internal, ssem_local; simpl; intuition. - * unfold ssem_internal. simpl. constructor; [|constructor]; auto. - constructor; constructor; simpl; auto. congruence. intro r0. - destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. - subst; rewrite Regmap.gss; simpl. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. - * unfold ssem_internal. simpl. constructor; [|constructor]; auto. - constructor; constructor; simpl; auto. congruence. intro r0. - destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. - subst; rewrite Regmap.gss; simpl. - inversion_SOME args; intros ARGS; [|exploit seval_list_sval_inj_not_none; eauto; contradiction]. - exploit seval_list_sval_inj; eauto. intro ARGS'. erewrite ARGS in ARGS'. inv ARGS'. rewrite ADD. - inversion_SOME m2. intro SMEM. - assert (m = m2) by congruence. subst. rewrite LOAD. reflexivity. - - explore_destruct; unfold sabort, sabort_local; simpl. - * unfold sabort. simpl. left. constructor; auto. - right. right. exists r. simpl. destruct (Pos.eq_dec r r); try congruence. - simpl. erewrite seval_list_sval_inj; simpl; auto. - rewrite ADD; simpl; auto. try_simplify_someHyps. - * unfold ssem_internal. simpl. constructor; [|constructor]; auto. - constructor; constructor; simpl; auto. congruence. intro r0. - destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. - subst; rewrite Regmap.gss; simpl. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. intros SMEM SEVAL. - rewrite LOAD. reflexivity. - } { rewrite ADD. destruct t. - - simpl. left; eauto. simpl. econstructor; eauto. - right. right. simpl. exists r. destruct (Pos.eq_dec r r); [|contradiction]. - simpl. inversion_SOME args. intro SLS. - eapply seval_list_sval_inj in REG. rewrite REG in SLS. inv SLS. - rewrite ADD. reflexivity. - - simpl. constructor; [|constructor]; simpl; auto. - constructor; simpl; constructor; auto; [congruence|]. - intro r0. destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. - subst. simpl. rewrite Regmap.gss. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. intro SMEM. rewrite ADD. reflexivity. - } - + (* STORE *) - inversion_SOME a0; intros ADD. - { inversion_SOME m'; intros STORE; simpl. - - unfold ssem_internal, ssem_local; simpl; intuition. - * congruence. - * erewrite seval_list_sval_inj; simpl; auto. - erewrite REG. - try_simplify_someHyps. - - unfold sabort, sabort_local; simpl. - left. constructor; auto. right. left. - erewrite seval_list_sval_inj; simpl; auto. - erewrite REG. - try_simplify_someHyps. } - { unfold sabort, sabort_local; simpl. - left. constructor; auto. right. left. - erewrite seval_list_sval_inj; simpl; auto. - erewrite ADD; simpl; auto. } - + (* COND *) - Local Hint Resolve is_tail_refl: core. - Local Hint Unfold ssem_local: core. - inversion_SOME b; intros COND. - { destruct b; simpl; unfold ssem_internal, ssem_local; simpl. - - remember (mk_sistate_exit _ _ _ _) as ext. exists ext, (si_exits st). - constructor; constructor; subst; simpl; auto. - unfold seval_condition. subst; simpl. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. - - intuition. unfold all_fallthrough in * |- *. simpl. - intuition. subst. simpl. - unfold seval_condition. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. } - { unfold sabort. simpl. right. - remember (mk_sistate_exit _ _ _ _) as ext. exists ext, (si_exits st). - constructor; [constructor; subst; simpl; auto|]. - left. subst; simpl; auto. - unfold seval_condition. - erewrite seval_list_sval_inj; simpl; auto. - try_simplify_someHyps. } -Qed. - - -Lemma siexec_inst_correct_None ge sp i st rs0 m0 rs m: - ssem_local ge sp (st.(si_local)) rs0 m0 rs m -> - siexec_inst i st = None -> - istep ge i sp rs m = None. -Proof. - intros (PRE & MEM & REG). - destruct i; simpl; unfold sist_set_local, ssem_internal, ssem_local; simpl; try_simplify_someHyps. -Qed. - -(** * Symbolic execution of the internal steps of a path *) -Fixpoint siexec_path (path:nat) (f: function) (st: sistate): option sistate := - match path with - | O => Some st - | S p => - SOME i <- (fn_code f)!(st.(si_pc)) IN - SOME st1 <- siexec_inst i st IN - siexec_path p f st1 - end. - -Lemma siexec_inst_add_exits i st st': - siexec_inst i st = Some st' -> - ( si_exits st' = si_exits st \/ exists ext, si_exits st' = ext :: si_exits st ). -Proof. - destruct i; simpl; intro SISTEP; inversion_clear SISTEP; unfold siexec_inst; simpl; (discriminate || eauto). -Qed. - -Lemma siexec_inst_preserves_allfu ge sp ext lx rs0 m0 st st' i: - all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs0 m0 -> - siexec_inst i st = Some st' -> - all_fallthrough_upto_exit ge sp ext lx (si_exits st') rs0 m0. -Proof. - intros ALLFU SISTEP. destruct ALLFU as (ISTAIL & ALLF). - constructor; eauto. - destruct i; simpl in SISTEP; inversion_clear SISTEP; simpl; (discriminate || eauto). -Qed. - -Lemma siexec_path_correct_false ge sp f rs0 m0 st' is: - forall path, - is.(icontinue)=false -> - forall st, ssem_internal ge sp st rs0 m0 is -> - siexec_path path f st = Some st' -> - ssem_internal ge sp st' rs0 m0 is. -Proof. - induction path; simpl. - - intros. congruence. - - intros ICF st SSEM STEQ'. - destruct ((fn_code f) ! (si_pc st)) eqn:FIC; [|discriminate]. - destruct (siexec_inst _ _) eqn:SISTEP; [|discriminate]. - eapply IHpath. 3: eapply STEQ'. eauto. - unfold ssem_internal in SSEM. rewrite ICF in SSEM. - destruct SSEM as (ext & lx & SEXIT & ALLFU). - unfold ssem_internal. rewrite ICF. exists ext, lx. - constructor; auto. eapply siexec_inst_preserves_allfu; eauto. -Qed. - -Lemma siexec_path_preserves_sabort ge sp path f rs0 m0 st': forall st, - siexec_path path f st = Some st' -> - sabort ge sp st rs0 m0 -> sabort ge sp st' rs0 m0. -Proof. - Local Hint Resolve siexec_inst_preserves_sabort: core. - induction path; simpl. - + unfold sist_set_local; try_simplify_someHyps. - + intros st; inversion_SOME i. - inversion_SOME st1; eauto. -Qed. - -Lemma siexec_path_WF path f: forall st, - siexec_path path f st = None -> nth_default_succ (fn_code f) path st.(si_pc) = None. -Proof. - induction path; simpl. - + unfold sist_set_local. intuition congruence. - + intros st; destruct ((fn_code f) ! (si_pc st)); simpl; try tauto. - destruct (siexec_inst i st) as [st1|] eqn: Hst1; simpl. - - intros; erewrite siexec_inst_default_succ; eauto. - - intros; erewrite siexec_inst_WF; eauto. -Qed. - -Lemma siexec_path_default_succ path f st': forall st, - siexec_path path f st = Some st' -> nth_default_succ (fn_code f) path st.(si_pc) = Some st'.(si_pc). -Proof. - induction path; simpl. - + unfold sist_set_local. intros st H. inversion_clear H; simpl; try congruence. - + intros st; destruct ((fn_code f) ! (si_pc st)); simpl; try congruence. - destruct (siexec_inst i st) as [st1|] eqn: Hst1; simpl; try congruence. - intros; erewrite siexec_inst_default_succ; eauto. -Qed. - -Lemma siexec_path_correct_true ge sp path (f:function) rs0 m0: forall st is, - is.(icontinue)=true -> - ssem_internal ge sp st rs0 m0 is -> - nth_default_succ (fn_code f) path st.(si_pc) <> None -> - ssem_internal_opt2 ge sp (siexec_path path f st) rs0 m0 - (isteps ge path f sp is.(irs) is.(imem) is.(ipc)) - . -Proof. - Local Hint Resolve siexec_path_correct_false siexec_path_preserves_sabort siexec_path_WF: core. - induction path; simpl. - + intros st is CONT INV WF; - unfold ssem_internal, sist_set_local in * |- *; - try_simplify_someHyps. simpl. - destruct is; simpl in * |- *; subst; intuition auto. - + intros st is CONT; unfold ssem_internal at 1; rewrite CONT. - intros (LOCAL & PC & NYE) WF. - rewrite <- PC. - inversion_SOME i; intro Hi; rewrite Hi in WF |- *; simpl; auto. - exploit siexec_inst_correct; eauto. - inversion_SOME st1; intros Hst1; erewrite Hst1; simpl. - - inversion_SOME is1; intros His1;rewrite His1; simpl. - * destruct (icontinue is1) eqn:CONT1. - (* icontinue is0 = true *) - intros; eapply IHpath; eauto. - destruct i; simpl in * |- *; unfold sist_set_local in * |- *; try_simplify_someHyps. - (* icontinue is0 = false -> EARLY EXIT *) - destruct (siexec_path path f st1) as [st2|] eqn: Hst2; simpl; eauto. - destruct WF. erewrite siexec_inst_default_succ; eauto. - (* try_simplify_someHyps; eauto. *) - * destruct (siexec_path path f st1) as [st2|] eqn: Hst2; simpl; eauto. - - intros His1;rewrite His1; simpl; auto. -Qed. - -(** REM: in the following two unused lemmas *) - -Lemma siexec_path_right_assoc_decompose f path: forall st st', - siexec_path (S path) f st = Some st' -> - exists st0, siexec_path path f st = Some st0 /\ siexec_path 1%nat f st0 = Some st'. -Proof. - induction path; simpl; eauto. - intros st st'. - inversion_SOME i1. - inversion_SOME st1. - try_simplify_someHyps; eauto. -Qed. - -Lemma siexec_path_right_assoc_compose f path: forall st st0 st', - siexec_path path f st = Some st0 -> - siexec_path 1%nat f st0 = Some st' -> - siexec_path (S path) f st = Some st'. -Proof. - induction path. - + intros st st0 st' H. simpl in H. - try_simplify_someHyps; auto. - + intros st st0 st'. - assert (X:exists x, x=(S path)); eauto. - destruct X as [x X]. - intros H1 H2. rewrite <- X. - generalize H1; clear H1. simpl. - inversion_SOME i1. intros Hi1; rewrite Hi1. - inversion_SOME st1. intros Hst1; rewrite Hst1. - subst; eauto. -Qed. - -(** * Symbolic (final) value of a path *) -Inductive sfval := - | Snone - | Scall (sig:signature) (svos: sval + ident) (lsv:list_sval) (res:reg) (pc:node) - (* NB: [res] the return register is hard-wired ! Is it restrictive ? *) - | Stailcall: signature -> sval + ident -> list_sval -> sfval - | Sbuiltin (ef:external_function) (sargs: list (builtin_arg sval)) (res: builtin_res reg) (pc:node) - | Sjumptable (sv: sval) (tbl: list node) - | Sreturn: option sval -> sfval -. - -Definition sfind_function (pge: RTLpath.genv) (ge: RTL.genv) (sp: val) (svos : sval + ident) (rs0: regset) (m0: mem): option fundef := - match svos with - | inl sv => SOME v <- seval_sval ge sp sv rs0 m0 IN Genv.find_funct pge v - | inr symb => SOME b <- Genv.find_symbol pge symb IN Genv.find_funct_ptr pge b - end. - -Section SEVAL_BUILTIN_ARG. (* adapted from Events.v *) - -Variable ge: RTL.genv. -Variable sp: val. -Variable m: mem. -Variable rs0: regset. -Variable m0: mem. - -Inductive seval_builtin_arg: builtin_arg sval -> val -> Prop := - | seval_BA: forall x v, - seval_sval ge sp x rs0 m0 = Some v -> - seval_builtin_arg (BA x) v - | seval_BA_int: forall n, - seval_builtin_arg (BA_int n) (Vint n) - | seval_BA_long: forall n, - seval_builtin_arg (BA_long n) (Vlong n) - | seval_BA_float: forall n, - seval_builtin_arg (BA_float n) (Vfloat n) - | seval_BA_single: forall n, - seval_builtin_arg (BA_single n) (Vsingle n) - | seval_BA_loadstack: forall chunk ofs v, - Mem.loadv chunk m (Val.offset_ptr sp ofs) = Some v -> - seval_builtin_arg (BA_loadstack chunk ofs) v - | seval_BA_addrstack: forall ofs, - seval_builtin_arg (BA_addrstack ofs) (Val.offset_ptr sp ofs) - | seval_BA_loadglobal: forall chunk id ofs v, - Mem.loadv chunk m (Senv.symbol_address ge id ofs) = Some v -> - seval_builtin_arg (BA_loadglobal chunk id ofs) v - | seval_BA_addrglobal: forall id ofs, - seval_builtin_arg (BA_addrglobal id ofs) (Senv.symbol_address ge id ofs) - | seval_BA_splitlong: forall hi lo vhi vlo, - seval_builtin_arg hi vhi -> seval_builtin_arg lo vlo -> - seval_builtin_arg (BA_splitlong hi lo) (Val.longofwords vhi vlo) - | seval_BA_addptr: forall a1 a2 v1 v2, - seval_builtin_arg a1 v1 -> seval_builtin_arg a2 v2 -> - seval_builtin_arg (BA_addptr a1 a2) - (if Archi.ptr64 then Val.addl v1 v2 else Val.add v1 v2). - -Definition seval_builtin_args (al: list (builtin_arg sval)) (vl: list val) : Prop := - list_forall2 seval_builtin_arg al vl. - -Lemma seval_builtin_arg_determ: - forall a v, seval_builtin_arg a v -> forall v', seval_builtin_arg a v' -> v' = v. -Proof. - induction 1; intros v' EV; inv EV; try congruence. - f_equal; eauto. - apply IHseval_builtin_arg1 in H3. apply IHseval_builtin_arg2 in H5. subst; auto. -Qed. - -Lemma eval_builtin_args_determ: - forall al vl, seval_builtin_args al vl -> forall vl', seval_builtin_args al vl' -> vl' = vl. -Proof. - induction 1; intros v' EV; inv EV; f_equal; eauto using seval_builtin_arg_determ. -Qed. - -End SEVAL_BUILTIN_ARG. - -Inductive ssem_final (pge: RTLpath.genv) (ge: RTL.genv) (sp:val) (npc: node) stack (f: function) (rs0: regset) (m0: mem): sfval -> regset -> mem -> trace -> state -> Prop := - | exec_Snone rs m: - ssem_final pge ge sp npc stack f rs0 m0 Snone rs m E0 (State stack f sp npc rs m) - | exec_Scall rs m sig svos lsv args res pc fd: - sfind_function pge ge sp svos rs0 m0 = Some fd -> - funsig fd = sig -> - seval_list_sval ge sp lsv rs0 m0 = Some args -> - ssem_final pge ge sp npc stack f rs0 m0 (Scall sig svos lsv res pc) rs m - E0 (Callstate (Stackframe res f sp pc rs :: stack) fd args m) - | exec_Stailcall stk rs m sig svos args fd m' lsv: - sfind_function pge ge sp svos rs0 m0 = Some fd -> - funsig fd = sig -> - sp = Vptr stk Ptrofs.zero -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - seval_list_sval ge sp lsv rs0 m0 = Some args -> - ssem_final pge ge sp npc stack f rs0 m0 (Stailcall sig svos lsv) rs m - E0 (Callstate stack fd args m') - | exec_Sbuiltin m' rs m vres res pc t sargs ef vargs: - seval_builtin_args ge sp m rs0 m0 sargs vargs -> - external_call ef ge vargs m t vres m' -> - ssem_final pge ge sp npc stack f rs0 m0 (Sbuiltin ef sargs res pc) rs m - t (State stack f sp pc (regmap_setres res vres rs) m') - | exec_Sjumptable sv tbl pc' n rs m: - seval_sval ge sp sv rs0 m0 = Some (Vint n) -> - list_nth_z tbl (Int.unsigned n) = Some pc' -> - ssem_final pge ge sp npc stack f rs0 m0 (Sjumptable sv tbl) rs m - E0 (State stack f sp pc' rs m) - | exec_Sreturn stk osv rs m m' v: - sp = (Vptr stk Ptrofs.zero) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - match osv with Some sv => seval_sval ge sp sv rs0 m0 | None => Some Vundef end = Some v -> - ssem_final pge ge sp npc stack f rs0 m0 (Sreturn osv) rs m - E0 (Returnstate stack v m') -. - -Record sstate := { internal:> sistate; final: sfval }. - -Inductive ssem pge (ge: RTL.genv) (sp:val) (st: sstate) stack f (rs0: regset) (m0: mem): trace -> state -> Prop := - | ssem_early is: - is.(icontinue) = false -> - ssem_internal ge sp st rs0 m0 is -> - ssem pge ge sp st stack f rs0 m0 E0 (State stack f sp is.(ipc) is.(irs) is.(imem)) - | ssem_normal is t s: - is.(icontinue) = true -> - ssem_internal ge sp st rs0 m0 is -> - ssem_final pge ge sp st.(si_pc) stack f rs0 m0 st.(final) is.(irs) is.(imem) t s -> - ssem pge ge sp st stack f rs0 m0 t s - . - -(* NB: generic function that could be put into [AST] file *) -Fixpoint builtin_arg_map {A B} (f: A -> B) (arg: builtin_arg A) : builtin_arg B := - match arg with - | BA x => BA (f x) - | BA_int n => BA_int n - | BA_long n => BA_long n - | BA_float f => BA_float f - | BA_single s => BA_single s - | BA_loadstack chunk ptr => BA_loadstack chunk ptr - | BA_addrstack ptr => BA_addrstack ptr - | BA_loadglobal chunk id ptr => BA_loadglobal chunk id ptr - | BA_addrglobal id ptr => BA_addrglobal id ptr - | BA_splitlong ba1 ba2 => BA_splitlong (builtin_arg_map f ba1) (builtin_arg_map f ba2) - | BA_addptr ba1 ba2 => BA_addptr (builtin_arg_map f ba1) (builtin_arg_map f ba2) - end. - -Lemma seval_builtin_arg_correct ge sp rs m rs0 m0 sreg: forall arg varg, - (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> - eval_builtin_arg ge (fun r => rs # r) sp m arg varg -> - seval_builtin_arg ge sp m rs0 m0 (builtin_arg_map sreg arg) varg. -Proof. - induction arg. - all: try (intros varg SEVAL BARG; inv BARG; constructor; congruence). - - intros varg SEVAL BARG. inv BARG. simpl. constructor. - eapply IHarg1; eauto. eapply IHarg2; eauto. - - intros varg SEVAL BARG. inv BARG. simpl. constructor. - eapply IHarg1; eauto. eapply IHarg2; eauto. -Qed. - -Lemma seval_builtin_args_correct ge sp rs m rs0 m0 sreg args vargs: - (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> - eval_builtin_args ge (fun r => rs # r) sp m args vargs -> - seval_builtin_args ge sp m rs0 m0 (map (builtin_arg_map sreg) args) vargs. -Proof. - induction 2. - - constructor. - - simpl. constructor; [| assumption]. - eapply seval_builtin_arg_correct; eauto. -Qed. - -Lemma seval_builtin_arg_complete ge sp rs m rs0 m0 sreg: forall arg varg, - (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> - seval_builtin_arg ge sp m rs0 m0 (builtin_arg_map sreg arg) varg -> - eval_builtin_arg ge (fun r => rs # r) sp m arg varg. -Proof. - induction arg. - all: intros varg SEVAL BARG; try (inv BARG; constructor; congruence). - - inv BARG. rewrite SEVAL in H0. inv H0. constructor. - - inv BARG. simpl. constructor. - eapply IHarg1; eauto. eapply IHarg2; eauto. - - inv BARG. simpl. constructor. - eapply IHarg1; eauto. eapply IHarg2; eauto. -Qed. - -Lemma seval_builtin_args_complete ge sp rs m rs0 m0 sreg: forall args vargs, - (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> - seval_builtin_args ge sp m rs0 m0 (map (builtin_arg_map sreg) args) vargs -> - eval_builtin_args ge (fun r => rs # r) sp m args vargs. -Proof. - induction args. - - simpl. intros. inv H0. constructor. - - intros vargs SEVAL BARG. simpl in BARG. inv BARG. - constructor; [| eapply IHargs; eauto]. - eapply seval_builtin_arg_complete; eauto. -Qed. - -(** * Symbolic execution of final step *) -Definition sexec_final (i: instruction) (prev: sistate_local): sfval := - match i with - | Icall sig ros args res pc => - let svos := sum_left_map prev.(si_sreg) ros in - let sargs := list_sval_inj (List.map prev.(si_sreg) args) in - Scall sig svos sargs res pc - | Itailcall sig ros args => - let svos := sum_left_map prev.(si_sreg) ros in - let sargs := list_sval_inj (List.map prev.(si_sreg) args) in - Stailcall sig svos sargs - | Ibuiltin ef args res pc => - let sargs := List.map (builtin_arg_map prev.(si_sreg)) args in - Sbuiltin ef sargs res pc - | Ireturn or => - let sor := SOME r <- or IN Some (prev.(si_sreg) r) in - Sreturn sor - | Ijumptable reg tbl => - let sv := prev.(si_sreg) reg in - Sjumptable sv tbl - | _ => Snone - end. - -Lemma sexec_final_correct pge ge sp i (f:function) pc st stack rs0 m0 t rs m s: - (fn_code f) ! pc = Some i -> - pc = st.(si_pc) -> - ssem_local ge sp (si_local st) rs0 m0 rs m -> - path_last_step ge pge stack f sp pc rs m t s -> - siexec_inst i st = None -> - ssem_final pge ge sp pc stack f rs0 m0 (sexec_final i (si_local st)) rs m t s. -Proof. - intros PC1 PC2 (PRE&MEM®) LAST Hi. destruct LAST; subst; try_simplify_someHyps; simpl. - + (* Snone *) destruct i; simpl in Hi |- *; unfold sist_set_local in Hi; try congruence. - + (* Icall *) intros; eapply exec_Scall; auto. - - destruct ros; simpl in * |- *; auto. - rewrite REG; auto. - - erewrite seval_list_sval_inj; simpl; auto. - + (* Itailcall *) intros. eapply exec_Stailcall; auto. - - destruct ros; simpl in * |- *; auto. - rewrite REG; auto. - - erewrite seval_list_sval_inj; simpl; auto. - + (* Ibuiltin *) intros. eapply exec_Sbuiltin; eauto. - eapply seval_builtin_args_correct; eauto. - + (* Ijumptable *) intros. eapply exec_Sjumptable; eauto. congruence. - + (* Ireturn *) intros; eapply exec_Sreturn; simpl; eauto. - destruct or; simpl; auto. -Qed. - -Lemma sexec_final_complete i (f:function) pc st ge pge sp stack rs0 m0 t rs m s: - (fn_code f) ! pc = Some i -> - pc = st.(si_pc) -> - ssem_local ge sp (si_local st) rs0 m0 rs m -> - ssem_final pge ge sp pc stack f rs0 m0 (sexec_final i (si_local st)) rs m t s -> - siexec_inst i st = None -> - path_last_step ge pge stack f sp pc rs m t s. -Proof. - intros PC1 PC2 (PRE&MEM®) LAST HSIS. - destruct i as [ (* Inop *) | (* Iop *) | (* Iload *) | (* Istore *) - | (* Icall *) sig ros args res pc' - | (* Itailcall *) sig ros args - | (* Ibuiltin *) ef bargs br pc' - | (* Icond *) - | (* Ijumptable *) jr tbl - | (*Ireturn*) or]; - subst; try_simplify_someHyps; try (unfold sist_set_local in HSIS; try congruence); - inversion LAST; subst; clear LAST; simpl in * |- *. - + (* Icall *) - erewrite seval_list_sval_inj in * |- ; simpl; try_simplify_someHyps; auto. - intros; eapply exec_Icall; eauto. - destruct ros; simpl in * |- *; auto. - rewrite REG in * |- ; auto. - + (* Itailcall *) - intros HPC SMEM. erewrite seval_list_sval_inj in H10; auto. inv H10. - eapply exec_Itailcall; eauto. - destruct ros; simpl in * |- *; auto. - rewrite REG in * |- ; auto. - + (* Ibuiltin *) intros HPC SMEM. - eapply exec_Ibuiltin; eauto. - eapply seval_builtin_args_complete; eauto. - + (* Ijumptable *) intros HPC SMEM. - eapply exec_Ijumptable; eauto. - congruence. - + (* Ireturn *) - intros; subst. enough (v=regmap_optget or Vundef rs) as ->. - * eapply exec_Ireturn; eauto. - * intros; destruct or; simpl; congruence. -Qed. - -(** * Main function of the symbolic execution *) - -Definition init_sistate_local := {| si_pre:= fun _ _ _ _ => True; si_sreg:= fun r => Sinput r; si_smem:= Sinit |}. - -Definition init_sistate pc := {| si_pc:= pc; si_exits:=nil; si_local:= init_sistate_local |}. - -Lemma init_ssem_internal ge sp pc rs m: ssem_internal ge sp (init_sistate pc) rs m (mk_istate true pc rs m). -Proof. - unfold ssem_internal, ssem_local, all_fallthrough; simpl. intuition. -Qed. - -Definition sexec (f: function) (pc:node): option sstate := - SOME path <- (fn_path f)!pc IN - SOME st <- siexec_path path.(psize) f (init_sistate pc) IN - SOME i <- (fn_code f)!(st.(si_pc)) IN - Some (match siexec_inst i st with - | Some st' => {| internal := st'; final := Snone |} - | None => {| internal := st; final := sexec_final i st.(si_local) |} - end). - -Lemma final_node_path_simpl f path pc: - (fn_path f)!pc = Some path -> nth_default_succ_inst (fn_code f) path.(psize) pc <> None. -Proof. - intros; exploit final_node_path; eauto. - intros (i & NTH & DUM). - congruence. -Qed. - -Lemma symb_path_last_step i st st' ge pge stack (f:function) sp pc rs m t s: - (fn_code f) ! pc = Some i -> - pc = st.(si_pc) -> - siexec_inst i st = Some st' -> - path_last_step ge pge stack f sp pc rs m t s -> - exists mk_istate, - istep ge i sp rs m = Some mk_istate - /\ t = E0 - /\ s = (State stack f sp mk_istate.(ipc) mk_istate.(RTLpath.irs) mk_istate.(imem)). -Proof. - intros PC1 PC2 Hst' LAST; destruct LAST; subst; try_simplify_someHyps; simpl. -Qed. - -(* NB: each concrete execution can be executed on the symbolic state (produced from [sexec]) -(sexec is a correct over-approximation) -*) -Theorem sexec_correct f pc pge ge sp path stack rs m t s: - (fn_path f)!pc = Some path -> - path_step ge pge path.(psize) stack f sp rs m pc t s -> - exists st, sexec f pc = Some st /\ ssem pge ge sp st stack f rs m t s. -Proof. - Local Hint Resolve init_ssem_internal: core. - intros PATH STEP; unfold sexec; rewrite PATH; simpl. - lapply (final_node_path_simpl f path pc); eauto. intro WF. - exploit (siexec_path_correct_true ge sp path.(psize) f rs m (init_sistate pc) (mk_istate true pc rs m)); simpl; eauto. - { intros ABS. apply WF; unfold nth_default_succ_inst. rewrite ABS; auto. } - (destruct (nth_default_succ_inst (fn_code f) path.(psize) pc) as [i|] eqn: Hi; [clear WF|congruence]). - destruct STEP as [sti STEPS CONT|sti t s STEPS CONT LAST]; - (* intro Hst *) - (rewrite STEPS; unfold ssem_internal_opt2; destruct (siexec_path _ _ _) as [st|] eqn: Hst; try congruence); - (* intro SEM *) - (simpl; unfold ssem_internal; simpl; rewrite CONT; intro SEM); - (* intro Hi' *) - ( assert (Hi': (fn_code f) ! (si_pc st) = Some i); - [ unfold nth_default_succ_inst in Hi; - exploit siexec_path_default_succ; eauto; simpl; - intros DEF; rewrite DEF in Hi; auto - | clear Hi; rewrite Hi' ]); - (* eexists *) - (eexists; constructor; eauto). - - (* early *) - eapply ssem_early; eauto. - unfold ssem_internal; simpl; rewrite CONT. - destruct (siexec_inst i st) as [st'|] eqn: Hst'; simpl; eauto. - destruct SEM as (ext & lx & SEM & ALLFU). exists ext, lx. - constructor; auto. eapply siexec_inst_preserves_allfu; eauto. - - destruct SEM as (SEM & PC & HNYE). - destruct (siexec_inst i st) as [st'|] eqn: Hst'; simpl. - + (* normal on Snone *) - rewrite <- PC in LAST. - exploit symb_path_last_step; eauto; simpl. - intros (mk_istate & ISTEP & Ht & Hs); subst. - exploit siexec_inst_correct; eauto. simpl. - erewrite Hst', ISTEP; simpl. - clear LAST CONT STEPS PC SEM HNYE Hst Hi' Hst' ISTEP st sti i. - intro SEM; destruct (mk_istate.(icontinue)) eqn: CONT. - { (* icontinue mk_istate = true *) - eapply ssem_normal; simpl; eauto. - unfold ssem_internal in SEM. - rewrite CONT in SEM. - destruct SEM as (SEM & PC & HNYE). - rewrite <- PC. - eapply exec_Snone. } - { eapply ssem_early; eauto. } - + (* normal non-Snone instruction *) - eapply ssem_normal; eauto. - * unfold ssem_internal; simpl; rewrite CONT; intuition. - * simpl. eapply sexec_final_correct; eauto. - rewrite PC; auto. -Qed. - -(* TODO: déplacer les trucs sur equiv_stackframe dans RTLpath ? *) -Inductive equiv_stackframe: stackframe -> stackframe -> Prop := - | equiv_stackframe_intro res f sp pc rs1 rs2 - (EQUIV: forall r : positive, rs1 !! r = rs2 !! r): - equiv_stackframe (Stackframe res f sp pc rs1) (Stackframe res f sp pc rs2). - -Inductive equiv_state: state -> state -> Prop := - | State_equiv stack f sp pc rs1 m rs2 - (EQUIV: forall r, rs1#r = rs2#r): - equiv_state (State stack f sp pc rs1 m) (State stack f sp pc rs2 m) - | Call_equiv stk stk' f args m - (STACKS: list_forall2 equiv_stackframe stk stk'): - equiv_state (Callstate stk f args m) (Callstate stk' f args m) - | Return_equiv stk stk' v m - (STACKS: list_forall2 equiv_stackframe stk stk'): - equiv_state (Returnstate stk v m) (Returnstate stk' v m). - -Lemma equiv_stackframe_refl stf: equiv_stackframe stf stf. -Proof. - destruct stf. constructor; auto. -Qed. - -Lemma equiv_stack_refl stk: list_forall2 equiv_stackframe stk stk. -Proof. - Local Hint Resolve equiv_stackframe_refl: core. - induction stk; simpl; constructor; auto. -Qed. - -Lemma equiv_state_refl s: equiv_state s s. -Proof. - Local Hint Resolve equiv_stack_refl: core. - induction s; simpl; constructor; auto. -Qed. - -(* -Lemma equiv_stackframe_trans stf1 stf2 stf3: - equiv_stackframe stf1 stf2 -> equiv_stackframe stf2 stf3 -> equiv_stackframe stf1 stf3. -Proof. - destruct 1; intros EQ; inv EQ; try econstructor; eauto. - intros; eapply eq_trans; eauto. -Qed. - -Lemma equiv_stack_trans stk1 stk2: - list_forall2 equiv_stackframe stk1 stk2 -> - forall stk3, list_forall2 equiv_stackframe stk2 stk3 -> - list_forall2 equiv_stackframe stk1 stk3. -Proof. - Local Hint Resolve equiv_stackframe_trans. - induction 1; intros stk3 EQ; inv EQ; econstructor; eauto. -Qed. - -Lemma equiv_state_trans s1 s2 s3: equiv_state s1 s2 -> equiv_state s2 s3 -> equiv_state s1 s3. -Proof. - Local Hint Resolve equiv_stack_trans. - destruct 1; intros EQ; inv EQ; econstructor; eauto. - intros; eapply eq_trans; eauto. -Qed. -*) - -Lemma regmap_setres_eq (rs rs': regset) res vres: - (forall r, rs # r = rs' # r) -> - forall r, (regmap_setres res vres rs) # r = (regmap_setres res vres rs') # r. -Proof. - intros RSEQ r. destruct res; simpl; try congruence. - destruct (peq x r). - - subst. repeat (rewrite Regmap.gss). reflexivity. - - repeat (rewrite Regmap.gso); auto. -Qed. - -Lemma ssem_final_equiv pge ge sp (f:function) st sv stack rs0 m0 t rs1 rs2 m s: - ssem_final pge ge sp st stack f rs0 m0 sv rs1 m t s -> - (forall r, rs1#r = rs2#r) -> - exists s', equiv_state s s' /\ ssem_final pge ge sp st stack f rs0 m0 sv rs2 m t s'. -Proof. - Local Hint Resolve equiv_stack_refl: core. - destruct 1. - - (* Snone *) intros; eexists; econstructor. - + eapply State_equiv; eauto. - + eapply exec_Snone. - - (* Scall *) - intros; eexists; econstructor. - 2: { eapply exec_Scall; eauto. } - apply Call_equiv; auto. - repeat (constructor; auto). - - (* Stailcall *) - intros; eexists; econstructor; [| eapply exec_Stailcall; eauto]. - apply Call_equiv; auto. - - (* Sbuiltin *) - intros; eexists; econstructor; [| eapply exec_Sbuiltin; eauto]. - constructor. eapply regmap_setres_eq; eauto. - - (* Sjumptable *) - intros; eexists; econstructor; [| eapply exec_Sjumptable; eauto]. - constructor. assumption. - - (* Sreturn *) - intros; eexists; econstructor; [| eapply exec_Sreturn; eauto]. - eapply equiv_state_refl; eauto. -Qed. - -Lemma siexec_inst_early_exit_absurd i st st' ge sp rs m rs' m' pc': - siexec_inst i st = Some st' -> - (exists ext lx, ssem_exit ge sp ext rs m rs' m' pc' /\ - all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs m) -> - all_fallthrough ge sp (si_exits st') rs m -> - False. -Proof. - intros SIEXEC (ext & lx & SSEME & ALLFU) ALLF. destruct ALLFU as (TAIL & _). - exploit siexec_inst_add_exits; eauto. destruct 1 as [SIEQ | (ext0 & SIEQ)]. - - rewrite SIEQ in *. eapply all_fallthrough_noexit. eauto. 2: eapply ALLF. eapply is_tail_in. eassumption. - - rewrite SIEQ in *. eapply all_fallthrough_noexit. eauto. 2: eapply ALLF. eapply is_tail_in. - constructor. eassumption. -Qed. - -Lemma is_tail_false {A: Type}: forall (l: list A) a, is_tail (a::l) nil -> False. -Proof. - intros. eapply is_tail_incl in H. unfold incl in H. pose (H a). - assert (In a (a::l)) by (constructor; auto). assert (In a nil) by auto. apply in_nil in H1. - contradiction. -Qed. - -Lemma cons_eq_false {A: Type}: forall (l: list A) a, - a :: l = l -> False. -Proof. - induction l; intros. - - discriminate. - - inv H. apply IHl in H2. contradiction. -Qed. - -Lemma app_cons_nil_eq {A: Type}: forall l' l (a:A), - (l' ++ a :: nil) ++ l = l' ++ a::l. -Proof. - induction l'; intros. - - simpl. reflexivity. - - simpl. rewrite IHl'. reflexivity. -Qed. - -Lemma app_eq_false {A: Type}: forall l (l': list A) a, - l' ++ a :: l = l -> False. -Proof. - induction l; intros. - - apply app_eq_nil in H. destruct H as (_ & H). apply cons_eq_false in H. contradiction. - - destruct l' as [|a' l']. - + simpl in H. apply cons_eq_false in H. contradiction. - + rewrite <- app_comm_cons in H. inv H. - apply (IHl (l' ++ (a0 :: nil)) a). rewrite app_cons_nil_eq. assumption. -Qed. - -Lemma is_tail_false_gen {A: Type}: forall (l: list A) l' a, is_tail (l'++(a::l)) l -> False. -Proof. - induction l. - - intros. destruct l' as [|a' l']. - + simpl in H. apply is_tail_false in H. contradiction. - + rewrite <- app_comm_cons in H. apply is_tail_false in H. contradiction. - - intros. inv H. - + apply app_eq_false in H2. contradiction. - + apply (IHl (l' ++ (a0 :: nil)) a). rewrite app_cons_nil_eq. assumption. -Qed. - -Lemma is_tail_eq {A: Type}: forall (l l': list A), - is_tail l' l -> - is_tail l l' -> - l = l'. -Proof. - destruct l as [|a l]; intros l' ITAIL ITAIL'. - - destruct l' as [|i' l']; auto. apply is_tail_false in ITAIL. contradiction. - - inv ITAIL; auto. - destruct l' as [|i' l']. { apply is_tail_false in ITAIL'. contradiction. } - exploit is_tail_trans. eapply ITAIL'. eauto. intro ABSURD. - apply (is_tail_false_gen l nil a) in ABSURD. contradiction. -Qed. - -(* NB: each execution of a symbolic state (produced from [sexec]) represents a concrete execution - (sexec is exact). -*) -Theorem sexec_exact f pc pge ge sp path stack st rs m t s1: - (fn_path f)!pc = Some path -> - sexec f pc = Some st -> - ssem pge ge sp st stack f rs m t s1 -> - exists s2, path_step ge pge path.(psize) stack f sp rs m pc t s2 /\ - equiv_state s1 s2. -Proof. - Local Hint Resolve init_ssem_internal: core. - unfold sexec; intros PATH SSTEP SEM; rewrite PATH in SSTEP. - lapply (final_node_path_simpl f path pc); eauto. intro WF. - exploit (siexec_path_correct_true ge sp path.(psize) f rs m (init_sistate pc) (mk_istate true pc rs m)); simpl; eauto. - { intros ABS. apply WF; unfold nth_default_succ_inst. rewrite ABS; auto. } - (destruct (nth_default_succ_inst (fn_code f) path.(psize) pc) as [i|] eqn: Hi; [clear WF|congruence]). - unfold nth_default_succ_inst in Hi. - destruct (siexec_path path.(psize) f (init_sistate pc)) as [st0|] eqn: Hst0; simpl. - 2:{ (* absurd case *) - exploit siexec_path_WF; eauto. - simpl; intros NDS; rewrite NDS in Hi; congruence. } - exploit siexec_path_default_succ; eauto; simpl. - intros NDS; rewrite NDS in Hi. - rewrite Hi in SSTEP. - intros ISTEPS. try_simplify_someHyps. - destruct (siexec_inst i st0) as [st'|] eqn:Hst'; simpl. - + (* exit on Snone instruction *) - assert (SEM': t = E0 /\ exists is, ssem_internal ge sp st' rs m is - /\ s1 = (State stack f sp (if (icontinue is) then (si_pc st') else (ipc is)) (irs is) (imem is))). - { destruct SEM as [is CONT SEM|is t s CONT SEM1 SEM2]; simpl in * |- *. - - repeat (econstructor; eauto). - rewrite CONT; eauto. - - inversion SEM2. repeat (econstructor; eauto). - rewrite CONT; eauto. } - clear SEM; subst. destruct SEM' as [X (is & SEM & X')]; subst. - intros. - destruct (isteps ge (psize path) f sp rs m pc) as [is0|] eqn:RISTEPS; simpl in *. - * unfold ssem_internal in ISTEPS. destruct (icontinue is0) eqn: ICONT0. - ** (* icontinue is0=true: path_step by normal_exit *) - destruct ISTEPS as (SEMis0&H1&H2). - rewrite H1 in * |-. - exploit siexec_inst_correct; eauto. - rewrite Hst'; simpl. - intros; exploit ssem_internal_opt_determ; eauto. - destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). - eexists. econstructor 1. - *** eapply exec_normal_exit; eauto. - eapply exec_istate; eauto. - *** rewrite EQ1. - enough ((ipc st) = (if icontinue st then si_pc st' else ipc is)) as ->. - { rewrite EQ2, EQ4. eapply State_equiv; auto. } - destruct (icontinue st) eqn:ICONT; auto. - exploit siexec_inst_default_succ; eauto. - erewrite istep_normal_exit; eauto. - try_simplify_someHyps. - ** (* The concrete execution has not reached "i" => early exit *) - unfold ssem_internal in SEM. - destruct (icontinue is) eqn:ICONT. - { destruct SEM as (SEML & SIPC & ALLF). - exploit siexec_inst_early_exit_absurd; eauto. contradiction. } - - eexists. econstructor 1. - *** eapply exec_early_exit; eauto. - *** destruct ISTEPS as (ext & lx & SSEME & ALLFU). destruct SEM as (ext' & lx' & SSEME' & ALLFU'). - eapply siexec_inst_preserves_allfu in ALLFU; eauto. - exploit ssem_exit_fallthrough_upto_exit; eauto. - exploit ssem_exit_fallthrough_upto_exit. eapply SSEME. eapply ALLFU. eapply ALLFU'. - intros ITAIL ITAIL'. apply is_tail_eq in ITAIL; auto. clear ITAIL'. - inv ITAIL. exploit ssem_exit_determ. eapply SSEME. eapply SSEME'. intros (IPCEQ & IRSEQ & IMEMEQ). - rewrite <- IPCEQ. rewrite <- IMEMEQ. constructor. congruence. - * (* The concrete execution has not reached "i" => abort case *) - eapply siexec_inst_preserves_sabort in ISTEPS; eauto. - exploit ssem_internal_exclude_sabort; eauto. contradiction. - + destruct SEM as [is CONT SEM|is t s CONT SEM1 SEM2]; simpl in * |- *. - - (* early exit *) - intros. - exploit ssem_internal_opt_determ; eauto. - destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). - eexists. econstructor 1. - * eapply exec_early_exit; eauto. - * rewrite EQ2, EQ4; eapply State_equiv. auto. - - (* normal exit non-Snone instruction *) - intros. - exploit ssem_internal_opt_determ; eauto. - destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). - unfold ssem_internal in SEM1. - rewrite CONT in SEM1. destruct SEM1 as (SEM1 & PC0 & NYE0). - exploit ssem_final_equiv; eauto. - clear SEM2; destruct 1 as (s' & Ms' & SEM2). - rewrite ! EQ4 in * |-; clear EQ4. - rewrite ! EQ2 in * |-; clear EQ2. - exists s'; intuition. - eapply exec_normal_exit; eauto. - eapply sexec_final_complete; eauto. - * congruence. - * unfold ssem_local in * |- *. - destruct SEM1 as (A & B & C). constructor; [|constructor]; eauto. - intro r. congruence. - * congruence. -Qed. - -(** * Simulation of RTLpath code w.r.t symbolic execution *) - -Section SymbValPreserved. - -Variable ge ge': RTL.genv. - -Hypothesis symbols_preserved_RTL: forall s, Genv.find_symbol ge' s = Genv.find_symbol ge s. - -Hypothesis senv_preserved_RTL: Senv.equiv ge ge'. - -Lemma senv_find_symbol_preserved id: - Senv.find_symbol ge id = Senv.find_symbol ge' id. -Proof. - destruct senv_preserved_RTL as (A & B & C). congruence. -Qed. - -Lemma senv_symbol_address_preserved id ofs: - Senv.symbol_address ge id ofs = Senv.symbol_address ge' id ofs. -Proof. - unfold Senv.symbol_address. rewrite senv_find_symbol_preserved. - reflexivity. -Qed. - -Lemma seval_preserved sp sv rs0 m0: - seval_sval ge sp sv rs0 m0 = seval_sval ge' sp sv rs0 m0. -Proof. - Local Hint Resolve symbols_preserved_RTL: core. - induction sv using sval_mut with (P0 := fun lsv => seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv rs0 m0) - (P1 := fun sm => seval_smem ge sp sm rs0 m0 = seval_smem ge' sp sm rs0 m0); simpl; auto. - + rewrite IHsv; clear IHsv. destruct (seval_list_sval _ _ _ _); auto. - rewrite IHsv0; clear IHsv0. destruct (seval_smem _ _ _ _); auto. - erewrite eval_operation_preserved; eauto. - + rewrite IHsv0; clear IHsv0. destruct (seval_list_sval _ _ _ _); auto. - erewrite <- eval_addressing_preserved; eauto. - destruct (eval_addressing _ sp _ _); auto. - rewrite IHsv; auto. - + rewrite IHsv; clear IHsv. destruct (seval_sval _ _ _ _); auto. - rewrite IHsv0; auto. - + rewrite IHsv0; clear IHsv0. destruct (seval_list_sval _ _ _ _); auto. - erewrite <- eval_addressing_preserved; eauto. - destruct (eval_addressing _ sp _ _); auto. - rewrite IHsv; clear IHsv. destruct (seval_smem _ _ _ _); auto. - rewrite IHsv1; auto. -Qed. - -Lemma seval_builtin_arg_preserved sp m rs0 m0: - forall bs varg, - seval_builtin_arg ge sp m rs0 m0 bs varg -> - seval_builtin_arg ge' sp m rs0 m0 bs varg. -Proof. - induction 1. - all: try (constructor; auto). - - rewrite <- seval_preserved. assumption. - - rewrite <- senv_symbol_address_preserved. assumption. - - rewrite senv_symbol_address_preserved. eapply seval_BA_addrglobal. -Qed. - -Lemma seval_builtin_args_preserved sp m rs0 m0 lbs vargs: - seval_builtin_args ge sp m rs0 m0 lbs vargs -> - seval_builtin_args ge' sp m rs0 m0 lbs vargs. -Proof. - induction 1; constructor; eauto. - eapply seval_builtin_arg_preserved; auto. -Qed. - -Lemma list_sval_eval_preserved sp lsv rs0 m0: - seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv rs0 m0. -Proof. - induction lsv; simpl; auto. - rewrite seval_preserved. destruct (seval_sval _ _ _ _); auto. - rewrite IHlsv; auto. -Qed. - -Lemma smem_eval_preserved sp sm rs0 m0: - seval_smem ge sp sm rs0 m0 = seval_smem ge' sp sm rs0 m0. -Proof. - induction sm; simpl; auto. - rewrite list_sval_eval_preserved. destruct (seval_list_sval _ _ _ _); auto. - erewrite <- eval_addressing_preserved; eauto. - destruct (eval_addressing _ sp _ _); auto. - rewrite IHsm; clear IHsm. destruct (seval_smem _ _ _ _); auto. - rewrite seval_preserved; auto. -Qed. - -Lemma seval_condition_preserved sp cond lsv sm rs0 m0: - seval_condition ge sp cond lsv sm rs0 m0 = seval_condition ge' sp cond lsv sm rs0 m0. -Proof. - unfold seval_condition. - rewrite list_sval_eval_preserved. destruct (seval_list_sval _ _ _ _); auto. - rewrite smem_eval_preserved; auto. -Qed. - -End SymbValPreserved. - -Require Import RTLpathLivegen RTLpathLivegenproof. - -(** * DEFINITION OF SIMULATION BETWEEN (ABSTRACT) SYMBOLIC EXECUTIONS -*) - -Definition istate_simulive alive (srce: PTree.t node) (is1 is2: istate): Prop := - is1.(icontinue) = is2.(icontinue) - /\ eqlive_reg alive is1.(irs) is2.(irs) - /\ is1.(imem) = is2.(imem). - -Definition istate_simu f (srce: PTree.t node) is1 is2: Prop := - if is1.(icontinue) then - (* TODO: il faudra raffiner le (fun _ => True) si on veut autoriser l'oracle à - ajouter du "code mort" sur des registres non utilisés (loop invariant code motion à la David) - Typiquement, pour connaître la frame des registres vivants, il faudra faire une propagation en arrière - sur la dernière instruction du superblock. *) - istate_simulive (fun _ => True) srce is1 is2 - else - exists path, f.(fn_path)!(is1.(ipc)) = Some path - /\ istate_simulive (fun r => Regset.In r path.(input_regs)) srce is1 is2 - /\ srce!(is2.(ipc)) = Some is1.(ipc). - -Record simu_proof_context {f1: RTLpath.function} := { - liveness_hyps: liveness_ok_function f1; - the_ge1: RTL.genv; - the_ge2: RTL.genv; - genv_match: forall s, Genv.find_symbol the_ge1 s = Genv.find_symbol the_ge2 s; - the_sp: val; - the_rs0: regset; - the_m0: mem -}. -Arguments simu_proof_context: clear implicits. - -(* NOTE: a pure semantic definition on [sistate], for a total freedom in refinements *) -Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) (st1 st2: sistate) (ctx: simu_proof_context f): Prop := - forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) st1 (the_rs0 ctx) (the_m0 ctx) is1 -> - exists is2, ssem_internal (the_ge2 ctx) (the_sp ctx) st2 (the_rs0 ctx) (the_m0 ctx) is2 - /\ istate_simu f dm is1 is2. - -Definition opt_simu {A} (o1: option A) (o2: option A) := - o1 <> None -> o2 = o1. - -Lemma opt_simu_Some {A} (a:A) (o1: option A) (o2: option A): - opt_simu o1 o2 -> o1 = Some a -> o2 = Some a. -Proof. - unfold opt_simu. intros H1 H2; subst; rewrite H1; congruence. -Qed. - -Inductive svident_simu (f: RTLpath.function) (ctx: simu_proof_context f): (sval + ident) -> (sval + ident) -> Prop := - | Sleft_simu sv1 sv2: - opt_simu (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) - (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) - -> svident_simu f ctx (inl sv1) (inl sv2) - | Sright_simu id1 id2: - id1 = id2 - -> svident_simu f ctx (inr id1) (inr id2) - . - - -Fixpoint ptree_get_list (pt: PTree.t node) (lp: list positive) : option (list positive) := - match lp with - | nil => Some nil - | p1::lp => SOME p2 <- pt!p1 IN - SOME lp2 <- (ptree_get_list pt lp) IN - Some (p2 :: lp2) - end. - -Lemma ptree_get_list_nth dm p2: forall lp2 lp1, - ptree_get_list dm lp2 = Some lp1 -> - forall n, list_nth_z lp2 n = Some p2 -> - exists p1, - list_nth_z lp1 n = Some p1 /\ dm ! p2 = Some p1. -Proof. - induction lp2. - - simpl. intros. inv H. simpl in *. discriminate. - - intros lp1 PGL n LNZ. simpl in PGL. explore. - inv LNZ. destruct (zeq n 0) eqn:ZEQ. - + subst. inv H0. exists n0. simpl; constructor; auto. - + exploit IHlp2; eauto. intros (p1 & LNZ & DMEQ). - eexists. simpl. rewrite ZEQ. - constructor; eauto. -Qed. - -Lemma ptree_get_list_nth_rev dm p1: forall lp2 lp1, - ptree_get_list dm lp2 = Some lp1 -> - forall n, list_nth_z lp1 n = Some p1 -> - exists p2, - list_nth_z lp2 n = Some p2 /\ dm ! p2 = Some p1. -Proof. - induction lp2. - - simpl. intros. inv H. simpl in *. discriminate. - - intros lp1 PGL n LNZ. simpl in PGL. explore. - inv LNZ. destruct (zeq n 0) eqn:ZEQ. - + subst. inv H0. exists a. simpl; constructor; auto. - + exploit IHlp2; eauto. intros (p2 & LNZ & DMEQ). - eexists. simpl. rewrite ZEQ. - constructor; eauto. congruence. -Qed. - -(* NOTE: we need to mix semantical simulation and syntactic definition on [sfval] in order to abstract the [match_states] *) -Inductive sfval_simu (dm: PTree.t node) (f: RTLpath.function) (opc1 opc2: node) (ctx: simu_proof_context f): sfval -> sfval -> Prop := - | Snone_simu: - dm!opc2 = Some opc1 -> - sfval_simu dm f opc1 opc2 ctx Snone Snone - | Scall_simu sig svos1 svos2 lsv1 lsv2 res pc1 pc2: - dm!pc2 = Some pc1 -> - svident_simu f ctx svos1 svos2 -> - opt_simu (seval_list_sval (the_ge1 ctx) (the_sp ctx) lsv1 (the_rs0 ctx) (the_m0 ctx)) - (seval_list_sval (the_ge2 ctx) (the_sp ctx) lsv2 (the_rs0 ctx) (the_m0 ctx)) -> - sfval_simu dm f opc1 opc2 ctx (Scall sig svos1 lsv1 res pc1) (Scall sig svos2 lsv2 res pc2) - | Stailcall_simu sig svos1 svos2 lsv1 lsv2: - svident_simu f ctx svos1 svos2 -> - opt_simu (seval_list_sval (the_ge1 ctx) (the_sp ctx) lsv1 (the_rs0 ctx) (the_m0 ctx)) - (seval_list_sval (the_ge2 ctx) (the_sp ctx) lsv2 (the_rs0 ctx) (the_m0 ctx)) -> - sfval_simu dm f opc1 opc2 ctx (Stailcall sig svos1 lsv1) (Stailcall sig svos2 lsv2) - | Sbuiltin_simu ef lbs1 lbs2 br pc1 pc2: - dm!pc2 = Some pc1 -> - lbs1 = lbs2 -> (* FIXME: TOO STRONG *) - sfval_simu dm f opc1 opc2 ctx (Sbuiltin ef lbs1 br pc1) (Sbuiltin ef lbs2 br pc2) - | Sjumptable_simu sv1 sv2 lpc1 lpc2: - ptree_get_list dm lpc2 = Some lpc1 -> - opt_simu (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) - (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) -> - sfval_simu dm f opc1 opc2 ctx (Sjumptable sv1 lpc1) (Sjumptable sv2 lpc2) - | Sreturn_simu os: - sfval_simu dm f opc1 opc2 ctx (Sreturn os) (Sreturn os). - -Definition sstate_simu dm f (s1 s2: sstate) (ctx: simu_proof_context f): Prop := - sistate_simu dm f s1.(internal) s2.(internal) ctx - /\ sfval_simu dm f s1.(si_pc) s2.(si_pc) ctx s1.(final) s2.(final). - -Definition sexec_simu dm (f1 f2: RTLpath.function) pc1 pc2: Prop := - forall st1, sexec f1 pc1 = Some st1 -> - exists st2, sexec f2 pc2 = Some st2 /\ forall ctx, sstate_simu dm f1 st1 st2 ctx. - -(** Maybe it could be useful to develop a small theory here to help in decomposing the simulation test ? - -Here are intermediate definitions. - -*) - -Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := - forall is1, ssem_local (the_ge1 ctx) (the_sp ctx) sl1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) -> - exists is2, ssem_local (the_ge2 ctx) (the_sp ctx) sl2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) - /\ istate_simu f dm is1 is2. - -Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof_context f) (se1 se2: sistate_exit) := - (seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond se1) (si_scondargs se1) - (si_smem (si_elocal se1)) (the_rs0 ctx) (the_m0 ctx)) - = (seval_condition (the_ge2 ctx) (the_sp ctx) (si_cond se2) (si_scondargs se2) - (si_smem (si_elocal se2)) (the_rs0 ctx) (the_m0 ctx)) - /\ forall is1, - ssem_exit (the_ge1 ctx) (the_sp ctx) se1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) (ipc is1) -> - exists is2, - ssem_exit (the_ge2 ctx) (the_sp ctx) se2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) (ipc is2) - /\ istate_simu f dm is1 is2. - -Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := - list_forall2 (siexit_simu dm f ctx) lse1 lse2. - diff --git a/kvx/lib/RTLpathScheduler.v b/kvx/lib/RTLpathScheduler.v deleted file mode 100644 index b70c1685..00000000 --- a/kvx/lib/RTLpathScheduler.v +++ /dev/null @@ -1,333 +0,0 @@ -(** RTLpath Scheduling from an external oracle. - -This module is inspired from [Duplicate] and [Duplicateproof] - -*) - -Require Import AST Linking Values Maps Globalenvs Smallstep Registers. -Require Import Coqlib Maps Events Errors Op. -Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory RTLpathSE_impl_junk. - - -Notation "'ASSERT' A 'WITH' MSG 'IN' B" := (if A then B else Error (msg MSG)) - (at level 200, A at level 100, B at level 200) - : error_monad_scope. - -Local Open Scope error_monad_scope. -Local Open Scope positive_scope. - -(** External oracle returning the new RTLpath function and a mapping of new path_entries to old path_entries - -NB: the new RTLpath function is generated from the fn_code, the fn_entrypoint and the fn_path -It requires to check that the path structure is wf ! - -*) - -(* Returns: new code, new entrypoint, new pathmap, revmap - * Indeed, the entrypoint might not be the same if the entrypoint node is moved further down - * a path ; same reasoning for the pathmap *) -Axiom untrusted_scheduler: RTLpath.function -> code * node * path_map * (PTree.t node). - -Extract Constant untrusted_scheduler => "RTLpathScheduleraux.scheduler". - -Program Definition function_builder (tfr: RTL.function) (tpm: path_map) : - { r : res RTLpath.function | forall f', r = OK f' -> fn_RTL f' = tfr} := - match RTLpathLivegen.function_checker tfr tpm with - | false => Error (msg "In function_builder: (tfr, tpm) is not wellformed") - | true => OK {| fn_RTL := tfr; fn_path := tpm |} - end. -Next Obligation. - apply function_checker_path_entry. auto. -Defined. Next Obligation. - apply function_checker_wellformed_path_map. auto. -Defined. - -Definition entrypoint_check (dm: PTree.t node) (fr tfr: RTL.function) : res unit := - match dm ! (fn_entrypoint tfr) with - | None => Error (msg "No mapping for (entrypoint tfr)") - | Some etp => if (Pos.eq_dec (fn_entrypoint fr) etp) then OK tt - else Error (msg "Entrypoints do not match") - end. - -Lemma entrypoint_check_correct fr tfr dm: - entrypoint_check dm fr tfr = OK tt -> - dm ! (fn_entrypoint tfr) = Some (fn_entrypoint fr). -Proof. - unfold entrypoint_check. explore; try discriminate. congruence. -Qed. - -Definition path_entry_check_single (pm tpm: path_map) (m: node * node) := - let (pc2, pc1) := m in - match (tpm ! pc2) with - | None => Error (msg "pc2 isn't an entry of tpm") - | Some _ => - match (pm ! pc1) with - | None => Error (msg "pc1 isn't an entry of pm") - | Some _ => OK tt - end - end. - -Lemma path_entry_check_single_correct pm tpm pc1 pc2: - path_entry_check_single pm tpm (pc2, pc1) = OK tt -> - path_entry tpm pc2 /\ path_entry pm pc1. -Proof. - unfold path_entry_check_single. intro. explore. - constructor; congruence. -Qed. - -(* Inspired from Duplicate.verify_mapping_rec *) -Fixpoint path_entry_check_rec (pm tpm: path_map) lm := - match lm with - | nil => OK tt - | m :: lm => do u1 <- path_entry_check_single pm tpm m; - do u2 <- path_entry_check_rec pm tpm lm; - OK tt - end. - -Lemma path_entry_check_rec_correct pm tpm pc1 pc2: forall lm, - path_entry_check_rec pm tpm lm = OK tt -> - In (pc2, pc1) lm -> - path_entry tpm pc2 /\ path_entry pm pc1. -Proof. - induction lm. - - simpl. intuition. - - simpl. intros. explore. destruct H0. - + subst. eapply path_entry_check_single_correct; eauto. - + eapply IHlm; assumption. -Qed. - -Definition path_entry_check (dm: PTree.t node) (pm tpm: path_map) := path_entry_check_rec pm tpm (PTree.elements dm). - -Lemma path_entry_check_correct dm pm tpm: - path_entry_check dm pm tpm = OK tt -> - forall pc1 pc2, dm ! pc2 = Some pc1 -> - path_entry tpm pc2 /\ path_entry pm pc1. -Proof. - unfold path_entry_check. intros. eapply PTree.elements_correct in H0. - eapply path_entry_check_rec_correct; eassumption. -Qed. - -Definition function_equiv_checker (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) : res unit := - let pm := fn_path f in - let fr := fn_RTL f in - let tpm := fn_path tf in - let tfr := fn_RTL tf in - do _ <- entrypoint_check dm fr tfr; - do _ <- path_entry_check dm pm tpm; - do _ <- simu_check dm f tf; - OK tt. - -Lemma function_equiv_checker_entrypoint f tf dm: - function_equiv_checker dm f tf = OK tt -> - dm ! (fn_entrypoint tf) = Some (fn_entrypoint f). -Proof. - unfold function_equiv_checker. intros. explore. - eapply entrypoint_check_correct; eauto. -Qed. - -Lemma function_equiv_checker_pathentry1 f tf dm: - function_equiv_checker dm f tf = OK tt -> - forall pc1 pc2, dm ! pc2 = Some pc1 -> - path_entry (fn_path tf) pc2. -Proof. - unfold function_equiv_checker. intros. explore. - exploit path_entry_check_correct. eassumption. all: eauto. intuition. -Qed. - -Lemma function_equiv_checker_pathentry2 f tf dm: - function_equiv_checker dm f tf = OK tt -> - forall pc1 pc2, dm ! pc2 = Some pc1 -> - path_entry (fn_path f) pc1. -Proof. - unfold function_equiv_checker. intros. explore. - exploit path_entry_check_correct. eassumption. all: eauto. intuition. -Qed. - -Lemma function_equiv_checker_correct f tf dm: - function_equiv_checker dm f tf = OK tt -> - forall pc1 pc2, dm ! pc2 = Some pc1 -> - sexec_simu dm f tf pc1 pc2. -Proof. - unfold function_equiv_checker. intros. explore. - eapply simu_check_correct; eauto. -Qed. - -Definition verified_scheduler (f: RTLpath.function) : res (RTLpath.function * (PTree.t node)) := - let (tctetpm, dm) := untrusted_scheduler f in - let (tcte, tpm) := tctetpm in - let (tc, te) := tcte in - let tfr := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in - do tf <- proj1_sig (function_builder tfr tpm); - do tt <- function_equiv_checker dm f tf; -(* do _ <- injective_checker dm; *) - OK (tf, dm). - -Theorem verified_scheduler_correct f tf dm: - verified_scheduler f = OK (tf, dm) -> - fn_sig f = fn_sig tf - /\ fn_params f = fn_params tf - /\ fn_stacksize f = fn_stacksize tf - /\ dm ! (fn_entrypoint tf) = Some (fn_entrypoint f) - /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> path_entry (fn_path f) pc1) - /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> path_entry (fn_path tf) pc2) - /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2) -(* /\ is_injective dm *) -. -Proof. - intros VERIF. unfold verified_scheduler in VERIF. explore. - Local Hint Resolve function_equiv_checker_entrypoint - function_equiv_checker_pathentry1 function_equiv_checker_pathentry2 - function_equiv_checker_correct (* injective_checker_correct *): core. - destruct (function_builder _ _) as [res H]; simpl in * |- *; auto. - apply H in EQ2. rewrite EQ2. simpl. - repeat (constructor; eauto). - - exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. -Qed. - -Record match_function (dupmap: PTree.t node) (f1 f2: RTLpath.function): Prop := { - preserv_fnsig: fn_sig f1 = fn_sig f2; - preserv_fnparams: fn_params f1 = fn_params f2; - preserv_fnstacksize: fn_stacksize f1 = fn_stacksize f2; - preserv_entrypoint: dupmap!(f2.(fn_entrypoint)) = Some f1.(fn_entrypoint); - dupmap_path_entry1: forall pc1 pc2, dupmap!pc2 = Some pc1 -> path_entry (fn_path f1) pc1; - dupmap_path_entry2: forall pc1 pc2, dupmap!pc2 = Some pc1 -> path_entry (fn_path f2) pc2; - dupmap_correct: forall pc1 pc2, dupmap!pc2 = Some pc1 -> sexec_simu dupmap f1 f2 pc1 pc2; -(* dupmap_injective: is_injective dupmap *) -}. - -Program Definition transf_function (f: RTLpath.function): - { r : res RTLpath.function | forall f', r = OK f' -> exists dm, match_function dm f f'} := - match (verified_scheduler f) with - | Error e => Error e - | OK (tf, dm) => OK tf - end. -Next Obligation. - exploit verified_scheduler_correct; eauto. - intros (A & B & C & D & E & F & G (* & H *)). - exists dm. econstructor; eauto. -Defined. - -Theorem match_function_preserves f f' dm: - match_function dm f f' -> - fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'. -Proof. - intros. - destruct H as [SIG PARAM SIZE ENTRY CORRECT]. - intuition. -Qed. - -Definition transf_fundef (f: fundef) : res fundef := - transf_partial_fundef (fun f => proj1_sig (transf_function f)) f. - -Definition transf_program (p: program) : res program := - transform_partial_program transf_fundef p. - -(** * Preservation proof *) - -Local Notation ext alive := (fun r => Regset.In r alive). - -Inductive match_fundef: RTLpath.fundef -> RTLpath.fundef -> Prop := - | match_Internal dupmap f f': match_function dupmap f f' -> match_fundef (Internal f) (Internal f') - | match_External ef: match_fundef (External ef) (External ef). - -Inductive match_stackframes: stackframe -> stackframe -> Prop := - | match_stackframe_intro dupmap res f sp pc rs1 rs2 f' pc' path - (TRANSF: match_function dupmap f f') - (DUPLIC: dupmap!pc' = Some pc) - (LIVE: liveness_ok_function f) - (PATH: f.(fn_path)!pc = Some path) - (EQUIV: forall v, eqlive_reg (ext path.(input_regs)) (rs1 # res <- v) (rs2 # res <- v)): - match_stackframes (Stackframe res f sp pc rs1) (Stackframe res f' sp pc' rs2). - -Inductive match_states: state -> state -> Prop := - | match_states_intro dupmap st f sp pc rs1 rs2 m st' f' pc' path - (STACKS: list_forall2 match_stackframes st st') - (TRANSF: match_function dupmap f f') - (DUPLIC: dupmap!pc' = Some pc) - (LIVE: liveness_ok_function f) - (PATH: f.(fn_path)!pc = Some path) - (EQUIV: eqlive_reg (ext path.(input_regs)) rs1 rs2): - match_states (State st f sp pc rs1 m) (State st' f' sp pc' rs2 m) - | match_states_call st st' f f' args m - (STACKS: list_forall2 match_stackframes st st') - (TRANSF: match_fundef f f') - (LIVE: liveness_ok_fundef f): - match_states (Callstate st f args m) (Callstate st' f' args m) - | match_states_return st st' v m - (STACKS: list_forall2 match_stackframes st st'): - match_states (Returnstate st v m) (Returnstate st' v m). - -Lemma match_stackframes_equiv stf1 stf2 stf3: - match_stackframes stf1 stf2 -> equiv_stackframe stf2 stf3 -> match_stackframes stf1 stf3. -Proof. - destruct 1; intros EQ; inv EQ; try econstructor; eauto. - intros; eapply eqlive_reg_trans; eauto. - rewrite eqlive_reg_triv in * |-. - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - simpl; auto. -Qed. - -Lemma match_stack_equiv stk1 stk2: - list_forall2 match_stackframes stk1 stk2 -> - forall stk3, list_forall2 equiv_stackframe stk2 stk3 -> - list_forall2 match_stackframes stk1 stk3. -Proof. - Local Hint Resolve match_stackframes_equiv: core. - induction 1; intros stk3 EQ; inv EQ; econstructor; eauto. -Qed. - -Lemma match_states_equiv s1 s2 s3: match_states s1 s2 -> equiv_state s2 s3 -> match_states s1 s3. -Proof. - Local Hint Resolve match_stack_equiv: core. - destruct 1; intros EQ; inv EQ; econstructor; eauto. - intros; eapply eqlive_reg_triv_trans; eauto. -Qed. - -Lemma eqlive_match_stackframes stf1 stf2 stf3: - eqlive_stackframes stf1 stf2 -> match_stackframes stf2 stf3 -> match_stackframes stf1 stf3. -Proof. - destruct 1; intros MS; inv MS; try econstructor; eauto. - try_simplify_someHyps. intros; eapply eqlive_reg_trans; eauto. -Qed. - -Lemma eqlive_match_stack stk1 stk2: - list_forall2 eqlive_stackframes stk1 stk2 -> - forall stk3, list_forall2 match_stackframes stk2 stk3 -> - list_forall2 match_stackframes stk1 stk3. -Proof. - induction 1; intros stk3 MS; inv MS; econstructor; eauto. - eapply eqlive_match_stackframes; eauto. -Qed. - -Lemma eqlive_match_states s1 s2 s3: eqlive_states s1 s2 -> match_states s2 s3 -> match_states s1 s3. -Proof. - Local Hint Resolve eqlive_match_stack: core. - destruct 1; intros MS; inv MS; try_simplify_someHyps; econstructor; eauto. - eapply eqlive_reg_trans; eauto. -Qed. - -Lemma eqlive_stackframes_refl stf1 stf2: match_stackframes stf1 stf2 -> eqlive_stackframes stf1 stf1. -Proof. - destruct 1; econstructor; eauto. - intros; eapply eqlive_reg_refl; eauto. -Qed. - -Lemma eqlive_stacks_refl stk1 stk2: - list_forall2 match_stackframes stk1 stk2 -> list_forall2 eqlive_stackframes stk1 stk1. -Proof. - induction 1; simpl; econstructor; eauto. - eapply eqlive_stackframes_refl; eauto. -Qed. - -Lemma transf_fundef_correct f f': - transf_fundef f = OK f' -> match_fundef f f'. -Proof. - intros TRANSF; destruct f; simpl; monadInv TRANSF. - + destruct (transf_function f) as [res H]; simpl in * |- *; auto. - destruct (H _ EQ). - intuition subst; auto. - eapply match_Internal; eauto. - + eapply match_External. -Qed. - diff --git a/kvx/lib/RTLpathScheduleraux.ml b/kvx/lib/RTLpathScheduleraux.ml deleted file mode 100644 index 88f777a5..00000000 --- a/kvx/lib/RTLpathScheduleraux.ml +++ /dev/null @@ -1,368 +0,0 @@ -open RTLpath -open RTL -open Maps -open RTLpathLivegenaux -open Registers -open Camlcoq - -type superblock = { - instructions: P.t array; (* pointers to code instructions *) - (* each predicted Pcb has its attached liveins *) - (* This is indexed by the pc value *) - liveins: Regset.t PTree.t; - (* Union of the input_regs of the last successors *) - output_regs: Regset.t; - typing: RTLtyping.regenv -} - -let print_instructions insts code = - if (!debug_flag) then begin - dprintf "[ "; - List.iter ( - fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code)) - ) insts; dprintf "]" - end - -let print_superblock sb code = - let insts = sb.instructions in - let li = sb.liveins in - let outs = sb.output_regs in - begin - dprintf "{ instructions = "; print_instructions (Array.to_list insts) code; dprintf "\n"; - dprintf " liveins = "; print_ptree_regset li; dprintf "\n"; - dprintf " output_regs = "; print_regset outs; dprintf "}" - end - -let print_superblocks lsb code = - let rec f = function - | [] -> () - | sb :: lsb -> (print_superblock sb code; dprintf ",\n"; f lsb) - in begin - dprintf "[\n"; - f lsb; - dprintf "]" - end - -(* Adapted from backend/PrintRTL.ml: print_function *) -let print_code code = let open PrintRTL in let open Printf in - if (!debug_flag) then begin - fprintf stdout "{\n"; - let instrs = - List.sort - (fun (pc1, _) (pc2, _) -> compare pc2 pc1) - (List.rev_map - (fun (pc, i) -> (P.to_int pc, i)) - (PTree.elements code)) in - List.iter (print_instruction stdout) instrs; - fprintf stdout "}" - end - -let print_arrayp arr = begin - dprintf "[| "; - Array.iter (fun n -> dprintf "%d, " (P.to_int n)) arr; - dprintf "|]" -end - -let get_superblocks code entry pm typing = - let visited = ref (PTree.map (fun n i -> false) code) in - let rec get_superblocks_rec pc = - let liveins = ref (PTree.empty) in - let rec follow pc n = - let inst = get_some @@ PTree.get pc code in - if (n == 0) then begin - (match (non_predicted_successors inst) with - | [pcout] -> - let live = (get_some @@ PTree.get pcout pm).input_regs in - liveins := PTree.set pc live !liveins - | _ -> ()); - ([pc], successors_inst inst) - end else - let nexts_from_exit = match (non_predicted_successors inst) with - | [pcout] -> - let live = (get_some @@ PTree.get pcout pm).input_regs in begin - liveins := PTree.set pc live !liveins; - [pcout] - end - | [] -> [] - | _ -> failwith "Having more than one non_predicted_successor is not handled" - in match (predicted_successor inst) with - | None -> failwith "Incorrect path" - | Some succ -> - let (insts, nexts) = follow succ (n-1) in (pc :: insts, nexts_from_exit @ nexts) - in if (get_some @@ PTree.get pc !visited) then [] - else begin - visited := PTree.set pc true !visited; - let pi = get_some @@ PTree.get pc pm in - let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in - let superblock = { instructions = Array.of_list insts; liveins = !liveins; - output_regs = pi.output_regs; typing = typing } in - superblock :: (List.concat @@ List.map get_superblocks_rec nexts) - end - in let lsb = get_superblocks_rec entry in begin - (* debug_flag := true; *) - dprintf "Superblocks identified:"; print_superblocks lsb code; dprintf "\n"; - (* debug_flag := false; *) - lsb -end - -(* TODO David *) -let schedule_superblock sb code = - if not !Clflags.option_fprepass - then sb.instructions - else - let old_flag = !debug_flag in - debug_flag := true; - print_endline "ORIGINAL SUPERBLOCK"; - print_superblock sb code; - debug_flag := old_flag; - let nr_instr = Array.length sb.instructions in - let trailer_length = - match PTree.get (sb.instructions.(nr_instr-1)) code with - | None -> 0 - | Some ii -> - match predicted_successor ii with - | Some _ -> 0 - | None -> 1 in - match PrepassSchedulingOracle.schedule_sequence - (Array.map (fun i -> - (match PTree.get i code with - | Some ii -> ii - | None -> failwith "RTLpathScheduleraux.schedule_superblock"), - (match PTree.get i sb.liveins with - | Some s -> s - | None -> Regset.empty)) - (Array.sub sb.instructions 0 (nr_instr-trailer_length))) with - | None -> sb.instructions - | Some order -> - let ins' = - Array.append - (Array.map (fun i -> sb.instructions.(i)) order) - (Array.sub sb.instructions (nr_instr-trailer_length) trailer_length) in - Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins'); - debug_flag := true; - print_instructions (Array.to_list ins') code; - debug_flag := old_flag; - flush stdout; - assert ((Array.length sb.instructions) = (Array.length ins')); - (*sb.instructions; *) - ins';; - - (* stub2: reverse function *) - (* - let reversed = Array.of_list @@ List.rev @@ Array.to_list (sb.instructions) in - let tmp = reversed.(0) in - let last_index = Array.length reversed - 1 in - begin - reversed.(0) <- reversed.(last_index); - reversed.(last_index) <- tmp; - reversed - end *) - (* stub: identity function *) - -(** - * Perform basic checks on the new order : - * - must have the same length as the old order - * - non basic instructions (call, tailcall, return, jumptable, non predicted CB) must not move - *) -let check_order code old_order new_order = begin - assert ((Array.length old_order) == (Array.length new_order)); - let length = Array.length new_order in - if length > 0 then - let last_inst = Array.get old_order (length - 1) in - let instr = get_some @@ PTree.get last_inst code in - match predicted_successor instr with - | None -> - if (last_inst != Array.get new_order (length - 1)) then - failwith "The last instruction of the superblock is not basic, but was moved" - | _ -> () -end - -type sinst = - (* Each middle instruction has a direct successor *) - (* A Smid can be the last instruction of a superblock, but a Send cannot be moved *) - | Smid of RTL.instruction * node - | Send of RTL.instruction - -let rinst_to_sinst inst = - match inst with - | Inop n -> Smid(inst, n) - | Iop (_,_,_,n) -> Smid(inst, n) - | Iload (_,_,_,_,_,n) -> Smid(inst, n) - | Istore (_,_,_,_,n) -> Smid(inst, n) - | Icond (_,_,n1,n2,p) -> ( - match p with - | Some true -> Smid(inst, n1) - | Some false -> Smid(inst, n2) - | None -> Send(inst) - ) - | Icall _ | Ibuiltin _ | Ijumptable _ | Itailcall _ | Ireturn _ -> Send(inst) - -let change_predicted_successor s = function - | Smid(i, n) -> Smid(i, s) - | Send _ -> failwith "Called change_predicted_successor on Send. Are you trying to move a non-basic instruction in the middle of the block?" - -(* Forwards the successor changes into an RTL instruction *) -let sinst_to_rinst = function - | Smid(inst, s) -> ( - match inst with - | Inop n -> Inop s - | Iop (a,b,c,n) -> Iop (a,b,c,s) - | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) - | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) - | Icond (a,b,n1,n2,p) -> ( - match p with - | Some true -> Icond(a, b, s, n2, p) - | Some false -> Icond(a, b, n1, s, p) - | None -> failwith "Non predicted Icond as a middle instruction!" - ) - | _ -> failwith "That instruction shouldn't be a middle instruction" - ) - | Send i -> i - -let apply_schedule code sb new_order = - let tc = ref code in - let old_order = sb.instructions in - begin - check_order code old_order new_order; - Array.iteri (fun i n' -> - let inst' = get_some @@ PTree.get n' code in - let iend = Array.length old_order - 1 in - let new_inst = - if (i == iend) then - let final_inst_node = Array.get old_order iend in - let sinst' = rinst_to_sinst inst' in - match sinst' with - (* The below assert fails if a Send is in the middle of the original superblock *) - | Send i -> (assert (final_inst_node == n'); i) - | Smid _ -> - let final_inst = get_some @@ PTree.get final_inst_node code in - match rinst_to_sinst final_inst with - | Smid (_, s') -> sinst_to_rinst @@ change_predicted_successor s' sinst' - | Send _ -> assert(false) (* should have failed earlier *) - else - sinst_to_rinst - (* this will fail if the moved instruction is a Send *) - @@ change_predicted_successor (Array.get old_order (i+1)) - @@ rinst_to_sinst inst' - in tc := PTree.set (Array.get old_order i) new_inst !tc - ) new_order; - !tc - end - - (* -let main_successors = function -| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n] -| Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> [n] -| Icond (_,_,n1,n2,p) -> ( - match p with - | Some true -> [n1; n2] - | Some false -> [n2; n1] - | None -> [n1; n2] ) -| Ijumptable _ | Itailcall _ | Ireturn _ -> [] - -let change_predicted_successor i s = match i with - | Itailcall _ | Ireturn _ -> failwith "Wrong instruction (5) - Tailcalls and returns should not be moved in the middle of a superblock" - | Ijumptable _ -> failwith "Wrong instruction (6) - Jumptables should not be moved in the middle of a superblock" - | Inop n -> Inop s - | Iop (a,b,c,n) -> Iop (a,b,c,s) - | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) - | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) - | Icall (a,b,c,d,n) -> Icall (a,b,c,d,s) - | Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s) - | Icond (a,b,n1,n2,p) -> ( - match p with - | Some true -> Icond (a,b,s,n2,p) - | Some false -> Icond (a,b,n1,s,p) - | None -> failwith "Predicted a successor for an Icond with p=None - unpredicted CB should not be moved in the middle of the superblock" - ) - -let rec change_successors i = function - | [] -> ( - match i with - | Itailcall _ | Ireturn _ -> i - | _ -> failwith "Wrong instruction (1)") - | [s] -> ( - match i with - | Inop n -> Inop s - | Iop (a,b,c,n) -> Iop (a,b,c,s) - | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) - | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) - | Icall (a,b,c,d,n) -> Icall (a,b,c,d,s) - | Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s) - | Ijumptable (a,[n]) -> Ijumptable (a,[s]) - | Icond (a,b,n1,n2,p) -> ( - match p with - | Some true -> Icond (a,b,s,n2,p) - | Some false -> Icond (a,b,n1,s,p) - | None -> failwith "Icond Wrong instruction (2) ; should not happen?" - ) - | _ -> failwith "Wrong instruction (2)") - | [s1; s2] -> ( - match i with - | Icond (a,b,n1,n2,p) -> Icond (a,b,s1,s2,p) - | Ijumptable (a, [n1; n2]) -> Ijumptable (a, [s1; s2]) - | _ -> change_successors i [s1]) - | ls -> ( - match i with - | Ijumptable (a, ln) -> begin - assert ((List.length ln) == (List.length ls)); - Ijumptable (a, ls) - end - | _ -> failwith "Wrong instruction (4)") - - -let apply_schedule code sb new_order = - let tc = ref code in - let old_order = sb.instructions in - let last_node = Array.get old_order (Array.length old_order - 1) in - let last_successors = main_successors - @@ get_some @@ PTree.get last_node code in - begin - check_order code old_order new_order; - Array.iteri (fun i n' -> - let inst' = get_some @@ PTree.get n' code in - let new_inst = - if (i == (Array.length old_order - 1)) then - change_successors inst' last_successors - else - change_predicted_successor inst' (Array.get old_order (i+1)) - in tc := PTree.set (Array.get old_order i) new_inst !tc - ) new_order; - !tc - end -*) - -let rec do_schedule code = function - | [] -> code - | sb :: lsb -> - let schedule = schedule_superblock sb code in - let new_code = apply_schedule code sb schedule in - begin - (* debug_flag := true; *) - dprintf "Old Code: "; print_code code; - dprintf "\nSchedule to apply: "; print_arrayp schedule; - dprintf "\nNew Code: "; print_code new_code; - dprintf "\n"; - (* debug_flag := false; *) - do_schedule new_code lsb - end - -let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK" - -let scheduler f = - let code = f.fn_RTL.fn_code in - let id_ptree = PTree.map (fun n i -> n) (f.fn_path) in - let entry = f.fn_RTL.fn_entrypoint in - let pm = f.fn_path in - let typing = get_ok @@ RTLtyping.type_function f.fn_RTL in - let lsb = get_superblocks code entry pm typing in - begin - (* debug_flag := true; *) - dprintf "Pathmap:\n"; dprintf "\n"; - print_path_map pm; - dprintf "Superblocks:\n"; - print_superblocks lsb code; dprintf "\n"; - (* debug_flag := false; *) - let tc = do_schedule code lsb in - (((tc, entry), pm), id_ptree) - end diff --git a/kvx/lib/RTLpathSchedulerproof.v b/kvx/lib/RTLpathSchedulerproof.v deleted file mode 100644 index 5c32847e..00000000 --- a/kvx/lib/RTLpathSchedulerproof.v +++ /dev/null @@ -1,341 +0,0 @@ -Require Import AST Linking Values Maps Globalenvs Smallstep Registers. -Require Import Coqlib Maps Events Errors Op. -Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory. -Require Import RTLpathScheduler. - -Definition match_prog (p tp: program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. -Proof. - intros. eapply match_transform_partial_program_contextual; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: program. -Variable tprog: program. - -Hypothesis TRANSL: match_prog prog tprog. - -Let pge := Genv.globalenv prog. -Let tpge := Genv.globalenv tprog. - -Hypothesis all_fundef_liveness_ok: forall b fd, Genv.find_funct_ptr pge b = Some fd -> liveness_ok_fundef fd. - -Lemma symbols_preserved s: Genv.find_symbol tpge s = Genv.find_symbol pge s. -Proof. - rewrite <- (Genv.find_symbol_match TRANSL). reflexivity. -Qed. - -Lemma senv_preserved: - Senv.equiv pge tpge. -Proof. - eapply (Genv.senv_match TRANSL). -Qed. - -Lemma functions_preserved: - forall (v: val) (f: fundef), - Genv.find_funct pge v = Some f -> - exists tf cunit, transf_fundef f = OK tf /\ Genv.find_funct tpge v = Some tf /\ linkorder cunit prog. -Proof. - intros. exploit (Genv.find_funct_match TRANSL); eauto. - intros (cu & tf & A & B & C). - repeat eexists; intuition eauto. - + unfold incl; auto. - + eapply linkorder_refl. -Qed. - -Lemma function_ptr_preserved: - forall v f, - Genv.find_funct_ptr pge v = Some f -> - exists tf, - Genv.find_funct_ptr tpge v = Some tf /\ transf_fundef f = OK tf. -Proof. - intros. - exploit (Genv.find_funct_ptr_transf_partial TRANSL); eauto. -Qed. - -Lemma function_sig_preserved: - forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. -Proof. - intros. destruct f. - - simpl in H. monadInv H. - destruct (transf_function f) as [res H]; simpl in * |- *; auto. - destruct (H _ EQ). - intuition subst; auto. - symmetry. - eapply match_function_preserves. - eassumption. - - simpl in H. monadInv H. reflexivity. -Qed. - -Theorem transf_initial_states: - forall s1, initial_state prog s1 -> - exists s2, initial_state tprog s2 /\ match_states s1 s2. -Proof. - intros. inv H. - exploit function_ptr_preserved; eauto. intros (tf & FIND & TRANSF). - exists (Callstate nil tf nil m0). - split. - - econstructor; eauto. - + intros; apply (Genv.init_mem_match TRANSL); assumption. - + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. - symmetry. eapply match_program_main. eauto. - + destruct f. - * monadInv TRANSF. rewrite <- H3. - destruct (transf_function f) as [res H]; simpl in * |- *; auto. - destruct (H _ EQ). - intuition subst; auto. - symmetry; eapply match_function_preserves. eassumption. - * monadInv TRANSF. assumption. - - constructor; eauto. - + constructor. - + apply transf_fundef_correct; auto. -(* + eapply all_fundef_liveness_ok; eauto. *) -Qed. - -Theorem transf_final_states s1 s2 r: - final_state s1 r -> match_states s1 s2 -> final_state s2 r. -Proof. - unfold final_state. - intros H; inv H. - intros H; inv H; simpl in * |- *; try congruence. - inv H1. - destruct st; simpl in * |- *; try congruence. - inv STACKS. constructor. -Qed. - - -Let ge := Genv.globalenv (RTLpath.transf_program prog). -Let tge := Genv.globalenv (RTLpath.transf_program tprog). - -Lemma senv_sym x y: Senv.equiv x y -> Senv.equiv y x. -Proof. - unfold Senv.equiv. intuition congruence. -Qed. - -Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. -Proof. - unfold Senv.equiv. intuition congruence. -Qed. - -Lemma senv_preserved_RTL: - Senv.equiv ge tge. -Proof. - eapply senv_transitivity. { eapply senv_sym; eapply RTLpath.senv_preserved. } - eapply senv_transitivity. { eapply senv_preserved. } - eapply RTLpath.senv_preserved. -Qed. - -Lemma symbols_preserved_RTL s: Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - unfold tge, ge. erewrite RTLpath.symbols_preserved; eauto. - rewrite symbols_preserved. - erewrite RTLpath.symbols_preserved; eauto. -Qed. - -Program Definition mkctx sp rs0 m0 {f1: RTLpath.function} (hyp: liveness_ok_function f1) - : simu_proof_context f1 - := {| the_ge1:= ge; the_ge2 := tge; the_sp:=sp; the_rs0:=rs0; the_m0:=m0 |}. -Obligation 2. - erewrite symbols_preserved_RTL. eauto. -Qed. - -Lemma s_find_function_preserved f sp svos1 svos2 rs0 m0 fd - (LIVE: liveness_ok_function f): - (svident_simu f (mkctx sp rs0 m0 LIVE) svos1 svos2) -> - sfind_function pge ge sp svos1 rs0 m0 = Some fd -> - exists fd', sfind_function tpge tge sp svos2 rs0 m0 = Some fd' - /\ transf_fundef fd = OK fd' - /\ liveness_ok_fundef fd. -Proof. - Local Hint Resolve symbols_preserved_RTL: core. - unfold sfind_function. intros [sv1 sv2 SIMU|]; simpl in *. - + rewrite !(seval_preserved ge tge) in *; eauto. - destruct (seval_sval _ _ _ _); try congruence. - erewrite SIMU; try congruence. clear SIMU. - intros; exploit functions_preserved; eauto. - intros (fd' & cunit & (X1 & X2 & X3)). eexists. - repeat split; eauto. - eapply find_funct_liveness_ok; eauto. -(* intros. eapply all_fundef_liveness_ok; eauto. *) - + subst. rewrite symbols_preserved. destruct (Genv.find_symbol _ _); try congruence. - intros; exploit function_ptr_preserved; eauto. - intros (fd' & X). eexists. intuition eauto. -(* intros. eapply all_fundef_liveness_ok; eauto. *) -Qed. - -Lemma sistate_simu f dupmap sp st st' rs m is - (LIVE: liveness_ok_function f): - ssem_internal ge sp st rs m is -> - sistate_simu dupmap f st st' (mkctx sp rs m LIVE)-> - exists is', - ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap is is'. -Proof. - intros SEM X; eapply X; eauto. -Qed. - -Lemma ssem_final_simu dm f f' stk stk' sp st st' rs0 m0 sv sv' rs m t s - (LIVE: liveness_ok_function f): - match_function dm f f' -> - list_forall2 match_stackframes stk stk' -> - (* s_istate_simu f dupmap st st' -> *) - sfval_simu dm f st.(si_pc) st'.(si_pc) (mkctx sp rs0 m0 LIVE) sv sv' -> - ssem_final pge ge sp st.(si_pc) stk f rs0 m0 sv rs m t s -> - exists s', ssem_final tpge tge sp st'.(si_pc) stk' f' rs0 m0 sv' rs m t s' /\ match_states s s'. -Proof. - Local Hint Resolve transf_fundef_correct: core. - intros FUN STK (* SIS *) SFV. destruct SFV; intros SEM; inv SEM; simpl in *. - - (* Snone *) - exploit initialize_path. { eapply dupmap_path_entry1; eauto. } - intros (path & PATH). - eexists; split; econstructor; eauto. - eapply eqlive_reg_refl. - - (* Scall *) - exploit s_find_function_preserved; eauto. - intros (fd' & FIND & TRANSF & LIVE'). - erewrite <- function_sig_preserved; eauto. - exploit initialize_path. { eapply dupmap_path_entry1; eauto. } - intros (path & PATH). - eexists; split; econstructor; eauto. - + eapply opt_simu_Some; eauto. - + simpl. repeat (econstructor; eauto). - - (* Stailcall *) - exploit s_find_function_preserved; eauto. - intros (fd' & FIND & TRANSF & LIVE'). - erewrite <- function_sig_preserved; eauto. - eexists; split; econstructor; eauto. - + erewrite <- preserv_fnstacksize; eauto. - + eapply opt_simu_Some; eauto. - - (* Sbuiltin *) - pose senv_preserved_RTL as SRTL. - exploit initialize_path. { eapply dupmap_path_entry1; eauto. } - intros (path & PATH). - eexists; split; econstructor; eauto. - + eapply seval_builtin_args_preserved; eauto. - + eapply external_call_symbols_preserved; eauto. - + eapply eqlive_reg_refl. - - (* Sjumptable *) - exploit ptree_get_list_nth_rev; eauto. intros (p2 & LNZ & DM). - exploit initialize_path. { eapply dupmap_path_entry1; eauto. } - intros (path & PATH). - eexists; split; econstructor; eauto. - + eapply opt_simu_Some; eauto. - + eapply eqlive_reg_refl. - - (* Sreturn *) - eexists; split; econstructor; eauto. - + erewrite <- preserv_fnstacksize; eauto. - + destruct os; auto. - erewrite <- seval_preserved; eauto. -Qed. - -(* The main theorem on simulation of symbolic states ! *) -Theorem ssem_sstate_simu dm f f' stk stk' sp st st' rs m t s: - match_function dm f f' -> - liveness_ok_function f -> - list_forall2 match_stackframes stk stk' -> - ssem pge ge sp st stk f rs m t s -> - (forall ctx: simu_proof_context f, sstate_simu dm f st st' ctx) -> - exists s', ssem tpge tge sp st' stk' f' rs m t s' /\ match_states s s'. -Proof. - intros MFUNC LIVE STACKS SEM SIMU. - destruct (SIMU (mkctx sp rs m LIVE)) as (SIMU1 & SIMU2); clear SIMU. - destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl. - - (* sem_early *) - exploit sistate_simu; eauto. - unfold istate_simu; rewrite CONT. - intros (is' & SEM' & (path & PATH & (CONT' & RS' & M') & PC')). - exists (State stk' f' sp (ipc is') (irs is') (imem is')). - split. - + eapply ssem_early; auto. congruence. - + rewrite M'. econstructor; eauto. - - (* sem_normal *) - exploit sistate_simu; eauto. - unfold istate_simu; rewrite CONT. - intros (is' & SEM' & (CONT' & RS' & M')(* & DMEQ *)). - rewrite <- eqlive_reg_triv in RS'. - exploit ssem_final_simu; eauto. - clear SEM2; intros (s0 & SEM2 & MATCH0). - exploit ssem_final_equiv; eauto. - clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s1 & EQ & SEM2). - exists s1; split. - + eapply ssem_normal; eauto. - + eapply match_states_equiv; eauto. -Qed. - -Lemma exec_path_simulation dupmap path stk stk' f f' sp rs m pc pc' t s: - (fn_path f)!pc = Some path -> - path_step ge pge path.(psize) stk f sp rs m pc t s -> - list_forall2 match_stackframes stk stk' -> - dupmap ! pc' = Some pc -> - match_function dupmap f f' -> - liveness_ok_function f -> - exists path' s', (fn_path f')!pc' = Some path' /\ path_step tge tpge path'.(psize) stk' f' sp rs m pc' t s' /\ match_states s s'. -Proof. - intros PATH STEP STACKS DUPPC MATCHF LIVE. - exploit initialize_path. { eapply dupmap_path_entry2; eauto. } - intros (path' & PATH'). - exists path'. - exploit (sexec_correct f pc pge ge sp path stk rs m t s); eauto. - intros (st & SYMB & SEM); clear STEP. - exploit dupmap_correct; eauto. - clear SYMB; intros (st' & SYMB & SIMU). - exploit ssem_sstate_simu; eauto. - intros (s0 & SEM0 & MATCH). - exploit sexec_exact; eauto. - intros (s' & STEP' & EQ). - exists s'; intuition. - eapply match_states_equiv; eauto. -Qed. - -Lemma step_simulation s1 t s1' s2: - step ge pge s1 t s1' -> - match_states s1 s2 -> - exists s2', - step tge tpge s2 t s2' - /\ match_states s1' s2'. -Proof. - Local Hint Resolve eqlive_stacks_refl transf_fundef_correct: core. - destruct 1 as [path stack f sp rs m pc t s PATH STEP | | | ]; intros MS; inv MS. -(* exec_path *) - - try_simplify_someHyps. intros. - exploit path_step_eqlive; eauto. (* { intros. eapply all_fundef_liveness_ok; eauto. } *) - clear STEP EQUIV rs; intros (s2 & STEP & EQLIVE). - exploit exec_path_simulation; eauto. - clear STEP; intros (path' & s' & PATH' & STEP' & MATCH'). - exists s'; split. - + eapply exec_path; eauto. - + eapply eqlive_match_states; eauto. -(* exec_function_internal *) - - inv LIVE. - exploit initialize_path. { eapply (fn_entry_point_wf f). } - destruct 1 as (path & PATH). - inversion TRANSF as [f0 xf tf MATCHF|]; subst. eexists. split. - + eapply exec_function_internal. erewrite <- preserv_fnstacksize; eauto. - + erewrite preserv_fnparams; eauto. - econstructor; eauto. - { apply preserv_entrypoint; auto. } - { apply eqlive_reg_refl. } -(* exec_function_external *) - - inversion TRANSF as [|]; subst. eexists. split. - + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved_RTL. - + constructor. assumption. -(* exec_return *) - - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split. - + constructor. - + inv H1. econstructor; eauto. -Qed. - -Theorem transf_program_correct: - forward_simulation (semantics prog) (semantics tprog). -Proof. - eapply forward_simulation_step with match_states. - - eapply senv_preserved. - - eapply transf_initial_states. - - intros; eapply transf_final_states; eauto. - - intros; eapply step_simulation; eauto. -Qed. - -End PRESERVATION. diff --git a/kvx/lib/RTLpathproof.v b/kvx/lib/RTLpathproof.v deleted file mode 100644 index 20eded97..00000000 --- a/kvx/lib/RTLpathproof.v +++ /dev/null @@ -1,50 +0,0 @@ -Require Import Coqlib Maps. -Require Import AST Integers Values Events Memory Globalenvs Smallstep. -Require Import Op Registers. -Require Import RTL Linking. -Require Import RTLpath. - -Definition match_prog (p: RTLpath.program) (tp: RTL.program) := - match_program (fun ctx f tf => tf = fundef_RTL f) eq p tp. - -Lemma transf_program_match: - forall p, match_prog p (transf_program p). -Proof. - intros. eapply match_transform_program; eauto. -Qed. - -Lemma match_program_transf: - forall p tp, match_prog p tp -> transf_program p = tp. -Proof. - intros p tp H. inversion_clear H. inv H1. - destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. - subst. unfold transf_program. unfold transform_program. simpl. - apply program_equals; simpl; auto. - induction H0; simpl; auto. - rewrite IHlist_forall2. apply cons_extract. - destruct a1 as [ida gda]. destruct b1 as [idb gdb]. - simpl in *. - inv H. inv H2. - - simpl in *. subst. auto. - - simpl in *. subst. inv H. auto. -Qed. - - -Section PRESERVATION. - -Variable prog: RTLpath.program. -Variable tprog: RTL.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Theorem transf_program_correct: - forward_simulation (RTLpath.semantics prog) (RTL.semantics tprog). -Proof. - pose proof (match_program_transf prog tprog TRANSF) as TR. subst. - eapply RTLpath_correct. -Qed. - -End PRESERVATION. - - diff --git a/scheduling/InstructionScheduler.ml b/scheduling/InstructionScheduler.ml new file mode 100644 index 00000000..eab0b21a --- /dev/null +++ b/scheduling/InstructionScheduler.ml @@ -0,0 +1,1263 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +let with_destructor dtor stuff f = + try let ret = f stuff in + dtor stuff; + ret + with exn -> dtor stuff; + raise exn;; + +let with_out_channel chan f = with_destructor close_out chan f;; +let with_in_channel chan f = with_destructor close_in chan f;; + +(** Schedule instructions on a synchronized pipeline +@author David Monniaux, CNRS, VERIMAG *) + +type latency_constraint = { + instr_from : int; + instr_to : int; + latency : int };; + +type problem = { + max_latency : int; + resource_bounds : int array; + instruction_usages : int array array; + latency_constraints : latency_constraint list; + };; + +let print_problem channel problem = + (if problem.max_latency >= 0 + then Printf.fprintf channel "max makespan: %d\n" problem.max_latency); + output_string channel "resource bounds:"; + (Array.iter (fun b -> Printf.fprintf channel " %d" b) problem.resource_bounds); + output_string channel ";\n"; + (Array.iteri (fun i v -> + Printf.fprintf channel "instr%d:" i; + (Array.iter (fun b -> Printf.fprintf channel " %d" b) v); + output_string channel ";\n") problem.instruction_usages); + List.iter (fun instr -> + Printf.printf "t%d - t%d >= %d;\n" + instr.instr_to instr.instr_from instr.latency) + problem.latency_constraints;; + +let get_nr_instructions problem = Array.length problem.instruction_usages;; +let get_nr_resources problem = Array.length problem.resource_bounds;; + +type solution = int array +type scheduler = problem -> solution option + +(* DISABLED +(** Schedule the problem optimally by constraint solving using the Gecode solver. *) +external gecode_scheduler : problem -> solution option = + "caml_gecode_schedule_instr";; + *) + +let maximum_slot_used times = + let maxi = ref (-1) in + for i=0 to (Array.length times)-2 + do + maxi := max !maxi times.(i) + done; + !maxi;; + +let check_schedule (problem : problem) (times : solution) = + let nr_instructions = get_nr_instructions problem in + (if Array.length times <> nr_instructions+1 + then failwith + (Printf.sprintf "check_schedule: %d times expected, got %d" + (nr_instructions+1) (Array.length times))); + (if problem.max_latency >= 0 && times.(nr_instructions)> problem.max_latency + then failwith "check_schedule: max_latency exceeded"); + (Array.iteri (fun i time -> + (if time < 0 + then failwith (Printf.sprintf "time[%d] < 0" i))) times); + let slot_resources = Array.init ((maximum_slot_used times)+1) + (fun _ -> Array.copy problem.resource_bounds) in + for i=0 to nr_instructions -1 + do + let remaining_resources = slot_resources.(times.(i)) + and used_resources = problem.instruction_usages.(i) in + for resource=0 to (Array.length used_resources)-1 + do + let after = remaining_resources.(resource) - used_resources.(resource) in + (if after < 0 + then failwith (Printf.sprintf "check_schedule: instruction %d exceeds resource %d at slot %d" i resource times.(i))); + remaining_resources.(resource) <- after + done + done; + List.iter (fun ctr -> + if times.(ctr.instr_to) - times.(ctr.instr_from) < ctr.latency + then failwith (Printf.sprintf "check_schedule: time[%d]=%d - time[%d]=%d < %d" + ctr.instr_to times.(ctr.instr_to) + ctr.instr_from times.(ctr.instr_from) + ctr.latency) + ) problem.latency_constraints;; + +let bound_max_time problem = + let total = ref(Array.length problem.instruction_usages) in + List.iter (fun ctr -> total := !total + ctr.latency) problem.latency_constraints; + !total;; + +let vector_less_equal a b = + try + Array.iter2 (fun x y -> + if x>y + then raise Exit) a b; + true + with Exit -> false;; + +let vector_subtract a b = + assert ((Array.length a) = (Array.length b)); + for i=0 to (Array.length a)-1 + do + b.(i) <- b.(i) - a.(i) + done;; + +(* The version with critical path ordering is much better! *) +type list_scheduler_order = + | INSTRUCTION_ORDER + | CRITICAL_PATH_ORDER;; + +let int_max (x : int) (y : int) = + if x > y then x else y;; + +let int_min (x : int) (y : int) = + if x < y then x else y;; + +let get_predecessors problem = + let nr_instructions = get_nr_instructions problem in + let predecessors = Array.make (nr_instructions+1) [] in + List.iter (fun ctr -> + predecessors.(ctr.instr_to) <- + (ctr.instr_from, ctr.latency)::predecessors.(ctr.instr_to)) + problem.latency_constraints; + predecessors;; + +let get_successors problem = + let nr_instructions = get_nr_instructions problem in + let successors = Array.make nr_instructions [] in + List.iter (fun ctr -> + successors.(ctr.instr_from) <- + (ctr.instr_to, ctr.latency)::successors.(ctr.instr_from)) + problem.latency_constraints; + successors;; + +let critical_paths successors = + let nr_instructions = Array.length successors in + let path_lengths = Array.make nr_instructions (-1) in + let rec compute i = + if i=nr_instructions then 0 else + match path_lengths.(i) with + | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" + | -1 -> path_lengths.(i) <- -2; + let x = List.fold_left + (fun cur (j, latency)-> int_max cur (latency+(compute j))) + 1 successors.(i) + in path_lengths.(i) <- x; x + | x -> x + in for i = nr_instructions-1 downto 0 + do + ignore (compute i) + done; + path_lengths;; + +let maximum_critical_path problem = + let paths = critical_paths (get_successors problem) in + Array.fold_left int_max 0 paths;; + +let get_earliest_dates predecessors = + let nr_instructions = (Array.length predecessors)-1 in + let path_lengths = Array.make (nr_instructions+1) (-1) in + let rec compute i = + match path_lengths.(i) with + | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" + | -1 -> path_lengths.(i) <- -2; + let x = List.fold_left + (fun cur (j, latency)-> int_max cur (latency+(compute j))) + 0 predecessors.(i) + in path_lengths.(i) <- x; x + | x -> x + in for i = 0 to nr_instructions + do + ignore (compute i) + done; + for i = 0 to nr_instructions - 1 + do + path_lengths.(nr_instructions) <- int_max + path_lengths.(nr_instructions) (1 + path_lengths.(i)) + done; + path_lengths;; + +exception Unschedulable + +let get_latest_dates deadline successors = + let nr_instructions = Array.length successors + and path_lengths = critical_paths successors in + Array.init (nr_instructions + 1) + (fun i -> + if i < nr_instructions then + let path_length = path_lengths.(i) in + assert (path_length >= 1); + (if path_length > deadline + then raise Unschedulable); + deadline - path_length + else deadline);; + +let priority_list_scheduler (order : list_scheduler_order) + (problem : problem) : + solution option = + let nr_instructions = get_nr_instructions problem in + let successors = get_successors problem + and predecessors = get_predecessors problem + and times = Array.make (nr_instructions+1) (-1) in + + let priorities = match order with + | INSTRUCTION_ORDER -> None + | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in + + let module InstrSet = + Set.Make (struct type t=int + let compare = match priorities with + | None -> (fun x y -> x - y) + | Some p -> (fun x y -> + (match p.(y)-p.(x) with + | 0 -> x - y + | z -> z)) + end) in + + let max_time = bound_max_time problem in + let ready = Array.make max_time InstrSet.empty in + Array.iteri (fun i preds -> + if i + if times.(j) < 0 + then raise Exit + else let t = times.(j) + latency in + if t > !time + then time := t) predecessors.(i); + assert(!time >= 0); + !time + with Exit -> -1 + + in + let advance_time() = + begin + (if !current_time < max_time-1 + then + begin + Array.blit problem.resource_bounds 0 current_resources 0 + (Array.length current_resources); + ready.(!current_time + 1) <- + InstrSet.union (ready.(!current_time)) (ready.(!current_time + 1)); + ready.(!current_time) <- InstrSet.empty; + end); + incr current_time + end in + + let attempt_scheduling ready usages = + let result = ref (-1) in + try + InstrSet.iter (fun i -> + (* Printf.printf "trying scheduling %d\n" i; + pr int_vector usages.(i); + print _vector current_resources; *) + if vector_less_equal usages.(i) current_resources + then + begin + vector_subtract usages.(i) current_resources; + result := i; + raise Exit + end) ready; + -1 + with Exit -> !result in + + while !current_time < max_time + do + if (InstrSet.is_empty ready.(!current_time)) + then advance_time() + else + match attempt_scheduling ready.(!current_time) + problem.instruction_usages with + | -1 -> advance_time() + | i -> + begin + assert(times.(i) < 0); + times.(i) <- !current_time; + ready.(!current_time) <- InstrSet.remove i (ready.(!current_time)); + List.iter (fun (instr_to, latency) -> + if instr_to < nr_instructions then + match earliest_time instr_to with + | -1 -> () + | to_time -> + ready.(to_time) <- InstrSet.add instr_to ready.(to_time)) + successors.(i); + successors.(i) <- [] + end + done; + try + let final_time = ref (-1) in + for i=0 to nr_instructions-1 + do + (if times.(i) < 0 then raise Exit); + (if !final_time < times.(i)+1 then final_time := times.(i)+1) + done; + List.iter (fun (i, latency) -> + let target_time = latency + times.(i) in + if target_time > !final_time + then final_time := target_time + ) predecessors.(nr_instructions); + times.(nr_instructions) <- !final_time; + Some times + with Exit -> None;; + +let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; + +(* dummy code for placating ocaml's warnings *) +let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;; + +type bundle = int list;; + +let rec extract_deps_to index = function + | [] -> [] + | dep :: deps -> let extracts = extract_deps_to index deps in + if (dep.instr_to == index) then + dep :: extracts + else + extracts + +exception InvalidBundle;; + +let dependency_check problem bundle index = + let index_deps = extract_deps_to index problem.latency_constraints in + List.iter (fun i -> + List.iter (fun dep -> + if (dep.instr_from == i) then raise InvalidBundle + ) index_deps + ) bundle;; + +let rec make_bundle problem resources bundle index = + let resources_copy = Array.copy resources in + let nr_instructions = get_nr_instructions problem in + if (index >= nr_instructions) then (bundle, index+1) else + let inst_usage = problem.instruction_usages.(index) in + try match vector_less_equal inst_usage resources with + | false -> raise InvalidBundle + | true -> ( + dependency_check problem bundle index; + vector_subtract problem.instruction_usages.(index) resources_copy; + make_bundle problem resources_copy (index::bundle) (index+1) + ) + with InvalidBundle -> (bundle, index);; + +let rec make_bundles problem index : bundle list = + if index >= get_nr_instructions problem then + [] + else + let (bundle, new_index) = make_bundle problem problem.resource_bounds [] index in + bundle :: (make_bundles problem new_index);; + +let bundles_to_schedule problem bundles : solution = + let nr_instructions = get_nr_instructions problem in + let schedule = Array.make (nr_instructions+1) (nr_instructions+4) in + let time = ref 0 in + List.iter (fun bundle -> + begin + List.iter (fun i -> + schedule.(i) <- !time + ) bundle; + time := !time + 1 + end + ) bundles; schedule;; + +let greedy_scheduler (problem : problem) : solution option = + let bundles = make_bundles problem 0 in + Some (bundles_to_schedule problem bundles);; + +(* alternate implementation +let swap_array_elements a i j = + let x = a.(i) in + a.(i) <- a.(j); + a.(j) <- x;; + +let array_reverse_slice a first last = + let i = ref first and j = ref last in + while i < j + do + swap_array_elements a !i !j; + incr i; + decr j + done;; + +let array_reverse a = + let a' = Array.copy a in + array_reverse_slice a' 0 ((Array.length a)-1); + a';; + *) + +(* unneeded +let array_reverse a = + let n=Array.length a in + Array.init n (fun i -> a.(n-1-i));; + *) + +let reverse_constraint nr_instructions ctr = + { instr_to = nr_instructions -ctr.instr_from; + instr_from = nr_instructions - ctr.instr_to; + latency = ctr.latency };; + +(* unneeded +let rec list_map_filter f = function + | [] -> [] + | h::t -> + (match f h with + | None -> list_map_filter f t + | Some x -> x :: (list_map_filter f t));; + *) + +let reverse_problem problem = + let nr_instructions = get_nr_instructions problem in + { + max_latency = problem.max_latency; + resource_bounds = problem.resource_bounds; + instruction_usages = Array.init (nr_instructions + 1) + (fun i -> + if i=0 + then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i)); + latency_constraints = List.map (reverse_constraint nr_instructions) + problem.latency_constraints + };; + +let max_scheduled_time solution = + let time = ref (-1) in + for i = 0 to ((Array.length solution) - 2) + do + time := max !time solution.(i) + done; + !time;; + +(* +let recompute_makespan problem solution = + let n = (Array.length solution) - 1 and ms = ref 0 in + List.iter (fun cstr -> + if cstr.instr_to = n + then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) + ) problem.latency_constraints; + !ms;; + *) + +let schedule_reversed (scheduler : problem -> solution option) + (problem : problem) = + match scheduler (reverse_problem problem) with + | None -> None + | Some solution -> + let nr_instructions = get_nr_instructions problem in + let makespan = max_scheduled_time solution in + let ret = Array.init (nr_instructions + 1) + (fun i -> makespan-solution.(nr_instructions-i)) in + ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1) + (ret.(nr_instructions)); + Some ret;; + +(** Schedule the problem using a greedy list scheduling algorithm, from the end. *) +let reverse_list_scheduler = schedule_reversed list_scheduler;; + +let check_problem problem = + (if (Array.length problem.instruction_usages) < 1 + then failwith "length(problem.instruction_usages) < 1");; + +let validated_scheduler (scheduler : problem -> solution option) + (problem : problem) = + check_problem problem; + match scheduler problem with + | None -> None + | (Some solution) as ret -> check_schedule problem solution; ret;; + +let get_max_latency solution = + solution.((Array.length solution)-1);; + +let show_date_ranges problem = + let deadline = problem.max_latency in + assert(deadline >= 0); + let successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates : int array = get_earliest_dates predecessors + and latest_dates : int array = get_latest_dates deadline successors in + assert ((Array.length earliest_dates) = + (Array.length latest_dates)); + Array.iteri (fun i early -> + let late = latest_dates.(i) in + Printf.printf "t[%d] in %d..%d\n" i early late) + earliest_dates;; + +type pseudo_boolean_problem_type = + | SATISFIABILITY + | OPTIMIZATION;; + +type pseudo_boolean_mapper = { + mapper_pb_type : pseudo_boolean_problem_type; + mapper_nr_instructions : int; + mapper_nr_pb_variables : int; + mapper_earliest_dates : int array; + mapper_latest_dates : int array; + mapper_var_offsets : int array; + mapper_final_predecessors : (int * int) list +};; + +(* Latency constraints are: + presence of instr-to at each t <= sum of presences of instr-from at compatible times + + if reverse_encoding + presence of instr-from at each t <= sum of presences of instr-to at compatible times *) + +(* Experiments show reverse_encoding=true multiplies time by 2 in sat4j + without making hard instances easier *) +let direct_encoding = false +and reverse_encoding = false +and delta_encoding = true + +let pseudo_boolean_print_problem channel problem pb_type = + let deadline = problem.max_latency in + assert (deadline > 0); + let nr_instructions = get_nr_instructions problem + and nr_resources = get_nr_resources problem + and successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates = get_earliest_dates predecessors + and latest_dates = get_latest_dates deadline successors in + let var_offsets = Array.make + (match pb_type with + | OPTIMIZATION -> nr_instructions+1 + | SATISFIABILITY -> nr_instructions) 0 in + let nr_pb_variables = + (let nr = ref 0 in + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + var_offsets.(i) <- !nr; + nr := !nr + latest_dates.(i) - earliest_dates.(i) + 1 + done; + !nr) + and nr_pb_constraints = + (match pb_type with + | OPTIMIZATION -> nr_instructions+1 + | SATISFIABILITY -> nr_instructions) + + + (let count = ref 0 in + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + try + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 then raise Exit + done + with Exit -> incr count + done + done; + !count) + + + (let count=ref 0 in + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions + then count := !count + 1 + latest_dates.(ctr.instr_to) + - earliest_dates.(ctr.instr_to) + + (if reverse_encoding + then 1 + latest_dates.(ctr.instr_from) + - earliest_dates.(ctr.instr_from) + else 0) + ) + problem.latency_constraints; + !count) + + + (match pb_type with + | OPTIMIZATION -> (1 + deadline - earliest_dates.(nr_instructions)) * nr_instructions + | SATISFIABILITY -> 0) + and measured_nr_constraints = ref 0 in + + let pb_var i t = + assert(t >= earliest_dates.(i)); + assert(t <= latest_dates.(i)); + let v = 1+var_offsets.(i)+t-earliest_dates.(i) in + assert(v <= nr_pb_variables); + Printf.sprintf "x%d" v in + + let end_constraint () = + begin + output_string channel ";\n"; + incr measured_nr_constraints + end in + + let gen_latency_constraint i_to i_from latency t_to = + Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_to; + for t_from=earliest_dates.(i_from) to + int_min latest_dates.(i_from) (t_to - latency) + do + Printf.fprintf channel "+1 %s " (pb_var i_from t_from) + done; + Printf.fprintf channel "-1 %s " (pb_var i_to t_to); + Printf.fprintf channel ">= 0"; + end_constraint() + + and gen_dual_latency_constraint i_to i_from latency t_from = + Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_from; + for t_to=int_max earliest_dates.(i_to) (t_from + latency) + to latest_dates.(i_to) + do + Printf.fprintf channel "+1 %s " (pb_var i_to t_to) + done; + Printf.fprintf channel "-1 %s " (pb_var i_from t_from); + Printf.fprintf channel ">= 0"; + end_constraint() + in + + Printf.fprintf channel "* #variable= %d #constraint= %d\n" nr_pb_variables nr_pb_constraints; + Printf.fprintf channel "* nr_instructions=%d deadline=%d\n" nr_instructions deadline; + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + output_string channel "min:"; + for t=earliest_dates.(nr_instructions) to deadline + do + Printf.fprintf channel " %+d %s" t (pb_var nr_instructions t) + done; + output_string channel ";\n"; + end; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + Printf.fprintf channel "* t[%d] in %d..%d\n" i early late; + for t=early to late + do + Printf.fprintf channel "+1 %s " (pb_var i t) + done; + Printf.fprintf channel "= 1"; + end_constraint() + done; + + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + let bound = problem.resource_bounds.(j) + and coeffs = ref [] in + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 + then coeffs := (i, usage) :: !coeffs + done; + if !coeffs <> [] then + begin + Printf.fprintf channel "* resource #%d at t=%d <= %d\n" j t bound; + List.iter (fun (i, usage) -> + Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; + Printf.fprintf channel ">= %d" (-bound); + end_constraint(); + end + done + done; + + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions then + begin + for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) + do + gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to + done; + if reverse_encoding + then + for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) + do + gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from + done + end + ) problem.latency_constraints; + + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + let final_latencies = Array.make nr_instructions 1 in + List.iter (fun (i, latency) -> + final_latencies.(i) <- int_max final_latencies.(i) latency) + predecessors.(nr_instructions); + for t_to=earliest_dates.(nr_instructions) to deadline + do + for i_from = 0 to nr_instructions -1 + do + gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to + done + done + end; + assert (!measured_nr_constraints = nr_pb_constraints); + { + mapper_pb_type = pb_type; + mapper_nr_instructions = nr_instructions; + mapper_nr_pb_variables = nr_pb_variables; + mapper_earliest_dates = earliest_dates; + mapper_latest_dates = latest_dates; + mapper_var_offsets = var_offsets; + mapper_final_predecessors = predecessors.(nr_instructions) + };; + +type pb_answer = + | Positive + | Negative + | Unknown + +let line_to_pb_solution sol line nr_pb_variables = + let assign s v = + begin + let i = int_of_string s in + sol.(i-1) <- v + end in + List.iter + begin + function "" -> () + | item -> + (match String.get item 0 with + | '+' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Positive + | '-' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Negative + | 'x' -> + assert ((String.length item) >= 2); + assign (String.sub item 1 ((String.length item)-1)) Positive + | _ -> failwith "syntax error in pseudo Boolean solution: epected + - or x" + ) + end + (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; + +let pb_solution_to_schedule mapper pb_solution = + Array.mapi (fun i offset -> + let first = mapper.mapper_earliest_dates.(i) + and last = mapper.mapper_latest_dates.(i) + and time = ref (-1) in + for t=first to last + do + match pb_solution.(t - first + offset) with + | Positive -> + (if !time = -1 + then time:=t + else failwith "duplicate time in pseudo boolean solution") + | Negative -> () + | Unknown -> failwith "unknown value in pseudo boolean solution" + done; + (if !time = -1 + then failwith "no time in pseudo boolean solution"); + !time + ) mapper.mapper_var_offsets;; + +let pseudo_boolean_read_solution mapper channel = + let optimum = ref (-1) + and optimum_found = ref false + and solution = Array.make mapper.mapper_nr_pb_variables Unknown in + try + while true do + match input_line channel with + | "" -> () + | line -> + begin + match String.get line 0 with + | 'c' -> () + | 'o' -> + assert ((String.length line) >= 2); + assert ((String.get line 1) = ' '); + optimum := int_of_string (String.sub line 2 ((String.length line)-2)) + | 's' -> (match line with + | "s OPTIMUM FOUND" -> optimum_found := true + | "s SATISFIABLE" -> () + | "s UNSATISFIABLE" -> close_in channel; + raise Unschedulable + | _ -> failwith line) + | 'v' -> line_to_pb_solution solution line mapper.mapper_nr_pb_variables + | x -> Printf.printf "unknown: %s\n" line + end + done; + assert false + with End_of_file -> + close_in channel; + begin + let sol = pb_solution_to_schedule mapper solution in + sol + end;; + +let recompute_max_latency mapper solution = + let maxi = ref (-1) in + for i=0 to (mapper.mapper_nr_instructions-1) + do + maxi := int_max !maxi (1+solution.(i)) + done; + List.iter (fun (i, latency) -> + maxi := int_max !maxi (solution.(i) + latency)) mapper.mapper_final_predecessors; + !maxi;; + +let adjust_check_solution mapper solution = + match mapper.mapper_pb_type with + | OPTIMIZATION -> + let max_latency = recompute_max_latency mapper solution in + assert (max_latency = solution.(mapper.mapper_nr_instructions)); + solution + | SATISFIABILITY -> + let max_latency = recompute_max_latency mapper solution in + Array.init (mapper.mapper_nr_instructions+1) + (fun i -> if i < mapper.mapper_nr_instructions + then solution.(i) + else max_latency);; + +(* let pseudo_boolean_solver = ref "/local/monniaux/progs/naps/naps" *) +(* let pseudo_boolean_solver = ref "/local/monniaux/packages/sat4j/org.sat4j.pb.jar CuttingPlanes" *) + +(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar CuttingPlanes" *) +(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar" *) +(* let pseudo_boolean_solver = ref "clasp" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/open-wbo/open-wbo_static -formula=1" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) +(* let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" *) +let pseudo_boolean_solver = ref "pb_solver" + +let pseudo_boolean_scheduler pb_type problem = + try + let filename_in = "problem.opb" in + (* needed only if not using stdout and filename_out = "problem.sol" *) + let mapper = + with_out_channel (open_out filename_in) + (fun opb_problem -> + pseudo_boolean_print_problem opb_problem problem pb_type) in + Some (with_in_channel + (Unix.open_process_in (!pseudo_boolean_solver ^ " " ^ filename_in)) + (fun opb_solution -> adjust_check_solution mapper (pseudo_boolean_read_solution mapper opb_solution))) + with + | Unschedulable -> None;; + +let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = + if (get_max_latency previous_solution)>1 then + begin + Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); + flush stdout; + match scheduler + { problem with max_latency = (get_max_latency previous_solution)-1 } + with + | None -> previous_solution + | Some solution -> reoptimizing_scheduler scheduler solution problem + end + else previous_solution;; + +let smt_var i = Printf.sprintf "t%d" i + +let is_resource_used problem j = + try + Array.iter (fun usages -> + if usages.(j) > 0 + then raise Exit) problem.instruction_usages; + false + with Exit -> true;; + +let smt_use_quantifiers = false + +let smt_print_problem channel problem = + let nr_instructions = get_nr_instructions problem in + let gen_smt_resource_constraint time j = + output_string channel "(<= (+"; + Array.iteri + (fun i usages -> + let usage=usages.(j) in + if usage > 0 + then Printf.fprintf channel " (ite (= %s %s) %d 0)" + time (smt_var i) usage) + problem.instruction_usages; + Printf.fprintf channel ") %d)" problem.resource_bounds.(j) + in + output_string channel "(set-option :produce-models true)\n"; + for i=0 to nr_instructions + do + Printf.fprintf channel "(declare-const %s Int)\n" (smt_var i); + Printf.fprintf channel "(assert (>= %s 0))\n" (smt_var i) + done; + for i=0 to nr_instructions-1 + do + Printf.fprintf channel "(assert (< %s %s))\n" + (smt_var i) (smt_var nr_instructions) + done; + (if problem.max_latency > 0 + then Printf.fprintf channel "(assert (<= %s %d))\n" + (smt_var nr_instructions) problem.max_latency); + List.iter (fun ctr -> + Printf.fprintf channel "(assert (>= (- %s %s) %d))\n" + (smt_var ctr.instr_to) + (smt_var ctr.instr_from) + ctr.latency) problem.latency_constraints; + for j=0 to (Array.length problem.resource_bounds)-1 + do + if is_resource_used problem j + then + begin + if smt_use_quantifiers + then + begin + Printf.fprintf channel + "; resource #%d <= %d\n(assert (forall ((t Int)) " + j problem.resource_bounds.(j); + gen_smt_resource_constraint "t" j; + output_string channel "))\n" + end + else + begin + (if problem.max_latency < 0 + then failwith "quantifier explosion needs max latency"); + for t=0 to problem.max_latency + do + Printf.fprintf channel + "; resource #%d <= %d at t=%d\n(assert " + j problem.resource_bounds.(j) t; + gen_smt_resource_constraint (string_of_int t) j; + output_string channel ")\n" + done + end + end + done; + output_string channel "(check-sat)(get-model)\n";; + + +let ilp_print_problem channel problem pb_type = + let deadline = problem.max_latency in + assert (deadline > 0); + let nr_instructions = get_nr_instructions problem + and nr_resources = get_nr_resources problem + and successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates = get_earliest_dates predecessors + and latest_dates = get_latest_dates deadline successors in + + let pb_var i t = + Printf.sprintf "x%d_%d" i t in + + let gen_latency_constraint i_to i_from latency t_to = + Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_to; + Printf.fprintf channel "c_%d_%d_%d_%d: " + i_to i_from latency t_to; + for t_from=earliest_dates.(i_from) to + int_min latest_dates.(i_from) (t_to - latency) + do + Printf.fprintf channel "+1 %s " (pb_var i_from t_from) + done; + Printf.fprintf channel "-1 %s " (pb_var i_to t_to); + output_string channel ">= 0\n" + + and gen_dual_latency_constraint i_to i_from latency t_from = + Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_from; + Printf.fprintf channel "d_%d_%d_%d_%d: " + i_to i_from latency t_from; + for t_to=int_max earliest_dates.(i_to) (t_from + latency) + to latest_dates.(i_to) + do + Printf.fprintf channel "+1 %s " (pb_var i_to t_to) + done; + Printf.fprintf channel "-1 %s " (pb_var i_from t_from); + Printf.fprintf channel ">= 0\n" + + and gen_delta_constraint i_from i_to latency = + if delta_encoding + then Printf.fprintf channel "l_%d_%d_%d: +1 t%d -1 t%d >= %d\n" + i_from i_to latency i_to i_from latency + + in + + Printf.fprintf channel "\\ nr_instructions=%d deadline=%d\n" nr_instructions deadline; + begin + match pb_type with + | SATISFIABILITY -> output_string channel "Minimize dummy: 0\n" + | OPTIMIZATION -> + Printf.fprintf channel "Minimize\nmakespan: t%d\n" nr_instructions + end; + output_string channel "Subject To\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + Printf.fprintf channel "\\ t[%d] in %d..%d\ntimes%d: " i early late i; + for t=early to late + do + Printf.fprintf channel "+1 %s " (pb_var i t) + done; + Printf.fprintf channel "= 1\n" + done; + + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + let bound = problem.resource_bounds.(j) + and coeffs = ref [] in + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 + then coeffs := (i, usage) :: !coeffs + done; + if !coeffs <> [] then + begin + Printf.fprintf channel "\\ resource #%d at t=%d <= %d\nr%d_%d: " j t bound j t; + List.iter (fun (i, usage) -> + Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; + Printf.fprintf channel ">= %d\n" (-bound) + end + done + done; + + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions then + begin + gen_delta_constraint ctr.instr_from ctr.instr_to ctr.latency; + begin + if direct_encoding + then + for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) + do + gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to + done + end; + begin + if reverse_encoding + then + for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) + do + gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from + done + end + end + ) problem.latency_constraints; + + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + let final_latencies = Array.make nr_instructions 1 in + List.iter (fun (i, latency) -> + final_latencies.(i) <- int_max final_latencies.(i) latency) + predecessors.(nr_instructions); + for i_from = 0 to nr_instructions -1 + do + gen_delta_constraint i_from nr_instructions final_latencies.(i_from) + done; + for t_to=earliest_dates.(nr_instructions) to deadline + do + for i_from = 0 to nr_instructions -1 + do + gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to + done + done + end; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + Printf.fprintf channel "ct%d : -1 t%d" i i; + let early = earliest_dates.(i) and late= latest_dates.(i) in + for t=early to late do + Printf.fprintf channel " +%d %s" t (pb_var i t) + done; + output_string channel " = 0\n" + done; + output_string channel "Bounds\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + begin + Printf.fprintf channel "%d <= t%d <= %d\n" early i late; + if true then + for t=early to late do + Printf.fprintf channel "0 <= %s <= 1\n" (pb_var i t) + done + end + done; + output_string channel "Integer\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + Printf.fprintf channel "t%d " i + done; + output_string channel "\nBinary\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + for t=early to late do + output_string channel (pb_var i t); + output_string channel " " + done; + output_string channel "\n" + done; + output_string channel "End\n"; + { + mapper_pb_type = pb_type; + mapper_nr_instructions = nr_instructions; + mapper_nr_pb_variables = 0; + mapper_earliest_dates = earliest_dates; + mapper_latest_dates = latest_dates; + mapper_var_offsets = [| |]; + mapper_final_predecessors = predecessors.(nr_instructions) + };; + +(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) + +let positive_float_round x = truncate (x +. 0.5) + +let float_round (x : float) : int = + if x > 0.0 + then positive_float_round x + else - (positive_float_round (-. x)) + +let rounded_int_of_string x = float_round (float_of_string x) + +let ilp_read_solution mapper channel = + let times = Array.make + (match mapper.mapper_pb_type with + | OPTIMIZATION -> 1+mapper.mapper_nr_instructions + | SATISFIABILITY -> mapper.mapper_nr_instructions) (-1) in + try + while true do + let line = input_line channel in + ( if (String.length line) < 3 + then failwith (Printf.sprintf "bad ilp output: length(line) < 3: %s" line)); + match String.get line 0 with + | 'x' -> () + | 't' -> let space = + try String.index line ' ' + with Not_found -> + failwith "bad ilp output: no t variable number" + in + let tnumber = + try int_of_string (String.sub line 1 (space-1)) + with Failure _ -> + failwith "bad ilp output: not a variable number" + in + (if tnumber < 0 || tnumber >= (Array.length times) + then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); + let value = + let s = String.sub line (space+1) ((String.length line)-space-1) in + try rounded_int_of_string s + with Failure _ -> + failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s) + in + (if value < 0 + then failwith "bad ilp output: negative time"); + times.(tnumber) <- value + | '#' -> () + | '0' -> () + | _ -> failwith (Printf.sprintf "bad ilp output: bad variable initial, line = %s" line) + done; + assert false + with End_of_file -> + Array.iteri (fun i x -> + if i<(Array.length times)-1 + && x<0 then raise Unschedulable) times; + times;; + +let ilp_solver = ref "ilp_solver" + +let problem_nr = ref 0 + +let ilp_scheduler pb_type problem = + try + let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr + and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in + incr problem_nr; + let mapper = with_out_channel (open_out filename_in) + (fun opb_problem -> ilp_print_problem opb_problem problem pb_type) in + + begin + match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with + | Unix.WEXITED 0 -> + Some (with_in_channel + (open_in filename_out) + (fun opb_solution -> + adjust_check_solution mapper + (ilp_read_solution mapper opb_solution))) + | Unix.WEXITED _ -> failwith "failed to start ilp solver" + | _ -> None + end + with + | Unschedulable -> None;; + +let current_utime_all () = + let t = Unix.times() in + t.Unix.tms_cutime +. t.Unix.tms_utime;; + +let utime_all_fn fn arg = + let utime_start = current_utime_all () in + let output = fn arg in + let utime_end = current_utime_all () in + (output, utime_end -. utime_start);; + +let cascaded_scheduler (problem : problem) = + let (some_initial_solution, list_scheduler_time) = + utime_all_fn (validated_scheduler list_scheduler) problem in + match some_initial_solution with + | None -> None + | Some initial_solution -> + let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in + begin + let latency2 = get_max_latency solution + and latency1 = get_max_latency initial_solution in + Printf.printf "postpass %s: %d, %d, %d, %g, %g\n" + (if latency2 < latency1 then "REOPTIMIZED" else "unchanged") + (get_nr_instructions problem) + latency1 latency2 + list_scheduler_time reoptimizing_time; + flush stdout + end; + Some solution;; + +let scheduler_by_name name = + match name with + | "ilp" -> validated_scheduler cascaded_scheduler + | "list" -> validated_scheduler list_scheduler + | "revlist" -> validated_scheduler reverse_list_scheduler + | "greedy" -> greedy_scheduler + | s -> failwith ("unknown scheduler: " ^ s);; diff --git a/scheduling/InstructionScheduler.mli b/scheduling/InstructionScheduler.mli new file mode 100644 index 00000000..85e2a5c6 --- /dev/null +++ b/scheduling/InstructionScheduler.mli @@ -0,0 +1,113 @@ +(** Schedule instructions on a synchronized pipeline +by David Monniaux, CNRS, VERIMAG *) + +(** A latency constraint: instruction number [instr_to] should be scheduled at least [latency] clock ticks before [instr_from]. + +It is possible to specify [latency]=0, meaning that [instr_to] can be scheduled at the same clock tick as [instr_from], but not before. + +[instr_to] can be the special value equal to the number of instructions, meaning that it refers to the final output latency. *) +type latency_constraint = { + instr_from : int; + instr_to : int; + latency : int; + } + +(** A scheduling problem. + +In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. +*) +type problem = { + max_latency : int; + (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) + + resource_bounds : int array; + (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) + + instruction_usages: int array array; + (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) + + latency_constraints : latency_constraint list + (** The latency constraints that must be satisfied *) + };; + +(** Print problem for human readability. *) +val print_problem : out_channel -> problem -> unit;; + +(** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) +type solution = int array + +(** A scheduling algorithm. +The return value [Some x] is a solution [x]. +[None] means that scheduling failed. *) +type scheduler = problem -> solution option;; + +(* DISABLED +(** Schedule the problem optimally by constraint solving using the Gecode solver. *) +external gecode_scheduler : problem -> solution option + = "caml_gecode_schedule_instr" + *) + +(** Get the number the last scheduling time used for an instruction in a solution. +@return The last clock tick used *) +val maximum_slot_used : solution -> int + +(** Validate that a solution is truly a solution of a scheduling problem. +@raise Failure if validation fails *) +val check_schedule : problem -> solution -> unit + +(** Schedule the problem using a greedy list scheduling algorithm, from the start. +The first (according to instruction ordering) instruction that is ready (according to the latency constraints) is scheduled at the current clock tick. +Once a clock tick is full go to the next. + +@return [Some solution] when a solution is found, [None] if not. *) +val list_scheduler : problem -> solution option + +(** Schedule the problem using the order of instructions without any reordering *) +val greedy_scheduler : problem -> solution option + +(** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) +val schedule_reversed : scheduler -> problem -> int array option + +(** Schedule a problem from the end using a list scheduler. BUGGY *) +val reverse_list_scheduler : problem -> int array option + +(** Check that a problem is well-formed. +@raise Failure if validation fails *) +val check_problem : problem -> unit + +(** Apply a scheduler and validate the result against the input problem. +@return The solution found +@raise Failure if validation fails *) +val validated_scheduler : scheduler -> problem -> solution option;; + +(** Get max latency from solution +@return Max latency *) +val get_max_latency : solution -> int;; + +(** Get the length of a maximal critical path +@return Max length *) +val maximum_critical_path : problem -> int;; + +(** Apply line scheduler then advanced solver +@return A solution if found *) +val cascaded_scheduler : problem -> solution option;; + +val show_date_ranges : problem -> unit;; + +type pseudo_boolean_problem_type = + | SATISFIABILITY + | OPTIMIZATION;; + +type pseudo_boolean_mapper +val pseudo_boolean_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; +val pseudo_boolean_read_solution : pseudo_boolean_mapper -> in_channel -> solution;; +val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; + +val smt_print_problem : out_channel -> problem -> unit;; + +val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; + +val ilp_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; + +(** Schedule a problem using a scheduler given by a string name *) +val scheduler_by_name : string -> problem -> int array option;; diff --git a/scheduling/PrepassSchedulingOracle.ml b/scheduling/PrepassSchedulingOracle.ml new file mode 100644 index 00000000..78961310 --- /dev/null +++ b/scheduling/PrepassSchedulingOracle.ml @@ -0,0 +1,432 @@ +open AST +open RTL +open Maps +open InstructionScheduler +open OpWeights +open Registers + +let use_alias_analysis () = false + +let length_of_chunk = function +| Mint8signed +| Mint8unsigned -> 1 +| Mint16signed +| Mint16unsigned -> 2 +| Mint32 +| Mfloat32 +| Many32 -> 4 +| Mint64 +| Mfloat64 +| Many64 -> 8;; + +let get_simple_dependencies (seqa : (instruction*Regset.t) array) = + let last_reg_reads : int list PTree.t ref = ref PTree.empty + and last_reg_write : (int*int) PTree.t ref = ref PTree.empty + and last_mem_reads : int list ref = ref [] + and last_mem_write : int option ref = ref None + and last_branch : int option ref = ref None + and latency_constraints : latency_constraint list ref = ref [] in + let add_constraint instr_from instr_to latency = + assert (instr_from <= instr_to); + assert (latency >= 0); + if instr_from = instr_to + then (if latency = 0 + then () + else failwith "PrepassSchedulingOracle.get_dependencies: negative self-loop") + else + latency_constraints := + { instr_from = instr_from; + instr_to = instr_to; + latency = latency + }:: !latency_constraints + and get_last_reads reg = + match PTree.get reg !last_reg_reads + with Some l -> l + | None -> [] in + let add_input_mem i = + if not (use_alias_analysis ()) + then + begin + begin + (* Read after write *) + match !last_mem_write with + | None -> () + | Some j -> add_constraint j i 1 + end; + last_mem_reads := i :: !last_mem_reads + end + and add_output_mem i = + if not (use_alias_analysis ()) + then + begin + begin + (* Write after write *) + match !last_mem_write with + | None -> () + | Some j -> add_constraint j i 1 + end; + (* Write after read *) + List.iter (fun j -> add_constraint j i 0) !last_mem_reads; + last_mem_write := Some i; + last_mem_reads := [] + end + and add_input_reg i reg = + begin + (* Read after write *) + match PTree.get reg !last_reg_write with + | None -> () + | Some (j, latency) -> add_constraint j i latency + end; + last_reg_reads := PTree.set reg + (i :: get_last_reads reg) + !last_reg_reads + and add_output_reg i latency reg = + begin + (* Write after write *) + match PTree.get reg !last_reg_write with + | None -> () + | Some (j, _) -> add_constraint j i 1 + end; + begin + (* Write after read *) + List.iter (fun j -> add_constraint j i 0) (get_last_reads reg) + end; + last_reg_write := PTree.set reg (i, latency) !last_reg_write; + last_reg_reads := PTree.remove reg !last_reg_reads + in + let add_input_regs i regs = List.iter (add_input_reg i) regs in + let rec add_builtin_res i (res : reg builtin_res) = + match res with + | BR r -> add_output_reg i 10 r + | BR_none -> () + | BR_splitlong (hi, lo) -> add_builtin_res i hi; + add_builtin_res i lo in + let rec add_builtin_arg i (ba : reg builtin_arg) = + match ba with + | BA r -> add_input_reg i r + | BA_int _ | BA_long _ | BA_float _ | BA_single _ -> () + | BA_loadstack(_,_) -> add_input_mem i + | BA_addrstack _ -> () + | BA_loadglobal(_, _, _) -> add_input_mem i + | BA_addrglobal _ -> () + | BA_splitlong(hi, lo) -> add_builtin_arg i hi; + add_builtin_arg i lo + | BA_addptr(a1, a2) -> add_builtin_arg i a1; + add_builtin_arg i a2 in + let irreversible_action i = + match !last_branch with + | None -> () + | Some j -> add_constraint j i 1 in + let set_branch i = + irreversible_action i; + last_branch := Some i + in + Array.iteri + begin + fun i (insn, other_uses) -> + List.iter (fun use -> + add_input_reg i use) + (Regset.elements other_uses); + + match insn with + | Inop _ -> () + | Iop(op, inputs, output, _) -> + (if Op.is_trapping_op op then irreversible_action i); + add_input_regs i inputs; + add_output_reg i (latency_of_op op (List.length inputs)) output + | Iload(trap, chunk, addressing, addr_regs, output, _) -> + (if trap=TRAP then irreversible_action i); + add_input_mem i; + add_input_regs i addr_regs; + add_output_reg i (latency_of_load trap chunk addressing (List.length addr_regs)) output + | Istore(chunk, addressing, addr_regs, input, _) -> + irreversible_action i; + add_input_regs i addr_regs; + add_input_reg i input; + add_output_mem i + | Icall(signature, ef, inputs, output, _) -> + set_branch i; + (match ef with + | Datatypes.Coq_inl r -> add_input_reg i r + | Datatypes.Coq_inr symbol -> () + ); + add_input_mem i; + add_input_regs i inputs; + add_output_reg i (latency_of_call signature ef) output; + add_output_mem i; + failwith "Icall" + | Itailcall(signature, ef, inputs) -> + set_branch i; + (match ef with + | Datatypes.Coq_inl r -> add_input_reg i r + | Datatypes.Coq_inr symbol -> () + ); + add_input_mem i; + add_input_regs i inputs; + failwith "Itailcall" + | Ibuiltin(ef, builtin_inputs, builtin_output, _) -> + set_branch i; + add_input_mem i; + List.iter (add_builtin_arg i) builtin_inputs; + add_builtin_res i builtin_output; + add_output_mem i; + failwith "Ibuiltin" + | Icond(cond, inputs, _, _, _) -> + set_branch i; + add_input_mem i; + add_input_regs i inputs + | Ijumptable(input, _) -> + set_branch i; + add_input_reg i input; + failwith "Ijumptable" + | Ireturn(Some input) -> + set_branch i; + add_input_reg i input; + failwith "Ireturn" + | Ireturn(None) -> + set_branch i; + failwith "Ireturn none" + end seqa; + !latency_constraints;; + +let resources_of_instruction = function + | Inop _ -> Array.map (fun _ -> 0) resource_bounds + | Iop(op, inputs, output, _) -> resources_of_op op (List.length inputs) + | Iload(trap, chunk, addressing, addr_regs, output, _) -> + resources_of_load trap chunk addressing (List.length addr_regs) + | Istore(chunk, addressing, addr_regs, input, _) -> + resources_of_store chunk addressing (List.length addr_regs) + | Icall(signature, ef, inputs, output, _) -> + resources_of_call signature ef + | Ibuiltin(ef, builtin_inputs, builtin_output, _) -> + resources_of_builtin ef + | Icond(cond, args, _, _ , _) -> + resources_of_cond cond (List.length args) + | Itailcall _ | Ijumptable _ | Ireturn _ -> resource_bounds + +let print_sequence pp (seqa : instruction array) = + Array.iteri ( + fun i (insn : instruction) -> + PrintRTL.print_instruction pp (i, insn)) seqa;; + +type unique_id = int + +type 'a symbolic_term_node = + | STop of Op.operation * 'a list + | STinitial_reg of int + | STother of int;; + +type symbolic_term = { + hash_id : unique_id; + hash_ct : symbolic_term symbolic_term_node + };; + +let rec print_term channel term = + match term.hash_ct with + | STop(op, args) -> + PrintOp.print_operation print_term channel (op, args) + | STinitial_reg n -> Printf.fprintf channel "x%d" n + | STother n -> Printf.fprintf channel "y%d" n;; + +type symbolic_term_table = { + st_table : (unique_id symbolic_term_node, symbolic_term) Hashtbl.t; + mutable st_next_id : unique_id };; + +let hash_init () = { + st_table = Hashtbl.create 20; + st_next_id = 0 + };; + +let ground_to_id = function + | STop(op, l) -> STop(op, List.map (fun t -> t.hash_id) l) + | STinitial_reg r -> STinitial_reg r + | STother i -> STother i;; + +let hash_node (table : symbolic_term_table) (term : symbolic_term symbolic_term_node) : symbolic_term = + let grounded = ground_to_id term in + match Hashtbl.find_opt table.st_table grounded with + | Some x -> x + | None -> + let term' = { hash_id = table.st_next_id; + hash_ct = term } in + (if table.st_next_id = max_int then failwith "hash: max_int"); + table.st_next_id <- table.st_next_id + 1; + Hashtbl.add table.st_table grounded term'; + term';; + +type access = { + base : symbolic_term; + offset : int64; + length : int + };; + +let term_equal a b = (a.hash_id = b.hash_id);; + +let access_of_addressing get_reg chunk addressing args = + match addressing, args with + | (Op.Aindexed ofs), [reg] -> Some + { base = get_reg reg; + offset = Camlcoq.camlint64_of_ptrofs ofs; + length = length_of_chunk chunk + } + | _, _ -> None ;; +(* TODO: global *) + +let symbolic_execution (seqa : instruction array) = + let regs = ref PTree.empty + and table = hash_init() in + let assign reg term = regs := PTree.set reg term !regs + and hash term = hash_node table term in + let get_reg reg = + match PTree.get reg !regs with + | None -> hash (STinitial_reg (Camlcoq.P.to_int reg)) + | Some x -> x in + let targets = Array.make (Array.length seqa) None in + Array.iteri + begin + fun i insn -> + match insn with + | Iop(Op.Omove, [input], output, _) -> + assign output (get_reg input) + | Iop(op, inputs, output, _) -> + assign output (hash (STop(op, List.map get_reg inputs))) + + | Iload(trap, chunk, addressing, args, output, _) -> + let access = access_of_addressing get_reg chunk addressing args in + targets.(i) <- access; + assign output (hash (STother(i))) + + | Icall(_, _, _, output, _) + | Ibuiltin(_, _, BR output, _) -> + assign output (hash (STother(i))) + + | Istore(chunk, addressing, args, va, _) -> + let access = access_of_addressing get_reg chunk addressing args in + targets.(i) <- access + + | Inop _ -> () + | Ibuiltin(_, _, BR_none, _) -> () + | Ibuiltin(_, _, BR_splitlong _, _) -> failwith "BR_splitlong" + + | Itailcall (_, _, _) + |Icond (_, _, _, _, _) + |Ijumptable (_, _) + |Ireturn _ -> () + end seqa; + targets;; + +let print_access channel = function + | None -> Printf.fprintf channel "any" + | Some x -> Printf.fprintf channel "%a + %Ld" print_term x.base x.offset;; + +let print_targets channel seqa = + let targets = symbolic_execution seqa in + Array.iteri + (fun i insn -> + match insn with + | Iload _ -> Printf.fprintf channel "%d: load %a\n" + i print_access targets.(i) + | Istore _ -> Printf.fprintf channel "%d: store %a\n" + i print_access targets.(i) + | _ -> () + ) seqa;; + +let may_overlap a0 b0 = + match a0, b0 with + | (None, _) | (_ , None) -> true + | (Some a), (Some b) -> + if term_equal a.base b.base + then (max a.offset b.offset) < + (min (Int64.add (Int64.of_int a.length) a.offset) + (Int64.add (Int64.of_int b.length) b.offset)) + else match a.base.hash_ct, b.base.hash_ct with + | STop(Op.Oaddrsymbol(ida, ofsa),[]), + STop(Op.Oaddrsymbol(idb, ofsb),[]) -> + (ida=idb) && + let ao = Int64.add a.offset (Camlcoq.camlint64_of_ptrofs ofsa) + and bo = Int64.add b.offset (Camlcoq.camlint64_of_ptrofs ofsb) in + (max ao bo) < + (min (Int64.add (Int64.of_int a.length) ao) + (Int64.add (Int64.of_int b.length) bo)) + | STop(Op.Oaddrstack _, []), + STop(Op.Oaddrsymbol _, []) + | STop(Op.Oaddrsymbol _, []), + STop(Op.Oaddrstack _, []) -> false + | STop(Op.Oaddrstack(ofsa),[]), + STop(Op.Oaddrstack(ofsb),[]) -> + let ao = Int64.add a.offset (Camlcoq.camlint64_of_ptrofs ofsa) + and bo = Int64.add b.offset (Camlcoq.camlint64_of_ptrofs ofsb) in + (max ao bo) < + (min (Int64.add (Int64.of_int a.length) ao) + (Int64.add (Int64.of_int b.length) bo)) + | _ -> true;; + +(* +(* TODO suboptimal quadratic algorithm *) +let get_alias_dependencies seqa = + let targets = symbolic_execution seqa + and deps = ref [] in + let add_constraint instr_from instr_to latency = + deps := { instr_from = instr_from; + instr_to = instr_to; + latency = latency + }:: !deps in + for i=0 to (Array.length seqa)-1 + do + for j=0 to i-1 + do + match seqa.(j), seqa.(i) with + | (Istore _), ((Iload _) | (Istore _)) -> + if may_overlap targets.(j) targets.(i) + then add_constraint j i 1 + | (Iload _), (Istore _) -> + if may_overlap targets.(j) targets.(i) + then add_constraint j i 0 + | (Istore _ | Iload _), (Icall _ | Ibuiltin _) + | (Icall _ | Ibuiltin _), (Icall _ | Ibuiltin _ | Iload _ | Istore _) -> + add_constraint j i 1 + | (Inop _ | Iop _), _ + | _, (Inop _ | Iop _) + | (Iload _), (Iload _) -> () + done + done; + !deps;; + *) + +let define_problem seqa = + let simple_deps = get_simple_dependencies seqa in + { max_latency = -1; + resource_bounds = OpWeights.resource_bounds; + instruction_usages = Array.map resources_of_instruction (Array.map fst seqa); + latency_constraints = + (* if (use_alias_analysis ()) + then (get_alias_dependencies seqa) @ simple_deps + else *) simple_deps };; + +let schedule_sequence (seqa : (instruction*Regset.t) array) = + try + if (Array.length seqa) <= 1 + then None + else + begin + let nr_instructions = Array.length seqa in + Printf.printf "prepass scheduling length = %d\n" (Array.length seqa); + let problem = define_problem seqa in + print_sequence stdout (Array.map fst seqa); + print_problem stdout problem; + match scheduler_by_name (!Clflags.option_fprepass_sched) problem with + | None -> Printf.printf "no solution in prepass scheduling\n"; + None + | Some solution -> + let positions = Array.init nr_instructions (fun i -> i) in + Array.sort (fun i j -> + let si = solution.(i) and sj = solution.(j) in + if si < sj then -1 + else if si > sj then 1 + else i - j) positions; + Some positions + end + with (Failure s) -> + Printf.printf "failure in prepass scheduling: %s\n" s; + None;; + diff --git a/scheduling/RTLpath.v b/scheduling/RTLpath.v new file mode 100644 index 00000000..82991a4d --- /dev/null +++ b/scheduling/RTLpath.v @@ -0,0 +1,1066 @@ +(** We introduce a data-structure extending the RTL CFG into a control-flow graph over "traces" (in the sense of "trace-scheduling") + Here, we use the word "path" instead of "trace" because "trace" has already a meaning in CompCert: + a "path" is simply a list of successive nodes in the CFG (modulo some additional wellformness conditions). + + Actually, we extend syntactically the notion of RTL programs with a structure of "path_map": + this gives an alternative view of the CFG -- where "nodes" are paths instead of simple instructions. + Our wellformness condition on paths express that: + - the CFG on paths is wellformed: any successor of a given path points to another path (possibly the same). + - execution of a paths only emit single events. + + We represent each path only by a natural: the number of nodes in the path. These nodes are recovered from a static notion of "default successor". + This notion of path is thus incomplete. For example, if a path contains a whole loop (and for example, unrools it several times), + then this loop must be a suffix of the path. + + However: it is sufficient in order to represent superblocks (each superblock being represented as a path). + A superblock decomposition of the CFG exactly corresponds to the case where each node is in at most one path. + + Our goal is to provide two bisimulable semantics: + - one is simply the RTL semantics + - the other is based on a notion of "path-step": each path is executed in a single step. + + Remark that all analyses on RTL programs should thus be appliable for "free" also for RTLpath programs ! +*) + +Require Import Coqlib Maps. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL Linking. + +Declare Scope option_monad_scope. + +Notation "'SOME' X <- A 'IN' B" := (match A with Some X => B | None => None end) + (at level 200, X ident, A at level 100, B at level 200) + : option_monad_scope. + +Notation "'ASSERT' A 'IN' B" := (if A then B else None) + (at level 200, A at level 100, B at level 200) + : option_monad_scope. + +Local Open Scope option_monad_scope. + +(** * Syntax of RTLpath programs *) + +(** Internal instruction = instruction with a default successor in a path. *) + +Definition default_succ (i: instruction): option node := + match i with + | Inop s => Some s + | Iop op args res s => Some s + | Iload _ chunk addr args dst s => Some s + | Istore chunk addr args src s => Some s + | Icond cond args ifso ifnot _ => Some ifnot + | _ => None (* TODO: we could choose a successor for jumptable ? *) + end. + +Definition early_exit (i: instruction): option node := (* FIXME: for jumptable, replace [node] by [list node] *) + match i with + | Icond cond args ifso ifnot _ => Some ifso + | _ => None + end. + +(** Our notion of path. + + We do not formally require that the set of path is a partition of the CFG. + path may have intersections ! + + Moreover, we do not formally require that path have a single entry-point (a superblock structure) + + But, in practice, these properties are probably necessary in order to ensure the success of dynamic verification of scheduling. + + Here: we only require that each exit-point of a path is the entry-point of a path + (and that internal node of a path are internal instructions) +*) + + +(* By convention, we say that node [n] is the entry-point of a path if it is a key of the path_map. + + Such a path of entry [n] is defined from a natural [path] representing the [path] default-successors of [n]. + + Remark: a path can loop several times in the CFG. + +*) + +Record path_info := { + psize: nat; (* number minus 1 of instructions in the path *) + input_regs: Regset.t; + (** Registers that are used (as input_regs) by the "fallthrough successors" of the path *) + (** This field is not used by the verificator, but is helpful for the superblock scheduler *) + output_regs: Regset.t +}. + +Definition path_map: Type := PTree.t path_info. + +Definition path_entry (*c:code*) (pm: path_map) (n: node): Prop + := pm!n <> None (*/\ c!n <> None*). + +Inductive wellformed_path (c:code) (pm: path_map): nat -> node -> Prop := + | wf_last_node i pc: + c!pc = Some i -> + (forall n, List.In n (successors_instr i) -> path_entry (*c*) pm n) -> + wellformed_path c pm 0 pc + | wf_internal_node path i pc pc': + c!pc = Some i -> + default_succ i = Some pc' -> + (forall n, early_exit i = Some n -> path_entry (*c*) pm n) -> + wellformed_path c pm path pc' -> + wellformed_path c pm (S path) pc. + +(* all paths defined from the path_map are wellformed *) +Definition wellformed_path_map (c:code) (pm: path_map): Prop := + forall n path, pm!n = Some path -> wellformed_path c pm path.(psize) n. + +(** We "extend" the notion of RTL program with the additional structure for path. + + There is thus a trivial "forgetful functor" from RTLpath programs to RTL ones. +*) + +Record function : Type := + { fn_RTL:> RTL.function; + fn_path: path_map; + (* condition 1 below: the entry-point of the code is an entry-point of a path *) + fn_entry_point_wf: path_entry (*fn_RTL.(fn_code)*) fn_path fn_RTL.(fn_entrypoint); + (* condition 2 below: the path_map is well-formed *) + fn_path_wf: wellformed_path_map fn_RTL.(fn_code) fn_path + }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition fundef_RTL (fu: fundef) : RTL.fundef := + match fu with + | Internal f => Internal f.(fn_RTL) + | External ef => External ef + end. +Coercion fundef_RTL: fundef >-> RTL.fundef. + +Definition transf_program (p: program) : RTL.program := transform_program fundef_RTL p. +Coercion transf_program: program >-> RTL.program. + +(** * Path-step semantics of RTLpath programs *) + +(* Semantics of internal instructions (mimicking RTL semantics) *) + +Record istate := mk_istate { icontinue: bool; ipc: node; irs: regset; imem: mem }. + +(* FIXME - prediction *) +(* Internal step through the path *) +Definition istep (ge: RTL.genv) (i: instruction) (sp: val) (rs: regset) (m: mem): option istate := + match i with + | Inop pc' => Some (mk_istate true pc' rs m) + | Iop op args res pc' => + SOME v <- eval_operation ge sp op rs##args m IN + Some (mk_istate true pc' (rs#res <- v) m) + | Iload TRAP chunk addr args dst pc' => + SOME a <- eval_addressing ge sp addr rs##args IN + SOME v <- Mem.loadv chunk m a IN + Some (mk_istate true pc' (rs#dst <- v) m) + | Iload NOTRAP chunk addr args dst pc' => + let default_state := mk_istate true pc' rs#dst <- (default_notrap_load_value chunk) m in + match (eval_addressing ge sp addr rs##args) with + | None => Some default_state + | Some a => match (Mem.loadv chunk m a) with + | None => Some default_state + | Some v => Some (mk_istate true pc' (rs#dst <- v) m) + end + end + | Istore chunk addr args src pc' => + SOME a <- eval_addressing ge sp addr rs##args IN + SOME m' <- Mem.storev chunk m a rs#src IN + Some (mk_istate true pc' rs m') + | Icond cond args ifso ifnot _ => + SOME b <- eval_condition cond rs##args m IN + Some (mk_istate (negb b) (if b then ifso else ifnot) rs m) + | _ => None (* TODO jumptable ? *) + end. + +(** Execution of a path in a single step *) + +(* Executes until a state [st] is reached where st.(continue) is false *) +Fixpoint isteps ge (path:nat) (f: function) sp rs m pc: option istate := + match path with + | O => Some (mk_istate true pc rs m) + | S p => + SOME i <- (fn_code f)!pc IN + SOME st <- istep ge i sp rs m IN + if (icontinue st) then + isteps ge p f sp (irs st) (imem st) (ipc st) + else + Some st + end. + +Definition find_function (pge: genv) (ros: reg + ident) (rs: regset) : option fundef := + match ros with + | inl r => Genv.find_funct pge rs#r + | inr symb => + match Genv.find_symbol pge symb with + | None => None + | Some b => Genv.find_funct_ptr pge b + end + end. + +Inductive stackframe : Type := + | Stackframe + (res: reg) (**r where to store the result *) + (f: function) (**r calling function *) + (sp: val) (**r stack pointer in calling function *) + (pc: node) (**r program point in calling function *) + (rs: regset) (**r register state in calling function *) + . + +Definition stf_RTL (st: stackframe): RTL.stackframe := + match st with + | Stackframe res f sp pc rs => RTL.Stackframe res f sp pc rs + end. + +Fixpoint stack_RTL (stack: list stackframe): list RTL.stackframe := + match stack with + | nil => nil + | cons stf stack' => cons (stf_RTL stf) (stack_RTL stack') + end. + +Inductive state : Type := + | State + (stack: list stackframe) (**r call stack *) + (f: function) (**r current function *) + (sp: val) (**r stack pointer *) + (pc: node) (**r current program point in [c] *) + (rs: regset) (**r register state *) + (m: mem) (**r memory state *) + | Callstate + (stack: list stackframe) (**r call stack *) + (f: fundef) (**r function to call *) + (args: list val) (**r arguments to the call *) + (m: mem) (**r memory state *) + | Returnstate + (stack: list stackframe) (**r call stack *) + (v: val) (**r return value for the call *) + (m: mem) (**r memory state *) + . + +Definition state_RTL (s: state): RTL.state := + match s with + | State stack f sp pc rs m => RTL.State (stack_RTL stack) f sp pc rs m + | Callstate stack f args m => RTL.Callstate (stack_RTL stack) f args m + | Returnstate stack v m => RTL.Returnstate (stack_RTL stack) v m + end. +Coercion state_RTL: state >-> RTL.state. + +(* Used to execute the last instruction of a path (isteps is only in charge of executing the instructions before the last) *) +Inductive path_last_step ge pge stack (f: function): val -> node -> regset -> mem -> trace -> state -> Prop := + | exec_istate i sp pc rs m st: + (fn_code f)!pc = Some i -> + istep ge i sp rs m = Some st -> + path_last_step ge pge stack f sp pc rs m + E0 (State stack f sp (ipc st) (irs st) (imem st)) + | exec_Icall sp pc rs m sig ros args res pc' fd: + (fn_code f)!pc = Some(Icall sig ros args res pc') -> + find_function pge ros rs = Some fd -> + funsig fd = sig -> + path_last_step ge pge stack f sp pc rs m + E0 (Callstate (Stackframe res f sp pc' rs :: stack) fd rs##args m) + | exec_Itailcall stk pc rs m sig ros args fd m': + (fn_code f)!pc = Some(Itailcall sig ros args) -> + find_function pge ros rs = Some fd -> + funsig fd = sig -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + path_last_step ge pge stack f (Vptr stk Ptrofs.zero) pc rs m + E0 (Callstate stack fd rs##args m') + | exec_Ibuiltin sp pc rs m ef args res pc' vargs t vres m': + (fn_code f)!pc = Some(Ibuiltin ef args res pc') -> + eval_builtin_args ge (fun r => rs#r) sp m args vargs -> + external_call ef ge vargs m t vres m' -> + path_last_step ge pge stack f sp pc rs m + t (State stack f sp pc' (regmap_setres res vres rs) m') + | exec_Ijumptable sp pc rs m arg tbl n pc': (* TODO remove jumptable from here ? *) + (fn_code f)!pc = Some(Ijumptable arg tbl) -> + rs#arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> + path_last_step ge pge stack f sp pc rs m + E0 (State stack f sp pc' rs m) + | exec_Ireturn stk pc rs m or m': + (fn_code f)!pc = Some(Ireturn or) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + path_last_step ge pge stack f (Vptr stk Ptrofs.zero) pc rs m + E0 (Returnstate stack (regmap_optget or Vundef rs) m'). + +(* Executes an entire path *) +Inductive path_step ge pge (path:nat) stack f sp rs m pc: trace -> state -> Prop := + | exec_early_exit st: + isteps ge path f sp rs m pc = Some st -> + (icontinue st) = false -> + path_step ge pge path stack f sp rs m pc E0 (State stack f sp (ipc st) (irs st) (imem st)) + | exec_normal_exit st t s: + isteps ge path f sp rs m pc = Some st -> + (icontinue st) = true -> + path_last_step ge pge stack f sp (ipc st) (irs st) (imem st) t s -> + path_step ge pge path stack f sp rs m pc t s. + +(* Either internal path execution, or the usual exec_function / exec_return borrowed from RTL *) +Inductive step ge pge: state -> trace -> state -> Prop := + | exec_path path stack f sp rs m pc t s: + (fn_path f)!pc = Some path -> + path_step ge pge path.(psize) stack f sp rs m pc t s -> + step ge pge (State stack f sp pc rs m) t s + | exec_function_internal s f args m m' stk: + Mem.alloc m 0 (fn_RTL f).(fn_stacksize) = (m', stk) -> + step ge pge (Callstate s (Internal f) args m) + E0 (State s + f + (Vptr stk Ptrofs.zero) + f.(fn_entrypoint) + (init_regs args f.(fn_params)) + m') + | exec_function_external s ef args res t m m': + external_call ef ge args m t res m' -> + step ge pge (Callstate s (External ef) args m) + t (Returnstate s res m') + | exec_return res f sp pc rs s vres m: + step ge pge (Returnstate (Stackframe res f sp pc rs :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) m). + +Inductive initial_state (p:program) : state -> Prop := + initial_state_intro (b : block) (f : fundef) (m0 : mem): + Genv.init_mem p = Some m0 -> + Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b -> + Genv.find_funct_ptr (Genv.globalenv p) b = Some f -> + funsig f = signature_main -> initial_state p (Callstate nil f nil m0). + +Definition final_state (st: state) (i:int): Prop + := RTL.final_state st i. + +Definition semantics (p: program) := + Semantics (step (Genv.globalenv (transf_program p))) (initial_state p) final_state (Genv.globalenv p). + +(** * Proving the bisimulation between (semantics p) and (RTL.semantics p). *) + +(** ** Preliminaries: simple tactics for option-monad *) + +Lemma destruct_SOME A B (P: option B -> Prop) (e: option A) (f: A -> option B): + (forall x, e = Some x -> P (f x)) -> (e = None -> P None) -> (P (SOME x <- e IN f x)). +Proof. + intros; destruct e; simpl; auto. +Qed. + +Lemma destruct_ASSERT B (P: option B -> Prop) (e: bool) (x: option B): + (e = true -> P x) -> (e = false -> P None) -> (P (ASSERT e IN x)). +Proof. + intros; destruct e; simpl; auto. +Qed. + +Ltac inversion_SOME x := + try (eapply destruct_SOME; [ let x := fresh x in intro x | simpl; try congruence ]). + +Ltac inversion_ASSERT := + try (eapply destruct_ASSERT; [ idtac | simpl; try congruence ]). + +Ltac simplify_someHyp := + match goal with + | H: None = Some _ |- _ => inversion H; clear H; subst + | H: Some _ = None |- _ => inversion H; clear H; subst + | H: ?t = ?t |- _ => clear H + | H: Some _ = Some _ |- _ => inversion H; clear H; subst + | H: Some _ <> None |- _ => clear H + | H: None <> Some _ |- _ => clear H + | H: _ = Some _ |- _ => (try rewrite !H in * |- *); generalize H; clear H + end. + +Ltac explore_destruct := + repeat (match goal with + | [H: ?expr = ?val |- context[match ?expr with | _ => _ end]] => rewrite H + | [H: match ?var with | _ => _ end |- _] => destruct var + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | _ => discriminate + end). + +Ltac simplify_someHyps := + repeat (simplify_someHyp; simpl in * |- *). + +Ltac try_simplify_someHyps := + try (intros; simplify_someHyps; eauto). + +(* TODO: try to improve this tactic with a better control over names and inversion *) +Ltac simplify_SOME x := + (repeat inversion_SOME x); try_simplify_someHyps. + +(** ** The easy way: Forward simulation of RTLpath by RTL + +This way can be viewed as a correctness property: all transitions in RTLpath are valid RTL transitions ! + +*) + +Local Hint Resolve RTL.exec_Inop RTL.exec_Iop RTL.exec_Iload RTL.exec_Istore RTL.exec_Icond RTL.exec_Iload_notrap1 RTL.exec_Iload_notrap2: core. + +(* istep reflects RTL.step *) +Lemma istep_correct ge i stack (f:function) sp rs m st : + istep ge i sp rs m = Some st -> + forall pc, (fn_code f)!pc = Some i -> + RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + destruct i; simpl; try congruence; simplify_SOME x. + 1-3: explore_destruct; simplify_SOME x. +Qed. + +Local Hint Resolve star_refl: core. + +(* isteps reflects a star relation on RTL.step *) +Lemma isteps_correct ge path stack f sp: forall rs m pc st, + isteps ge path f sp rs m pc = Some st -> + star RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + induction path; simpl; try_simplify_someHyps. + inversion_SOME i; intros Hi. + inversion_SOME st0; intros Hst0. + destruct (icontinue st0) eqn:cont. + + intros; eapply star_step. + - eapply istep_correct; eauto. + - simpl; eauto. + - auto. + + intros; simplify_someHyp; eapply star_step. + - eapply istep_correct; eauto. + - simpl; eauto. + - auto. +Qed. + +Lemma isteps_correct_early_exit ge path stack f sp: forall rs m pc st, + isteps ge path f sp rs m pc = Some st -> + st.(icontinue) = false -> + plus RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + destruct path; simpl; try_simplify_someHyps; try congruence. + inversion_SOME i; intros Hi. + inversion_SOME st0; intros Hst0. + destruct (icontinue st0) eqn:cont. + + intros; eapply plus_left. + - eapply istep_correct; eauto. + - eapply isteps_correct; eauto. + - auto. + + intros X; inversion X; subst. + eapply plus_one. + eapply istep_correct; eauto. +Qed. + +Local Hint Resolve list_forall2_nil match_globdef_fun linkorder_refl match_globvar_intro: core. + +Section CORRECTNESS. + +Variable p: program. + +Lemma match_prog_RTL: match_program (fun _ f tf => tf = fundef_RTL f) eq p (transf_program p). +Proof. + eapply match_transform_program; eauto. +Qed. + +Let pge := Genv.globalenv p. +Let ge := Genv.globalenv (transf_program p). + +Lemma senv_preserved: Senv.equiv pge ge. +Proof (Genv.senv_match match_prog_RTL). + +Lemma symbols_preserved s: Genv.find_symbol ge s = Genv.find_symbol pge s. +Proof (Genv.find_symbol_match match_prog_RTL s). + +Lemma find_function_RTL_match ros rs fd: + find_function pge ros rs = Some fd -> RTL.find_function ge ros rs = Some (fundef_RTL fd). +Proof. + destruct ros; simpl. + + intro; exploit (Genv.find_funct_match match_prog_RTL); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; auto. + + rewrite symbols_preserved. + destruct (Genv.find_symbol pge i); simpl; try congruence. + intro; exploit (Genv.find_funct_ptr_match match_prog_RTL); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; auto. +Qed. + +Local Hint Resolve istep_correct RTL.exec_Ibuiltin RTL.exec_Ijumptable RTL.exec_Ireturn RTL.exec_Icall RTL.exec_Itailcall find_function_RTL_match: core. + +Lemma path_last_step_correct stack f sp pc rs m t s: + path_last_step ge pge stack f sp pc rs m t s -> + RTL.step ge (State stack f sp pc rs m) t s. +Proof. + destruct 1; try (eapply istep_correct); simpl; eauto. +Qed. + +Lemma path_step_correct path stack f sp pc rs m t s: + path_step ge pge path stack f sp rs m pc t s -> + plus RTL.step ge (State stack f sp pc rs m) t s. +Proof. + destruct 1. + + eapply isteps_correct_early_exit; eauto. + + eapply plus_right. + eapply isteps_correct; eauto. + eapply path_last_step_correct; eauto. + auto. +Qed. + +Local Hint Resolve plus_one RTL.exec_function_internal RTL.exec_function_external RTL.exec_return: core. + +Lemma step_correct s t s': step ge pge s t s' -> plus RTL.step ge s t s'. +Proof. + destruct 1; try (eapply path_step_correct); simpl; eauto. +Qed. + +Theorem RTLpath_correct: forward_simulation (semantics p) (RTL.semantics p). +Proof. + eapply forward_simulation_plus with (match_states := fun s1 s2 => s2 = state_RTL s1); simpl; auto. + - apply senv_preserved. + - destruct 1; intros; eexists; intuition eauto. econstructor; eauto. + + apply (Genv.init_mem_match match_prog_RTL); auto. + + rewrite (Genv.find_symbol_match match_prog_RTL). + rewrite (match_program_main match_prog_RTL); eauto. + + exploit (Genv.find_funct_ptr_match match_prog_RTL); eauto. + intros (cunit & tf0 & XX); intuition subst; eauto. + - unfold final_state; intros; subst; eauto. + - intros; subst. eexists; intuition. + eapply step_correct; eauto. +Qed. + +End CORRECTNESS. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +(* Definition transf_program : RTLpath.program -> RTL.program := transform_program fundef_RTL. + +Lemma transf_program_proj: forall p, transf_program (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. *) + + +(** The hard way: Forward simulation of RTL by RTLpath + +This way can be viewed as a completeness property: all transitions in RTL can be represented as RTLpath transitions ! + +*) + +(* This lemma is probably needed to compose a pass from RTL -> RTLpath with other passes.*) +Lemma match_RTL_prog {LA: Linker fundef} {LV: Linker unit} p: match_program (fun _ f tf => f = fundef_RTL tf) eq (transf_program p) p. +Proof. + unfold match_program, match_program_gen; intuition. + unfold transf_program at 2; simpl. + generalize (prog_defs p). + induction l as [|a l]; simpl; eauto. + destruct a; simpl. + intros; eapply list_forall2_cons; eauto. + unfold match_ident_globdef; simpl; intuition; destruct g as [f|v]; simpl; eauto. + eapply match_globdef_var. destruct v; eauto. +Qed. + +(* Theory of wellformed paths *) + +Fixpoint nth_default_succ (c: code) (path:nat) (pc: node): option node := + match path with + | O => Some pc + | S path' => + SOME i <- c!pc IN + SOME pc' <- default_succ i IN + nth_default_succ c path' pc' + end. + +Lemma wellformed_suffix_path c pm path path': + (path' <= path)%nat -> + forall pc, wellformed_path c pm path pc -> + exists pc', nth_default_succ c (path-path') pc = Some pc' /\ wellformed_path c pm path' pc'. +Proof. + induction 1 as [|m]. + + intros. enough (path'-path'=0)%nat as ->; [simpl;eauto|omega]. + + intros pc WF; enough (S m-path'=S (m-path'))%nat as ->; [simpl;eauto|omega]. + inversion WF; subst; clear WF; intros; simplify_someHyps. + intros; simplify_someHyps; eauto. +Qed. + +Definition nth_default_succ_inst (c: code) (path:nat) pc: option instruction := + SOME pc <- nth_default_succ c path pc IN + c!pc. + +Lemma final_node_path f path pc: + (fn_path f)!pc = Some path -> + exists i, nth_default_succ_inst (fn_code f) path.(psize) pc = Some i + /\ (forall n, List.In n (successors_instr i) -> path_entry (*fn_code f*) (fn_path f) n). +Proof. + intros; exploit fn_path_wf; eauto. + intro WF. + set (ps:=path.(psize)). + exploit (wellformed_suffix_path (fn_code f) (fn_path f) ps O); omega || eauto. + destruct 1 as (pc' & NTH_SUCC & WF'); auto. + assert (ps - 0 = ps)%nat as HH by omega. rewrite HH in NTH_SUCC. clear HH. + unfold nth_default_succ_inst. + inversion WF'; clear WF'; subst. simplify_someHyps; eauto. +Qed. + +Lemma internal_node_path path f path0 pc: + (fn_path f)!pc = (Some path0) -> + (path < path0.(psize))%nat -> + exists i pc', + nth_default_succ_inst (fn_code f) path pc = Some i /\ + default_succ i = Some pc' /\ + (forall n, early_exit i = Some n -> path_entry (*fn_code f*) (fn_path f) n). +Proof. + intros; exploit fn_path_wf; eauto. + set (ps:=path0.(psize)). + intro WF; exploit (wellformed_suffix_path (fn_code f) (fn_path f) ps (ps-path)); eauto. { omega. } + destruct 1 as (pc' & NTH_SUCC & WF'). + assert (ps - (ps - path) = path)%nat as HH by omega. rewrite HH in NTH_SUCC. clear HH. + unfold nth_default_succ_inst. + inversion WF'; clear WF'; subst. { omega. } + simplify_someHyps; eauto. +Qed. + +Lemma initialize_path (*c*) pm n: path_entry (*c*) pm n -> exists path, pm!n = Some path. +Proof. + unfold path_entry; destruct pm!n; eauto. intuition congruence. +Qed. +Local Hint Resolve fn_entry_point_wf: core. +Local Opaque path_entry. + +Lemma istep_successors ge i sp rs m st: + istep ge i sp rs m = Some st -> + In (ipc st) (successors_instr i). +Proof. + destruct i; simpl; try congruence; simplify_SOME x. + all: explore_destruct; simplify_SOME x. +Qed. + +Lemma istep_normal_exit ge i sp rs m st: + istep ge i sp rs m = Some st -> + st.(icontinue) = true -> + default_succ i = Some st.(ipc). +Proof. + destruct i; simpl; try congruence; simplify_SOME x. + all: explore_destruct; simplify_SOME x. +Qed. + +Lemma isteps_normal_exit ge path f sp: forall rs m pc st, + st.(icontinue) = true -> + isteps ge path f sp rs m pc = Some st -> + nth_default_succ (fn_code f) path pc = Some st.(ipc). +Proof. + induction path; simpl. { try_simplify_someHyps. } + intros rs m pc st CONT; try_simplify_someHyps. + inversion_SOME i; intros Hi. + inversion_SOME st0; intros Hst0. + destruct (icontinue st0) eqn:X; try congruence. + try_simplify_someHyps. + intros; erewrite istep_normal_exit; eauto. +Qed. + + +(* TODO: the three following lemmas could maybe simplified by introducing an auxiliary + left-recursive definition equivalent to isteps ? +*) +Lemma isteps_step_right ge path f sp: forall rs m pc st i, + isteps ge path f sp rs m pc = Some st -> + st.(icontinue) = true -> + (fn_code f)!(st.(ipc)) = Some i -> + istep ge i sp st.(irs) st.(imem) = isteps ge (S path) f sp rs m pc. +Proof. + induction path. + + simpl; intros; try_simplify_someHyps. simplify_SOME st. + destruct st as [b]; destruct b; simpl; auto. + + intros rs m pc st i H. + simpl in H. + generalize H; clear H; simplify_SOME xx. + destruct (icontinue xx0) eqn: CONTxx0. + * intros; erewrite IHpath; eauto. + * intros; congruence. +Qed. + +Lemma isteps_inversion_early ge path f sp: forall rs m pc st, + isteps ge path f sp rs m pc = Some st -> + (icontinue st)=false -> + exists st0 i path0, + (path > path0)%nat /\ + isteps ge path0 f sp rs m pc = Some st0 /\ + st0.(icontinue) = true /\ + (fn_code f)!(st0.(ipc)) = Some i /\ + istep ge i sp st0.(irs) st0.(imem) = Some st. +Proof. + induction path as [|path]; simpl. + - intros; try_simplify_someHyps; try congruence. + - intros rs m pc st; inversion_SOME i; inversion_SOME st0. + destruct (icontinue st0) eqn: CONT. + + intros STEP PC STEPS CONT0. exploit IHpath; eauto. + clear STEPS. + intros (st1 & i0 & path0 & BOUND & STEP1 & CONT1 & X1 & X2); auto. + exists st1. exists i0. exists (S path0). intuition. + simpl; try_simplify_someHyps. + rewrite CONT. auto. + + intros; try_simplify_someHyps; try congruence. + eexists. exists i. exists O; simpl. intuition eauto. + omega. +Qed. + +Lemma isteps_resize ge path0 path1 f sp rs m pc st: + (path0 <= path1)%nat -> + isteps ge path0 f sp rs m pc = Some st -> + (icontinue st)=false -> + isteps ge path1 f sp rs m pc = Some st. +Proof. + induction 1 as [|path1]; simpl; auto. + intros PSTEP CONT. exploit IHle; auto. clear PSTEP IHle H path0. + generalize rs m pc st CONT; clear rs m pc st CONT. + induction path1 as [|path]; simpl; auto. + - intros; try_simplify_someHyps; try congruence. + - intros rs m pc st; inversion_SOME i; inversion_SOME st0; intros; try_simplify_someHyps. + destruct (icontinue st0) eqn: CONT0; eauto. +Qed. + +(* FIXME - add prediction *) +Inductive is_early_exit pc: instruction -> Prop := + | Icond_early_exit cond args ifnot predict: + is_early_exit pc (Icond cond args pc ifnot predict) + . (* TODO add jumptable here ? *) + +Lemma istep_early_exit ge i sp rs m st : + istep ge i sp rs m = Some st -> + st.(icontinue) = false -> + st.(irs) = rs /\ st.(imem) = m /\ is_early_exit st.(ipc) i. +Proof. + Local Hint Resolve Icond_early_exit: core. + destruct i; simpl; try congruence; simplify_SOME b; simpl; try congruence. + all: explore_destruct; simplify_SOME b; try discriminate. +Qed. + +Section COMPLETENESS. + +Variable p: program. + +Let pge := Genv.globalenv p. +Let ge := Genv.globalenv (transf_program p). + +Lemma find_funct_ptr_RTL_preserv b f: + Genv.find_funct_ptr ge b = Some f -> (exists f0, Genv.find_funct_ptr pge b = Some f0 /\ f = f0). +Proof. + intros; exploit (Genv.find_funct_ptr_match (match_RTL_prog p)); eauto. + destruct 1 as (cunit & tf & X & Y & Z); subst. + eauto. +Qed. + +Lemma find_RTL_function_match ros rs fd: + RTL.find_function ge ros rs = Some fd -> exists fd', fd = fundef_RTL fd' /\ find_function pge ros rs = Some fd'. +Proof. + destruct ros; simpl. + + intro; exploit (Genv.find_funct_match (match_RTL_prog p)); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; eauto. + + rewrite (symbols_preserved p); unfold pge. + destruct (Genv.find_symbol (Genv.globalenv p) i); simpl; try congruence. + intro; exploit find_funct_ptr_RTL_preserv; eauto. + intros (tf & H1 & H2); subst; eauto. +Qed. + + +(** *** Definition of well-formed stacks and of match_states *) +Definition wf_stf (st: stackframe): Prop := + match st with + | Stackframe res f sp pc rs => path_entry (*f.(fn_code)*) f.(fn_path) pc + end. + +Definition wf_stackframe (stack: list stackframe): Prop := + forall st, List.In st stack -> wf_stf st. + +Lemma wf_stackframe_nil: wf_stackframe nil. +Proof. + unfold wf_stackframe; simpl. tauto. +Qed. +Local Hint Resolve wf_stackframe_nil: core. + +Lemma wf_stackframe_cons st stack: + wf_stackframe (st::stack) <-> (wf_stf st) /\ wf_stackframe stack. +Proof. + unfold wf_stackframe; simpl; intuition (subst; auto). +Qed. + +Definition stack_of (s: state): list stackframe := + match s with + | State stack f sp pc rs m => stack + | Callstate stack f args m => stack + | Returnstate stack v m => stack + end. + +Definition is_inst (s: RTL.state): bool := + match s with + | RTL.State stack f sp pc rs m => true + | _ => false + end. + +Inductive match_inst_states_goal (idx: nat) (s1:RTL.state): state -> Prop := + | State_match path stack f sp pc rs m s2: + (fn_path f)!pc = Some path -> + (idx <= path.(psize))%nat -> + isteps ge (path.(psize)-idx) f sp rs m pc = Some s2 -> + s1 = State stack f sp s2.(ipc) s2.(irs) s2.(imem) -> + match_inst_states_goal idx s1 (State stack f sp pc rs m). + +Definition match_inst_states (idx: nat) (s1:RTL.state) (s2:state): Prop := + if is_inst s1 then match_inst_states_goal idx s1 s2 else s1 = state_RTL s2. + +Definition match_states (idx: nat) (s1:RTL.state) (s2:state): Prop := + match_inst_states idx s1 s2 + /\ wf_stackframe (stack_of s2). + +(** *** Auxiliary lemmas of completeness *) +Lemma istep_complete t i stack f sp rs m pc s': + RTL.step ge (State stack f sp pc rs m) t s' -> + (fn_code f)!pc = Some i -> + default_succ i <> None -> + t = E0 /\ exists st, istep ge i sp rs m = Some st /\ s'=(State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + intros H X; inversion H; simpl; subst; try rewrite X in * |-; clear X; simplify_someHyps; try congruence; + (split; auto); simplify_someHyps; eexists; split; simplify_someHyps; eauto. + all: explore_destruct; simplify_SOME a. +Qed. + +Lemma stuttering path idx stack f sp rs m pc st t s1': + isteps ge (path.(psize)-(S idx)) f sp rs m pc = Some st -> + (fn_path f)!pc = Some path -> + (S idx <= path.(psize))%nat -> + st.(icontinue) = true -> + RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> + t = E0 /\ match_inst_states idx s1' (State stack f sp pc rs m). +Proof. + intros PSTEP PATH BOUND CONT RSTEP; exploit (internal_node_path (path.(psize)-(S idx))); omega || eauto. + intros (i & pc' & Hi & Hpc & DUM). + unfold nth_default_succ_inst in Hi. + erewrite isteps_normal_exit in Hi; eauto. + exploit istep_complete; congruence || eauto. + intros (SILENT & st0 & STEP0 & EQ). + intuition; subst; unfold match_inst_states; simpl. + intros; refine (State_match _ _ path stack f sp pc rs m _ PATH _ _ _); simpl; omega || eauto. + set (ps:=path.(psize)). enough (ps - idx = S (ps - (S idx)))%nat as ->; try omega. + erewrite <- isteps_step_right; eauto. +Qed. + +Lemma normal_exit path stack f sp rs m pc st t s1': + isteps ge path.(psize) f sp rs m pc = Some st -> + (fn_path f)!pc = Some path -> + st.(icontinue) = true -> + RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> + wf_stackframe stack -> + exists s2', + (path_last_step ge pge stack f sp st.(ipc) st.(irs) st.(imem)) t s2' + /\ (exists idx', match_states idx' s1' s2'). +Proof. + Local Hint Resolve istep_successors list_nth_z_in: core. (* Hint for path_entry proofs *) + intros PSTEP PATH CONT RSTEP WF; exploit (final_node_path f path); eauto. + intros (i & Hi & SUCCS). + unfold nth_default_succ_inst in Hi. + erewrite isteps_normal_exit in Hi; eauto. + destruct (default_succ i) eqn:Hn0. + + (* exec_istate *) + exploit istep_complete; congruence || eauto. + intros (SILENT & st0 & STEP0 & EQ); subst. + exploit (exec_istate ge pge); eauto. + eexists; intuition eauto. + unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) (ipc st0)) as (path0 & Hpath0); eauto. + exists (path0.(psize)); intuition eauto. + econstructor; eauto. + * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. + * simpl; eauto. + + generalize Hi; inversion RSTEP; clear RSTEP; subst; (repeat (simplify_someHyp; simpl in * |- * )); try congruence; eauto. + - (* Icall *) + intros; exploit find_RTL_function_match; eauto. + intros (fd' & MATCHfd & Hfd'); subst. + exploit (exec_Icall ge pge); eauto. + eexists; intuition eauto. + eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. + rewrite wf_stackframe_cons; intuition simpl; eauto. + - (* Itailcall *) + intros; exploit find_RTL_function_match; eauto. + intros (fd' & MATCHfd & Hfd'); subst. + exploit (exec_Itailcall ge pge); eauto. + eexists; intuition eauto. + eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. + - (* Ibuiltin *) + intros; exploit exec_Ibuiltin; eauto. + eexists; intuition eauto. + unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) pc') as (path0 & Hpath0); eauto. + exists path0.(psize); intuition eauto. + econstructor; eauto. + * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. + * simpl; eauto. + - (* Ijumptable *) + intros; exploit exec_Ijumptable; eauto. + eexists; intuition eauto. + unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) pc') as (path0 & Hpath0); eauto. + exists path0.(psize); intuition eauto. + econstructor; eauto. + * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. + * simpl; eauto. + - (* Ireturn *) + intros; exploit exec_Ireturn; eauto. + eexists; intuition eauto. + eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. +Qed. + +Lemma path_step_complete stack f sp rs m pc t s1' idx path st: + isteps ge (path.(psize)-idx) f sp rs m pc = Some st -> + (fn_path f)!pc = Some path -> + (idx <= path.(psize))%nat -> + RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> + wf_stackframe stack -> + exists idx' s2', + (path_step ge pge path.(psize) stack f sp rs m pc t s2' + \/ (t = E0 /\ s2'=(State stack f sp pc rs m) /\ (idx' < idx)%nat) + \/ (exists path', path_step ge pge path.(psize) stack f sp rs m pc E0 (State stack f sp st.(ipc) st.(irs) st.(imem)) + /\ (fn_path f)!(ipc st) = Some path' /\ path'.(psize) = O + /\ path_step ge pge path'.(psize) stack f sp st.(irs) st.(imem) st.(ipc) t s2') + ) + /\ match_states idx' s1' s2'. +Proof. + Local Hint Resolve exec_early_exit exec_normal_exit: core. + intros PSTEP PATH BOUND RSTEP WF; destruct (st.(icontinue)) eqn: CONT. + destruct idx as [ | idx]. + + (* path_step on normal_exit *) + assert (path.(psize)-0=path.(psize))%nat as HH by omega. rewrite HH in PSTEP. clear HH. + exploit normal_exit; eauto. + intros (s2' & LSTEP & (idx' & MATCH)). + exists idx'; exists s2'; intuition eauto. + + (* stuttering step *) + exploit stuttering; eauto. + unfold match_states; exists idx; exists (State stack f sp pc rs m); + intuition. + + (* one or two path_step on early_exit *) + exploit (isteps_resize ge (path.(psize) - idx)%nat path.(psize)); eauto; try omega. + clear PSTEP; intros PSTEP. + (* TODO for clarification: move the assert below into a separate lemma *) + assert (HPATH0: exists path0, (fn_path f)!(ipc st) = Some path0). + { clear RSTEP. + exploit isteps_inversion_early; eauto. + intros (st0 & i & path0 & BOUND0 & PSTEP0 & CONT0 & PC0 & STEP0). + exploit istep_early_exit; eauto. + intros (X1 & X2 & EARLY_EXIT). + destruct st as [cont pc0 rs0 m0]; simpl in * |- *; intuition subst. + exploit (internal_node_path path0); omega || eauto. + intros (i' & pc' & Hi' & Hpc' & ENTRY). + unfold nth_default_succ_inst in Hi'. + erewrite isteps_normal_exit in Hi'; eauto. + clear pc' Hpc' STEP0 PSTEP0 BOUND0; try_simplify_someHyps; intros. + destruct EARLY_EXIT as [cond args ifnot]; simpl in ENTRY; + destruct (initialize_path (*fn_code f*) (fn_path f) pc0); eauto. + } + destruct HPATH0 as (path1 & Hpath1). + destruct (path1.(psize)) as [|ps] eqn:Hpath1size. + * (* two step case *) + exploit (normal_exit path1); try rewrite Hpath1size; simpl; eauto. + simpl; intros (s2' & LSTEP & (idx' & MATCH)). + exists idx'. exists s2'. constructor; auto. + right. right. eexists; intuition eauto. + (* now, prove the last step *) + rewrite Hpath1size; exploit exec_normal_exit. 4:{ eauto. } + - simpl; eauto. + - simpl; eauto. + - simpl; eauto. + * (* single step case *) + exploit (stuttering path1 ps stack f sp (irs st) (imem st) (ipc st)); simpl; auto. + - { rewrite Hpath1size; enough (S ps-S ps=0)%nat as ->; try omega. simpl; eauto. } + - omega. + - simpl; eauto. + - simpl; eauto. + - intuition subst. + repeat eexists; intuition eauto. +Qed. + +Lemma step_noninst_complete s1 t s1' s2: + is_inst s1 = false -> + s1 = state_RTL s2 -> + RTL.step ge s1 t s1' -> + wf_stackframe (stack_of s2) -> + exists s2', step ge pge s2 t s2' /\ exists idx, match_states idx s1' s2'. +Proof. + intros H0 H1 H2 WFSTACK; destruct s2; subst; simpl in * |- *; try congruence; + inversion H2; clear H2; subst; try_simplify_someHyps; try congruence. + + (* exec_function_internal *) + destruct f; simpl in H3; inversion H3; subst; clear H3. + eexists; constructor 1. + * eapply exec_function_internal; eauto. + * unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) (fn_entrypoint (fn_RTL f))) as (path & Hpath); eauto. + exists path.(psize). constructor; auto. + econstructor; eauto. + - set (ps:=path.(psize)). enough (ps-ps=O)%nat as ->; simpl; eauto. + omega. + - simpl; auto. + + (* exec_function_external *) + destruct f; simpl in H3 |-; inversion H3; subst; clear H3. + eexists; constructor 1. + * apply exec_function_external; eauto. + * unfold match_states, match_inst_states; simpl. exists O; auto. + + (* exec_return *) + destruct stack eqn: Hstack; simpl in H1; inversion H1; clear H1; subst. + destruct s0 eqn: Hs0; simpl in H0; inversion H0; clear H0; subst. + eexists; constructor 1. + * apply exec_return. + * unfold match_states, match_inst_states; simpl. + rewrite wf_stackframe_cons in WFSTACK. + destruct WFSTACK as (H0 & H1); simpl in H0. + destruct (initialize_path (*fn_code f0*) (fn_path f0) pc0) as (path & Hpath); eauto. + exists path.(psize). constructor; auto. + econstructor; eauto. + - set (ps:=path.(psize)). enough (ps-ps=O)%nat as ->; simpl; eauto. + omega. + - simpl; auto. +Qed. + +(** *** The main completeness lemma and the simulation theorem...*) +Lemma step_complete s1 t s1' idx s2: + match_states idx s1 s2 -> + RTL.step ge s1 t s1' -> + exists idx' s2', (plus (step ge) pge s2 t s2' \/ (t = E0 /\ s2=s2' /\ (idx' < idx)%nat)) /\ match_states idx' s1' s2'. +Proof. + Local Hint Resolve plus_one plus_two exec_path: core. + unfold match_states at 1, match_inst_states. intros (IS_INST & WFSTACK). destruct (is_inst s1) eqn: His1. + - clear His1; destruct IS_INST as [path stack f sp pc rs m s2 X X0 X1 X2]; auto; subst; simpl in * |- *. + intros STEP; exploit path_step_complete; eauto. + intros (idx' & s2' & H0 & H1). + eexists; eexists; eauto. + destruct H0 as [H0|[H0|(path'&H0)]]; intuition subst; eauto. + - intros; exploit step_noninst_complete; eauto. + intros (s2' & STEP & (idx0 & MATCH)). + exists idx0; exists s2'; intuition auto. +Qed. + +Theorem RTLpath_complete: forward_simulation (RTL.semantics p) (semantics p). +Proof. + eapply (Forward_simulation (L1:=RTL.semantics p) (L2:=semantics p) lt match_states). + constructor 1; simpl. + - apply lt_wf. + - unfold match_states, match_inst_states. destruct 1; simpl; exists O. + destruct (find_funct_ptr_RTL_preserv b f) as (f0 & X1 & X2); subst; eauto. + exists (Callstate nil f0 nil m0). simpl; split; try econstructor; eauto. + + apply (Genv.init_mem_match (match_RTL_prog p)); auto. + + rewrite (Genv.find_symbol_match (match_RTL_prog p)). + rewrite (match_program_main (match_RTL_prog p)); eauto. + - unfold final_state, match_states, match_inst_states. intros i s1 s2 r (H0 & H1) H2; destruct H2. + destruct s2; simpl in * |- *; inversion H0; subst. + constructor. + - Local Hint Resolve star_refl: core. + intros; exploit step_complete; eauto. + destruct 1 as (idx' & s2' & X). + exists idx'. exists s2'. intuition (subst; eauto). + - intros id; destruct (senv_preserved p); simpl in * |-. intuition. +Qed. + +End COMPLETENESS. diff --git a/scheduling/RTLpathLivegen.v b/scheduling/RTLpathLivegen.v new file mode 100644 index 00000000..1f0ebe3c --- /dev/null +++ b/scheduling/RTLpathLivegen.v @@ -0,0 +1,290 @@ +(** Building a RTLpath program with liveness annotation. +*) + + +Require Import Coqlib. +Require Import Maps. +Require Import Lattice. +Require Import AST. +Require Import Op. +Require Import Registers. +Require Import Globalenvs Smallstep RTL RTLpath. +Require Import Bool Errors. +Require Import Program. + +Local Open Scope lazy_bool_scope. + +Local Open Scope option_monad_scope. + +Axiom build_path_map: RTL.function -> path_map. + +Extract Constant build_path_map => "RTLpathLivegenaux.build_path_map". + +Fixpoint list_mem (rl: list reg) (alive: Regset.t) {struct rl}: bool := + match rl with + | nil => true + | r1 :: rs => Regset.mem r1 alive &&& list_mem rs alive + end. + +Definition exit_checker {A} (pm: path_map) (alive: Regset.t) (pc: node) (v:A): option A := + SOME path <- pm!pc IN + ASSERT Regset.subset path.(input_regs) alive IN + Some v. + +Lemma exit_checker_path_entry A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res: + exit_checker pm alive pc v = Some res -> path_entry pm pc. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; simpl; congruence. +Qed. + +Lemma exit_checker_res A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res: + exit_checker pm alive pc v = Some res -> v=res. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; try_simplify_someHyps. + inversion_ASSERT; try_simplify_someHyps. +Qed. + +(* FIXME - what about trap? *) +Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option (Regset.t * node) := + match i with + | Inop pc' => Some (alive, pc') + | Iop op args dst pc' => + ASSERT list_mem args alive IN + Some (Regset.add dst alive, pc') + | Iload _ chunk addr args dst pc' => + ASSERT list_mem args alive IN + Some (Regset.add dst alive, pc') + | Istore chunk addr args src pc' => + ASSERT Regset.mem src alive IN + ASSERT list_mem args alive IN + Some (alive, pc') + | Icond cond args ifso ifnot _ => + ASSERT list_mem args alive IN + exit_checker pm alive ifso (alive, ifnot) + | _ => None (* TODO jumptable ? *) + end. + + +Local Hint Resolve exit_checker_path_entry: core. + +Lemma iinst_checker_path_entry (pm: path_map) (alive: Regset.t) (i: instruction) res pc: + iinst_checker pm alive i = Some res -> + early_exit i = Some pc -> path_entry pm pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst. + inversion_ASSERT; try_simplify_someHyps. +Qed. + +Lemma iinst_checker_default_succ (pm: path_map) (alive: Regset.t) (i: instruction) res pc: + iinst_checker pm alive i = Some res -> + pc = snd res -> + default_succ i = Some pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst; + repeat (inversion_ASSERT); try_simplify_someHyps. + intros; exploit exit_checker_res; eauto. + intros; subst. simpl; auto. +Qed. + +Fixpoint ipath_checker (ps:nat) (f: RTL.function) (pm: path_map) (alive: Regset.t) (pc:node): option (Regset.t * node) := + match ps with + | O => Some (alive, pc) + | S p => + SOME i <- f.(fn_code)!pc IN + SOME res <- iinst_checker pm alive i IN + ipath_checker p f pm (fst res) (snd res) + end. + +Lemma ipath_checker_wellformed f pm ps: forall alive pc res, + ipath_checker ps f pm alive pc = Some res -> + wellformed_path f.(fn_code) pm 0 (snd res) -> + wellformed_path f.(fn_code) pm ps pc. +Proof. + induction ps; simpl; try_simplify_someHyps. + inversion_SOME i; inversion_SOME res'. + intros. eapply wf_internal_node; eauto. + * eapply iinst_checker_default_succ; eauto. + * intros; eapply iinst_checker_path_entry; eauto. +Qed. + +Definition reg_option_mem (or: option reg) (alive: Regset.t) := + match or with None => true | Some r => Regset.mem r alive end. + +Definition reg_sum_mem (ros: reg + ident) (alive: Regset.t) := + match ros with inl r => Regset.mem r alive | inr s => true end. + +(* NB: definition following [regmap_setres] in [RTL.step] semantics *) +Definition reg_builtin_res (res: builtin_res reg) (alive: Regset.t): Regset.t := + match res with + | BR r => Regset.add r alive + | _ => alive + end. + +Fixpoint exit_list_checker (pm: path_map) (alive: Regset.t) (l: list node): bool := + match l with + | nil => true + | pc::l' => exit_checker pm alive pc tt &&& exit_list_checker pm alive l' + end. + +Lemma lazy_and_Some_true A (o: option A) (b: bool): o &&& b = true <-> (exists v, o = Some v) /\ b = true. +Proof. + destruct o; simpl; intuition. + - eauto. + - firstorder. try_simplify_someHyps. +Qed. + +Lemma lazy_and_Some_tt_true (o: option unit) (b: bool): o &&& b = true <-> o = Some tt /\ b = true. +Proof. + intros; rewrite lazy_and_Some_true; firstorder. + destruct x; auto. +Qed. + + +Lemma exit_list_checker_correct pm alive l pc: + exit_list_checker pm alive l = true -> List.In pc l -> exit_checker pm alive pc tt = Some tt. +Proof. + intros EXIT PC; induction l; intuition. + simpl in * |-. rewrite lazy_and_Some_tt_true in EXIT. + firstorder (subst; eauto). +Qed. + +Local Hint Resolve exit_list_checker_correct: core. + +Definition inst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option unit := + match i with + | Icall sig ros args res pc' => + ASSERT list_mem args alive IN + ASSERT reg_sum_mem ros alive IN + exit_checker pm (Regset.add res alive) pc' tt + | Itailcall sig ros args => + ASSERT list_mem args alive IN + ASSERT reg_sum_mem ros alive IN + Some tt + | Ibuiltin ef args res pc' => + ASSERT list_mem (params_of_builtin_args args) alive IN + exit_checker pm (reg_builtin_res res alive) pc' tt + | Ijumptable arg tbl => + ASSERT Regset.mem arg alive IN + ASSERT exit_list_checker pm alive tbl IN + Some tt + | Ireturn optarg => + ASSERT (reg_option_mem optarg) alive IN + Some tt + | _ => + SOME res <- iinst_checker pm alive i IN + exit_checker pm (fst res) (snd res) tt + end. + +Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive: Regset.t) (i: instruction): + inst_checker pm alive i = Some tt -> + c!pc = Some i -> wellformed_path c pm 0 pc. +Proof. + intros CHECK PC. eapply wf_last_node; eauto. + clear c pc PC. intros pc PC. + destruct i; simpl in * |- *; intuition (subst; eauto); + try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). + intros X; exploit exit_checker_res; eauto. + clear X. intros; subst; eauto. +Qed. + +Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := + SOME res <- ipath_checker (path.(psize)) f pm (path.(input_regs)) pc IN + SOME i <- f.(fn_code)!(snd res) IN + inst_checker pm (fst res) i. + +Lemma path_checker_wellformed f pm pc path: + path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. +Proof. + unfold path_checker. + inversion_SOME res. + inversion_SOME i. + intros; eapply ipath_checker_wellformed; eauto. + eapply inst_checker_wellformed; eauto. +Qed. + +Fixpoint list_path_checker f pm (l:list (node*path_info)): bool := + match l with + | nil => true + | (pc, path)::l' => + path_checker f pm pc path &&& list_path_checker f pm l' + end. + +Lemma list_path_checker_correct f pm l: + list_path_checker f pm l = true -> forall e, List.In e l -> path_checker f pm (fst e) (snd e) = Some tt. +Proof. + intros CHECKER e H; induction l as [|(pc & path) l]; intuition. + simpl in * |- *. rewrite lazy_and_Some_tt_true in CHECKER. intuition (subst; auto). +Qed. + +Definition function_checker (f: RTL.function) pm: bool := + pm!(f.(fn_entrypoint)) &&& list_path_checker f pm (PTree.elements pm). + +Lemma function_checker_correct f pm pc path: + function_checker f pm = true -> + pm!pc = Some path -> + path_checker f pm pc path = Some tt. +Proof. + unfold function_checker; rewrite lazy_and_Some_true. + intros (ENTRY & PATH) PC. + exploit list_path_checker_correct; eauto. + - eapply PTree.elements_correct; eauto. + - simpl; auto. +Qed. + +Lemma function_checker_wellformed_path_map f pm: + function_checker f pm = true -> wellformed_path_map f.(fn_code) pm. +Proof. + unfold wellformed_path_map. + intros; eapply path_checker_wellformed; eauto. + intros; eapply function_checker_correct; eauto. +Qed. + +Lemma function_checker_path_entry f pm: + function_checker f pm = true -> path_entry pm (f.(fn_entrypoint)). +Proof. + unfold function_checker; rewrite lazy_and_Some_true; + unfold path_entry. firstorder congruence. +Qed. + +Definition liveness_ok_function (f: function): Prop := + forall pc path, f.(fn_path)!pc = Some path -> path_checker f f.(fn_path) pc path = Some tt. + +Program Definition transf_function (f: RTL.function): { r: res function | forall f', r = OK f' -> liveness_ok_function f' /\ f'.(fn_RTL) = f } := + let pm := build_path_map f in + match function_checker f pm with + | true => OK {| fn_RTL := f; fn_path := pm |} + | false => Error(msg "RTLpathGen: function_checker failed") + end. +Obligation 1. + apply function_checker_path_entry; auto. +Qed. +Obligation 2. + apply function_checker_wellformed_path_map; auto. +Qed. +Obligation 3. + unfold liveness_ok_function; simpl; intros; intuition. + apply function_checker_correct; auto. +Qed. + +Definition transf_fundef (f: RTL.fundef) : res fundef := + transf_partial_fundef (fun f => ` (transf_function f)) f. + +Inductive liveness_ok_fundef: fundef -> Prop := + | liveness_ok_Internal f: liveness_ok_function f -> liveness_ok_fundef (Internal f) + | liveness_ok_External ef: liveness_ok_fundef (External ef). + +Lemma transf_fundef_correct f f': + transf_fundef f = OK f' -> (liveness_ok_fundef f') /\ fundef_RTL f' = f. +Proof. + intros TRANSF; destruct f; simpl; monadInv TRANSF. + - destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. apply liveness_ok_Internal; auto. + - intuition. apply liveness_ok_External; auto. +Qed. + +Definition transf_program (p: RTL.program) : res program := + transform_partial_program transf_fundef p. + diff --git a/scheduling/RTLpathLivegenaux.ml b/scheduling/RTLpathLivegenaux.ml new file mode 100644 index 00000000..dd971db8 --- /dev/null +++ b/scheduling/RTLpathLivegenaux.ml @@ -0,0 +1,309 @@ +open RTL +open RTLpath +open Registers +open Maps +open Camlcoq +open Datatypes +open Kildall +open Lattice + +let debug_flag = ref false + +let dprintf fmt = let open Printf in + match !debug_flag with + | true -> printf fmt + | false -> ifprintf stdout fmt + +let get_some = function +| None -> failwith "Got None instead of Some _" +| Some thing -> thing + +let successors_inst = function +| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> [n] +| Icond (_,_,n1,n2,_) -> [n1; n2] +| Ijumptable (_,l) -> l +| Itailcall _ | Ireturn _ -> [] + +let predicted_successor = function +| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> Some n +| Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> None +| Icond (_,_,n1,n2,p) -> ( + match p with + | Some true -> Some n1 + | Some false -> Some n2 + | None -> None ) +| Ijumptable _ | Itailcall _ | Ireturn _ -> None + +let non_predicted_successors i = + match predicted_successor i with + | None -> successors_inst i + | Some n -> List.filter (fun n' -> n != n') (successors_inst i) + +let rec list_to_regset = function + | [] -> Regset.empty + | r::l -> Regset.add r (list_to_regset l) + +let get_input_regs i = + let empty = Regset.empty in + match i with + | Inop _ -> empty + | Iop (_,lr,_,_) | Iload (_,_,_,lr,_,_) | Icond (_,lr,_,_,_) -> list_to_regset lr + | Istore (_,_,lr,r,_) -> Regset.add r (list_to_regset lr) + | Icall (_, ri, lr, _, _) | Itailcall (_, ri, lr) -> begin + let rs = list_to_regset lr in + match ri with + | Coq_inr _ -> rs + | Coq_inl r -> Regset.add r rs + end + | Ibuiltin (_, lbr, _, _) -> list_to_regset @@ AST.params_of_builtin_args lbr + | Ijumptable (r, _) -> Regset.add r empty + | Ireturn opr -> (match opr with Some r -> Regset.add r empty | None -> empty) + +let get_output_reg i = + match i with + | Inop _ | Istore _ | Icond _ | Itailcall _ | Ijumptable _ | Ireturn _ -> None + | Iop (_, _, r, _) | Iload (_, _, _, _, r, _) | Icall (_, _, _, r, _) -> Some r + | Ibuiltin (_, _, brr, _) -> (match brr with AST.BR r -> Some r | _ -> None) + +(* adapted from Linearizeaux.get_join_points *) +let get_join_points code entry = + let reached = ref (PTree.map (fun n i -> false) code) in + let reached_twice = ref (PTree.map (fun n i -> false) code) in + let rec traverse pc = + if get_some @@ PTree.get pc !reached then begin + if not (get_some @@ PTree.get pc !reached_twice) then + reached_twice := PTree.set pc true !reached_twice + end else begin + reached := PTree.set pc true !reached; + traverse_succs (successors_inst @@ get_some @@ PTree.get pc code) + end + and traverse_succs = function + | [] -> () + | [pc] -> traverse pc + | pc :: l -> traverse pc; traverse_succs l + in traverse entry; !reached_twice + +(* Does not set the input_regs and liveouts field *) +let get_path_map code entry join_points = + let visited = ref (PTree.map (fun n i -> false) code) in + let path_map = ref PTree.empty in + let rec dig_path e = + let psize = ref (-1) in + let path_successors = ref [] in + let rec dig_path_rec n : (path_info * node list) option = + if not (get_some @@ PTree.get n !visited) then + let inst = get_some @@ PTree.get n code in + begin + visited := PTree.set n true !visited; + psize := !psize + 1; + let successor = match predicted_successor inst with + | None -> None + | Some n' -> if get_some @@ PTree.get n' join_points then None else Some n' + in match successor with + | Some n' -> begin + path_successors := !path_successors @ non_predicted_successors inst; + dig_path_rec n' + end + | None -> Some ({ psize = (Camlcoq.Nat.of_int !psize); + input_regs = Regset.empty; output_regs = Regset.empty }, + !path_successors @ successors_inst inst) + end + else None + in match dig_path_rec e with + | None -> () + | Some ret -> + let (path_info, succs) = ret in + begin + path_map := PTree.set e path_info !path_map; + List.iter dig_path succs + end + in begin + dig_path entry; + !path_map + end + +let print_regset rs = begin + dprintf "["; + List.iter (fun n -> dprintf "%d " (P.to_int n)) (Regset.elements rs); + dprintf "]" +end + +let print_ptree_regset pt = begin + dprintf "["; + List.iter (fun (n, rs) -> + dprintf "\n\t"; + dprintf "%d: " (P.to_int n); + print_regset rs + ) (PTree.elements pt); + dprintf "]" +end + +let transfer f pc after = let open Liveness in + match PTree.get pc f.fn_code with + | Some i -> + (match i with + | Inop _ -> after + | Iop (_, args, res, _) -> + reg_list_live args (Regset.remove res after) + | Iload (_, _, _, args, dst, _) -> + reg_list_live args (Regset.remove dst after) + | Istore (_, _, args, src, _) -> + reg_list_live args (Regset.add src after) + | Icall (_, ros, args, res, _) -> + reg_list_live args (reg_sum_live ros (Regset.remove res after)) + | Itailcall (_, ros, args) -> + reg_list_live args (reg_sum_live ros Regset.empty) + | Ibuiltin (_, args, res, _) -> + reg_list_live (AST.params_of_builtin_args args) + (reg_list_dead (AST.params_of_builtin_res res) after) + | Icond (_, args, _, _, _) -> + reg_list_live args after + | Ijumptable (arg, _) -> + Regset.add arg after + | Ireturn optarg -> + reg_option_live optarg Regset.empty) + | None -> Regset.empty + +module RegsetLat = LFSet(Regset) + +module DS = Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward) + +let analyze f = + let liveouts = get_some @@ DS.fixpoint f.fn_code successors_instr (transfer f) in + PTree.map (fun n _ -> let lo = PMap.get n liveouts in transfer f n lo) f.fn_code + +(** OLD CODE - If needed to have our own kildall + +let transfer after = let open Liveness in function + | Inop _ -> after + | Iop (_, args, res, _) -> + reg_list_live args (Regset.remove res after) + | Iload (_, _, _, args, dst, _) -> + reg_list_live args (Regset.remove dst after) + | Istore (_, _, args, src, _) -> + reg_list_live args (Regset.add src after) + | Icall (_, ros, args, res, _) -> + reg_list_live args (reg_sum_live ros (Regset.remove res after)) + | Itailcall (_, ros, args) -> + reg_list_live args (reg_sum_live ros Regset.empty) + | Ibuiltin (_, args, res, _) -> + reg_list_live (AST.params_of_builtin_args args) + (reg_list_dead (AST.params_of_builtin_res res) after) + | Icond (_, args, _, _, _) -> + reg_list_live args after + | Ijumptable (arg, _) -> + Regset.add arg after + | Ireturn optarg -> + reg_option_live optarg Regset.empty + +let get_last_nodes f = + let visited = ref (PTree.map (fun n i -> false) f.fn_code) in + let rec step n = + let inst = get_some @@ PTree.get n f.fn_code in + let successors = successors_inst inst in + if get_some @@ PTree.get n !visited then [] + else begin + +let analyze f = + let liveness = ref (PTree.map (fun n i -> None) f.fn_code) in + let predecessors = Duplicateaux.get_predecessors_rtl f.fn_code in + let last_nodes = get_last_nodes f in + let rec step liveout n = (* liveout is the input_regs from the successor *) + let inst = get_some @@ PTree.get n f.fn_code in + let continue = ref true in + let alive = match get_some @@ PTree.get n !liveness with + | None -> transfer liveout inst + | Some pre_alive -> begin + let union = Regset.union pre_alive liveout in + let new_alive = transfer union inst in + (if Regset.equal pre_alive new_alive then continue := false); + new_alive + end + in begin + liveness := PTree.set n (Some alive) !liveness; + if !continue then + let preds = get_some @@ PTree.get n predecessors in + List.iter (step alive) preds + end + in begin + List.iter (step Regset.empty) last_nodes; + let liveness_noopt = PTree.map (fun n i -> get_some i) !liveness in + begin + debug_flag := true; + dprintf "Liveness: "; print_ptree_regset liveness_noopt; dprintf "\n"; + debug_flag := false; + liveness_noopt + end + end +*) + +let rec traverse code n size = + let inst = get_some @@ PTree.get n code in + if (size == 0) then inst + else + let n' = get_some @@ predicted_successor inst in + traverse code n' (size-1) + +let get_outputs liveness code n pi = + let last_instruction = traverse code n (Camlcoq.Nat.to_int pi.psize) in + let path_last_successors = successors_inst last_instruction in + let list_input_regs = List.map ( + fun n -> get_some @@ PTree.get n liveness + ) path_last_successors in + List.fold_left Regset.union Regset.empty list_input_regs + +let set_pathmap_liveness f pm = + let liveness = analyze f in + let new_pm = ref PTree.empty in + let code = f.fn_code in + begin + dprintf "Liveness: "; print_ptree_regset liveness; dprintf "\n"; + List.iter (fun (n, pi) -> + let inputs = get_some @@ PTree.get n liveness in + let outputs = get_outputs liveness code n pi in + new_pm := PTree.set n + {psize=pi.psize; input_regs=inputs; output_regs=outputs} !new_pm + ) (PTree.elements pm); + !new_pm + end + +let print_true_nodes booltree = begin + dprintf "["; + List.iter (fun (n,b) -> + if b then dprintf "%d " (P.to_int n) + ) (PTree.elements booltree); + dprintf "]"; +end + +let print_path_info pi = begin + dprintf "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); + dprintf "input_regs="; + print_regset pi.input_regs; + dprintf "; output_regs="; + print_regset pi.output_regs; + dprintf ")" +end + +let print_path_map path_map = begin + dprintf "["; + List.iter (fun (n,pi) -> + dprintf "\n\t"; + dprintf "%d: " (P.to_int n); + print_path_info pi + ) (PTree.elements path_map); + dprintf "]" +end + +let build_path_map f = + let code = f.fn_code in + let entry = f.fn_entrypoint in + let join_points = get_join_points code entry in + let path_map = set_pathmap_liveness f @@ get_path_map code entry join_points in + begin + dprintf "Join points: "; + print_true_nodes join_points; + dprintf "\nPath map: "; + print_path_map path_map; + dprintf "\n"; + path_map + end diff --git a/scheduling/RTLpathLivegenproof.v b/scheduling/RTLpathLivegenproof.v new file mode 100644 index 00000000..0ba5ed44 --- /dev/null +++ b/scheduling/RTLpathLivegenproof.v @@ -0,0 +1,736 @@ +(** Proofs of the liveness properties from the liveness checker of RTLpathLivengen. +*) + + +Require Import Coqlib. +Require Import Maps. +Require Import Lattice. +Require Import AST. +Require Import Op. +Require Import Registers. +Require Import Globalenvs Smallstep RTL RTLpath RTLpathLivegen. +Require Import Bool Errors Linking Values Events. +Require Import Program. + +Definition match_prog (p: RTL.program) (tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. + +Section PRESERVATION. + +Variables prog: RTL.program. +Variables tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tpge := Genv.globalenv tprog. +Let tge := Genv.globalenv (RTLpath.transf_program tprog). + +Lemma symbols_preserved s: Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + rewrite <- (Genv.find_symbol_match TRANSL). + apply (Genv.find_symbol_match (match_prog_RTL tprog)). +Qed. + +Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. + +Lemma senv_preserved: Senv.equiv ge tge. +Proof. + eapply senv_transitivity. { eapply (Genv.senv_match TRANSL). } + eapply RTLpath.senv_preserved. +Qed. + +Lemma function_ptr_preserved v f: Genv.find_funct_ptr ge v = Some f -> + exists tf, Genv.find_funct_ptr tpge v = Some tf /\ transf_fundef f = OK tf. +Proof. + intros; apply (Genv.find_funct_ptr_transf_partial TRANSL); eauto. +Qed. + + +Lemma function_ptr_RTL_preserved v f: Genv.find_funct_ptr ge v = Some f -> Genv.find_funct_ptr tge v = Some f. +Proof. + intros; exploit function_ptr_preserved; eauto. + intros (tf & Htf & TRANS). + exploit (Genv.find_funct_ptr_match (match_prog_RTL tprog)); eauto. + intros (cunit & tf0 & X & Y & DUM); subst. + unfold tge. rewrite X. + exploit transf_fundef_correct; eauto. + intuition subst; auto. +Qed. + +Lemma find_function_preserved ros rs fd: + RTL.find_function ge ros rs = Some fd -> RTL.find_function tge ros rs = Some fd. +Proof. + intros H; assert (X: exists tfd, find_function tpge ros rs = Some tfd /\ fd = fundef_RTL tfd). + * destruct ros; simpl in * |- *. + + intros; exploit (Genv.find_funct_match TRANSL); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; repeat econstructor; eauto. + exploit transf_fundef_correct; eauto. + intuition auto. + + rewrite <- (Genv.find_symbol_match TRANSL) in H. + unfold tpge. destruct (Genv.find_symbol _ i); simpl; try congruence. + exploit function_ptr_preserved; eauto. + intros (tf & H1 & H2); subst; repeat econstructor; eauto. + exploit transf_fundef_correct; eauto. + intuition auto. + * destruct X as (tf & X1 & X2); subst. + eapply find_function_RTL_match; eauto. +Qed. + + +Local Hint Resolve symbols_preserved senv_preserved: core. + +Lemma transf_program_RTL_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics (RTLpath.transf_program tprog)). +Proof. + eapply forward_simulation_step with (match_states:=fun (s1 s2:RTL.state) => s1=s2); simpl; eauto. + - eapply senv_preserved. + - (* initial states *) + intros s1 INIT. destruct INIT as [b f m0 ge0 INIT SYMB PTR SIG]. eexists; intuition eauto. + econstructor; eauto. + + intros; eapply (Genv.init_mem_match (match_prog_RTL tprog)). apply (Genv.init_mem_match TRANSL); auto. + + rewrite symbols_preserved. + replace (prog_main (RTLpath.transf_program tprog)) with (prog_main prog). + * eapply SYMB. + * erewrite (match_program_main (match_prog_RTL tprog)). erewrite (match_program_main TRANSL); auto. + + exploit function_ptr_RTL_preserved; eauto. + - intros; subst; auto. + - intros s t s2 STEP s1 H; subst. + eexists; intuition. + destruct STEP. + + (* Inop *) eapply exec_Inop; eauto. + + (* Iop *) eapply exec_Iop; eauto. + erewrite eval_operation_preserved; eauto. + + (* Iload *) eapply exec_Iload; eauto. + erewrite eval_addressing_preserved; eauto. + + (* Iload notrap1 *) eapply exec_Iload_notrap1; eauto. + erewrite eval_addressing_preserved; eauto. + + (* Iload notrap2 *) eapply exec_Iload_notrap2; eauto. + erewrite eval_addressing_preserved; eauto. + + (* Istore *) eapply exec_Istore; eauto. + erewrite eval_addressing_preserved; eauto. + + (* Icall *) + eapply RTL.exec_Icall; eauto. + eapply find_function_preserved; eauto. + + (* Itailcall *) + eapply RTL.exec_Itailcall; eauto. + eapply find_function_preserved; eauto. + + (* Ibuiltin *) + eapply RTL.exec_Ibuiltin; eauto. + * eapply eval_builtin_args_preserved; eauto. + * eapply external_call_symbols_preserved; eauto. + + (* Icond *) + eapply exec_Icond; eauto. + + (* Ijumptable *) + eapply RTL.exec_Ijumptable; eauto. + + (* Ireturn *) + eapply RTL.exec_Ireturn; eauto. + + (* exec_function_internal *) + eapply RTL.exec_function_internal; eauto. + + (* exec_function_external *) + eapply RTL.exec_function_external; eauto. + eapply external_call_symbols_preserved; eauto. + + (* exec_return *) + eapply RTL.exec_return; eauto. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTLpath.semantics tprog). +Proof. + eapply compose_forward_simulations. + + eapply transf_program_RTL_correct. + + eapply RTLpath_complete. +Qed. + + +(* Properties used in hypothesis of [RTLpathLiveproofs.step_eqlive] theorem *) +Theorem all_fundef_liveness_ok b f: + Genv.find_funct_ptr tpge b = Some f -> liveness_ok_fundef f. +Proof. + unfold match_prog, match_program in TRANSL. + unfold Genv.find_funct_ptr, tpge; simpl; intro X. + destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. + destruct y as [tf0|]; try congruence. + inversion X as [H1]. subst. clear X. + remember (@Gfun fundef unit f) as f2. + destruct H as [ctx' f1 f2 H0|]; try congruence. + inversion Heqf2 as [H2]. subst; clear Heqf2. + exploit transf_fundef_correct; eauto. + intuition. +Qed. + +End PRESERVATION. + +Local Open Scope lazy_bool_scope. +Local Open Scope option_monad_scope. + +Local Notation ext alive := (fun r => Regset.In r alive). + +Lemma regset_add_spec live r1 r2: Regset.In r1 (Regset.add r2 live) <-> (r1 = r2 \/ Regset.In r1 live). +Proof. + destruct (Pos.eq_dec r1 r2). + - subst. intuition; eapply Regset.add_1; auto. + - intuition. + * right. eapply Regset.add_3; eauto. + * eapply Regset.add_2; auto. +Qed. + +Definition eqlive_reg (alive: Regset.elt -> Prop) (rs1 rs2: regset): Prop := + forall r, (alive r) -> rs1#r = rs2#r. + +Lemma eqlive_reg_refl alive rs: eqlive_reg alive rs rs. +Proof. + unfold eqlive_reg; auto. +Qed. + +Lemma eqlive_reg_symmetry alive rs1 rs2: eqlive_reg alive rs1 rs2 -> eqlive_reg alive rs2 rs1. +Proof. + unfold eqlive_reg; intros; symmetry; auto. +Qed. + +Lemma eqlive_reg_trans alive rs1 rs2 rs3: eqlive_reg alive rs1 rs2 -> eqlive_reg alive rs2 rs3 -> eqlive_reg alive rs1 rs3. +Proof. + unfold eqlive_reg; intros H0 H1 r H. rewrite H0; eauto. +Qed. + +Lemma eqlive_reg_update (alive: Regset.elt -> Prop) rs1 rs2 r v: eqlive_reg (fun r1 => r1 <> r /\ alive r1) rs1 rs2 -> eqlive_reg alive (rs1 # r <- v) (rs2 # r <- v). +Proof. + unfold eqlive_reg; intros EQLIVE r0 ALIVE. + destruct (Pos.eq_dec r r0) as [H|H]. + - subst. rewrite! Regmap.gss. auto. + - rewrite! Regmap.gso; auto. +Qed. + +Lemma eqlive_reg_monotonic (alive1 alive2: Regset.elt -> Prop) rs1 rs2: eqlive_reg alive2 rs1 rs2 -> (forall r, alive1 r -> alive2 r) -> eqlive_reg alive1 rs1 rs2. +Proof. + unfold eqlive_reg; intuition. +Qed. + +Lemma eqlive_reg_triv rs1 rs2: (forall r, rs1#r = rs2#r) <-> eqlive_reg (fun _ => True) rs1 rs2. +Proof. + unfold eqlive_reg; intuition. +Qed. + +Lemma eqlive_reg_triv_trans alive rs1 rs2 rs3: eqlive_reg alive rs1 rs2 -> (forall r, rs2#r = rs3#r) -> eqlive_reg alive rs1 rs3. +Proof. + rewrite eqlive_reg_triv; intros; eapply eqlive_reg_trans; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; eauto. +Qed. + +Local Hint Resolve Regset.mem_2 Regset.subset_2. + +Lemma lazy_and_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. +Proof. + destruct b1; simpl; intuition. +Qed. + +Lemma list_mem_correct (rl: list reg) (alive: Regset.t): + list_mem rl alive = true -> forall r, List.In r rl -> ext alive r. +Proof. + induction rl; simpl; try rewrite lazy_and_true; intuition subst; auto. +Qed. + +Lemma eqlive_reg_list (alive: Regset.elt -> Prop) args rs1 rs2: eqlive_reg alive rs1 rs2 -> (forall r, List.In r args -> (alive r)) -> rs1##args = rs2##args. +Proof. + induction args; simpl; auto. + intros EQLIVE ALIVE; rewrite IHargs; auto. + unfold eqlive_reg in EQLIVE. + rewrite EQLIVE; auto. +Qed. + +Lemma eqlive_reg_listmem (alive: Regset.t) args rs1 rs2: eqlive_reg (ext alive) rs1 rs2 -> list_mem args alive = true -> rs1##args = rs2##args. +Proof. + intros; eapply eqlive_reg_list; eauto. + intros; eapply list_mem_correct; eauto. +Qed. + +Record eqlive_istate alive (st1 st2: istate): Prop := + { eqlive_continue: icontinue st1 = icontinue st2; + eqlive_ipc: ipc st1 = ipc st2; + eqlive_irs: eqlive_reg alive (irs st1) (irs st2); + eqlive_imem: (imem st1) = (imem st2) }. + +Lemma iinst_checker_eqlive ge sp pm alive i res rs1 rs2 m st1: + eqlive_reg (ext alive) rs1 rs2 -> + iinst_checker pm alive i = Some res -> + istep ge i sp rs1 m = Some st1 -> + exists st2, istep ge i sp rs2 m = Some st2 /\ eqlive_istate (ext (fst res)) st1 st2. +Proof. + intros EQLIVE. + destruct i; simpl; try_simplify_someHyps. + - (* Inop *) + repeat (econstructor; eauto). + - (* Iop *) + inversion_ASSERT; try_simplify_someHyps. + inversion_SOME v. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + - (* Iload *) + inversion_ASSERT; try_simplify_someHyps. + destruct t. (* TODO - simplify that proof ? *) + + inversion_SOME a0. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + inversion_SOME v; try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto. + destruct (eval_addressing _ _ _ _). + * destruct (Memory.Mem.loadv _ _ _). + ** intros. inv H1. repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + ** intros. inv H1. repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + * intros. inv H1. repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + - (* Istore *) + (repeat inversion_ASSERT); try_simplify_someHyps. + inversion_SOME a0. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + rewrite <- (EQLIVE r); auto. + inversion_SOME v; try_simplify_someHyps. + try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + - (* Icond *) + inversion_ASSERT. + inversion_SOME b. intros EVAL. + intros ARGS; erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + exploit exit_checker_res; eauto. + intro; subst; simpl. auto. +Qed. + +Lemma iinst_checker_istep_continue ge sp pm alive i res rs m st: + iinst_checker pm alive i = Some res -> + istep ge i sp rs m = Some st -> + icontinue st = true -> + (snd res)=(ipc st). +Proof. + intros; exploit iinst_checker_default_succ; eauto. + erewrite istep_normal_exit; eauto. + congruence. +Qed. + +Lemma exit_checker_eqlive A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res rs1 rs2: + exit_checker pm alive pc v = Some res -> + eqlive_reg (ext alive) rs1 rs2 -> + exists path, pm!pc = Some path /\ eqlive_reg (ext path.(input_regs)) rs1 rs2. +Proof. + unfold exit_checker. + inversion_SOME path. + inversion_ASSERT. try_simplify_someHyps. + repeat (econstructor; eauto). + intros; eapply eqlive_reg_monotonic; eauto. + intros; exploit Regset.subset_2; eauto. +Qed. + +Lemma iinst_checker_eqlive_stopped ge sp pm alive i res rs1 rs2 m st1: + eqlive_reg (ext alive) rs1 rs2 -> + istep ge i sp rs1 m = Some st1 -> + iinst_checker pm alive i = Some res -> + icontinue st1 = false -> + exists path st2, pm!(ipc st1) = Some path /\ istep ge i sp rs2 m = Some st2 /\ eqlive_istate (ext path.(input_regs)) st1 st2. +Proof. + intros EQLIVE. + set (tmp := istep ge i sp rs2). + destruct i; simpl; try_simplify_someHyps; repeat (inversion_ASSERT || inversion_SOME b); try_simplify_someHyps; try congruence. + 1-3: explore_destruct; simpl; try_simplify_someHyps; repeat (inversion_ASSERT || inversion_SOME b); try_simplify_someHyps; try congruence. + (* Icond *) + unfold tmp; clear tmp; simpl. + intros EVAL; erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + destruct b eqn:EQb; simpl in * |-; try congruence. + intros; exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE2). + repeat (econstructor; simpl; eauto). +Qed. + +Lemma ipath_checker_eqlive_normal ge ps (f:function) sp pm: forall alive pc res rs1 rs2 m st1, + eqlive_reg (ext alive) rs1 rs2 -> + ipath_checker ps f pm alive pc = Some res -> + isteps ge ps f sp rs1 m pc = Some st1 -> + icontinue st1 = true -> + exists st2, isteps ge ps f sp rs2 m pc = Some st2 /\ eqlive_istate (ext (fst res)) st1 st2. +Proof. + induction ps as [|ps]; simpl; try_simplify_someHyps. + - repeat (econstructor; simpl; eauto). + - inversion_SOME i; try_simplify_someHyps. + inversion_SOME res0. + inversion_SOME st0. + intros. + exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP & [CONT PC RS MEM]). + try_simplify_someHyps. + rewrite <- CONT, <- MEM, <- PC. + destruct (icontinue st0) eqn:CONT'. + * intros; exploit iinst_checker_istep_continue; eauto. + rewrite <- PC; intros X; rewrite X in * |-. eauto. + * try_simplify_someHyps. + congruence. +Qed. + +Lemma ipath_checker_isteps_continue ge ps (f:function) sp pm: forall alive pc res rs m st, + ipath_checker ps f pm alive pc = Some res -> + isteps ge ps f sp rs m pc = Some st -> + icontinue st = true -> + (snd res)=(ipc st). +Proof. + induction ps as [|ps]; simpl; try_simplify_someHyps. + inversion_SOME i; try_simplify_someHyps. + inversion_SOME res0. + inversion_SOME st0. + destruct (icontinue st0) eqn:CONT'. + - intros; exploit iinst_checker_istep_continue; eauto. + intros EQ; rewrite EQ in * |-; clear EQ; eauto. + - try_simplify_someHyps; congruence. +Qed. + +Lemma ipath_checker_eqlive_stopped ge ps (f:function) sp pm: forall alive pc res rs1 rs2 m st1, + eqlive_reg (ext alive) rs1 rs2 -> + ipath_checker ps f pm alive pc = Some res -> + isteps ge ps f sp rs1 m pc = Some st1 -> + icontinue st1 = false -> + exists path st2, pm!(ipc st1) = Some path /\ isteps ge ps f sp rs2 m pc = Some st2 /\ eqlive_istate (ext path.(input_regs)) st1 st2. +Proof. + induction ps as [|ps]; simpl; try_simplify_someHyps; try congruence. + inversion_SOME i; try_simplify_someHyps. + inversion_SOME res0. + inversion_SOME st0. + intros. + destruct (icontinue st0) eqn:CONT'; try_simplify_someHyps; intros. + * intros; exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP & [CONT PC RS MEM]). + exploit iinst_checker_istep_continue; eauto. + intros PC'. + try_simplify_someHyps. + rewrite PC', <- CONT, <- MEM, <- PC, CONT'. + eauto. + * intros; exploit iinst_checker_eqlive_stopped; eauto. + intros EQLIVE; generalize EQLIVE; destruct 1 as (path & st2 & PATH & ISTEP & [CONT PC RS MEM]). + try_simplify_someHyps. + rewrite <- CONT, <- MEM, <- PC, CONT'. + try_simplify_someHyps. +Qed. + +Inductive eqlive_stackframes: stackframe -> stackframe -> Prop := + | eqlive_stackframes_intro path res f sp pc rs1 rs2 + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: forall v, eqlive_reg (ext path.(input_regs)) (rs1 # res <- v) (rs2 # res <- v)): + eqlive_stackframes (Stackframe res f sp pc rs1) (Stackframe res f sp pc rs2). + +Inductive eqlive_states: state -> state -> Prop := + | eqlive_states_intro + path st1 st2 f sp pc rs1 rs2 m + (STACKS: list_forall2 eqlive_stackframes st1 st2) + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: eqlive_reg (ext path.(input_regs)) rs1 rs2): + eqlive_states (State st1 f sp pc rs1 m) (State st2 f sp pc rs2 m) + | eqlive_states_call st1 st2 f args m + (LIVE: liveness_ok_fundef f) + (STACKS: list_forall2 eqlive_stackframes st1 st2): + eqlive_states (Callstate st1 f args m) (Callstate st2 f args m) + | eqlive_states_return st1 st2 v m + (STACKS: list_forall2 eqlive_stackframes st1 st2): + eqlive_states (Returnstate st1 v m) (Returnstate st2 v m). + + +Section LivenessProperties. + +Variable prog: program. + +Let pge := Genv.globalenv prog. +Let ge := Genv.globalenv (RTLpath.transf_program prog). + +Hypothesis all_fundef_liveness_ok: forall b f, + Genv.find_funct_ptr pge b = Some f -> + liveness_ok_fundef f. + +Lemma find_funct_liveness_ok v fd: + Genv.find_funct pge v = Some fd -> liveness_ok_fundef fd. +Proof. + unfold Genv.find_funct. + destruct v; try congruence. + destruct (Integers.Ptrofs.eq_dec _ _); try congruence. + eapply all_fundef_liveness_ok; eauto. +Qed. + +Lemma find_function_liveness_ok ros rs f: + find_function pge ros rs = Some f -> liveness_ok_fundef f. +Proof. + destruct ros as [r|i]; simpl. + - intros; eapply find_funct_liveness_ok; eauto. + - destruct (Genv.find_symbol pge i); try congruence. + eapply all_fundef_liveness_ok; eauto. +Qed. + +Lemma find_function_eqlive alive ros rs1 rs2: + eqlive_reg (ext alive) rs1 rs2 -> + reg_sum_mem ros alive = true -> + find_function pge ros rs1 = find_function pge ros rs2. +Proof. + intros EQLIVE. + destruct ros; simpl; auto. + intros H; erewrite (EQLIVE r); eauto. +Qed. + +Lemma inst_checker_from_iinst_checker i sp rs m st pm alive: + istep ge i sp rs m = Some st -> + inst_checker pm alive i = (SOME res <- iinst_checker pm alive i IN exit_checker pm (fst res) (snd res) tt). +Proof. + destruct i; simpl; try congruence. +Qed. + +Lemma exit_checker_eqlive_ext1 (pm: path_map) (alive: Regset.t) (pc: node) r rs1 rs2: + exit_checker pm (Regset.add r alive) pc tt = Some tt -> + eqlive_reg (ext alive) rs1 rs2 -> + exists path, pm!pc = Some path /\ (forall v, eqlive_reg (ext path.(input_regs)) (rs1 # r <- v) (rs2 # r <- v)). +Proof. + unfold exit_checker. + inversion_SOME path. + inversion_ASSERT. try_simplify_someHyps. + repeat (econstructor; eauto). + intros; eapply eqlive_reg_update; eauto. + eapply eqlive_reg_monotonic; eauto. + intros r0 [X1 X2]; exploit Regset.subset_2; eauto. + rewrite regset_add_spec. intuition subst. +Qed. + +Local Hint Resolve in_or_app: local. +Lemma eqlive_eval_builtin_args alive rs1 rs2 sp m args vargs: + eqlive_reg alive rs1 rs2 -> + Events.eval_builtin_args ge (fun r => rs1 # r) sp m args vargs -> + (forall r, List.In r (params_of_builtin_args args) -> alive r) -> + Events.eval_builtin_args ge (fun r => rs2 # r) sp m args vargs. +Proof. + unfold Events.eval_builtin_args. + intros EQLIVE; induction 1 as [|a1 al b1 bl EVAL1 EVALL]; simpl. + { econstructor; eauto. } + intro X. + assert (X1: eqlive_reg (fun r => In r (params_of_builtin_arg a1)) rs1 rs2). + { eapply eqlive_reg_monotonic; eauto with local. } + lapply IHEVALL; eauto with local. + clear X IHEVALL; intro X. econstructor; eauto. + generalize X1; clear EVALL X1 X. + induction EVAL1; simpl; try (econstructor; eauto; fail). + - intros X1; erewrite X1; [ econstructor; eauto | eauto ]. + - intros; econstructor. + + eapply IHEVAL1_1; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. + + eapply IHEVAL1_2; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. + - intros; econstructor. + + eapply IHEVAL1_1; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. + + eapply IHEVAL1_2; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. +Qed. + +Lemma exit_checker_eqlive_builtin_res (pm: path_map) (alive: Regset.t) (pc: node) rs1 rs2 (res:builtin_res reg): + exit_checker pm (reg_builtin_res res alive) pc tt = Some tt -> + eqlive_reg (ext alive) rs1 rs2 -> + exists path, pm!pc = Some path /\ (forall vres, eqlive_reg (ext path.(input_regs)) (regmap_setres res vres rs1) (regmap_setres res vres rs2)). +Proof. + destruct res; simpl. + - intros; exploit exit_checker_eqlive_ext1; eauto. + - intros; exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE). + eexists; intuition eauto. + - intros; exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE). + eexists; intuition eauto. +Qed. + +Lemma exit_list_checker_eqlive (pm: path_map) (alive: Regset.t) (tbl: list node) rs1 rs2 pc: forall n, + exit_list_checker pm alive tbl = true -> + eqlive_reg (ext alive) rs1 rs2 -> + list_nth_z tbl n = Some pc -> + exists path, pm!pc = Some path /\ eqlive_reg (ext path.(input_regs)) rs1 rs2. +Proof. + induction tbl; simpl. + - intros; try congruence. + - intros n; rewrite lazy_and_Some_tt_true; destruct (zeq n 0) eqn: Hn. + * try_simplify_someHyps; intuition. + exploit exit_checker_eqlive; eauto. + * intuition. eapply IHtbl; eauto. +Qed. + +Lemma inst_checker_eqlive (f: function) sp alive pc i rs1 rs2 m stk1 stk2 t s1: + list_forall2 eqlive_stackframes stk1 stk2 -> + eqlive_reg (ext alive) rs1 rs2 -> + liveness_ok_function f -> + (fn_code f) ! pc = Some i -> + path_last_step ge pge stk1 f sp pc rs1 m t s1 -> + inst_checker (fn_path f) alive i = Some tt -> + exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. +Proof. + intros STACKS EQLIVE LIVENESS PC; + destruct 1 as [i' sp pc rs1 m st1| + sp pc rs1 m sig ros args res pc' fd| + st1 pc rs1 m sig ros args fd m'| + sp pc rs1 m ef args res pc' vargs t vres m'| + sp pc rs1 m arg tbl n pc' | + st1 pc rs1 m optr m']; + try_simplify_someHyps. + + (* istate *) + intros PC ISTEP. erewrite inst_checker_from_iinst_checker; eauto. + inversion_SOME res. + intros. + destruct (icontinue st1) eqn: CONT. + - (* CONT => true *) + exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE2). + eapply eqlive_states_intro; eauto. + erewrite <- iinst_checker_istep_continue; eauto. + - (* CONT => false *) + intros; exploit iinst_checker_eqlive_stopped; eauto. + destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + eapply eqlive_states_intro; eauto. + + (* Icall *) + repeat inversion_ASSERT. intros. + exploit exit_checker_eqlive_ext1; eauto. + intros (path & PATH & EQLIVE2). + eexists; split. + - eapply exec_Icall; eauto. + erewrite <- find_function_eqlive; eauto. + - erewrite eqlive_reg_listmem; eauto. + eapply eqlive_states_call; eauto. + eapply find_function_liveness_ok; eauto. + repeat (econstructor; eauto). + + (* Itailcall *) + repeat inversion_ASSERT. intros. + eexists; split. + - eapply exec_Itailcall; eauto. + erewrite <- find_function_eqlive; eauto. + - erewrite eqlive_reg_listmem; eauto. + eapply eqlive_states_call; eauto. + eapply find_function_liveness_ok; eauto. + + (* Ibuiltin *) + repeat inversion_ASSERT. intros. + exploit exit_checker_eqlive_builtin_res; eauto. + intros (path & PATH & EQLIVE2). + eexists; split. + - eapply exec_Ibuiltin; eauto. + eapply eqlive_eval_builtin_args; eauto. + intros; eapply list_mem_correct; eauto. + - repeat (econstructor; simpl; eauto). + + (* Ijumptable *) + repeat inversion_ASSERT. intros. + exploit exit_list_checker_eqlive; eauto. + intros (path & PATH & EQLIVE2). + eexists; split. + - eapply exec_Ijumptable; eauto. + erewrite <- EQLIVE; eauto. + - repeat (econstructor; simpl; eauto). + + (* Ireturn *) + repeat inversion_ASSERT. intros. + eexists; split. + - eapply exec_Ireturn; eauto. + - destruct optr; simpl in * |- *. + * erewrite (EQLIVE r); eauto. + eapply eqlive_states_return; eauto. + * eapply eqlive_states_return; eauto. +Qed. + +Lemma path_step_eqlive path stk1 f sp rs1 m pc t s1 stk2 rs2: + path_step ge pge (psize path) stk1 f sp rs1 m pc t s1 -> + list_forall2 eqlive_stackframes stk1 stk2 -> + eqlive_reg (ext (input_regs path)) rs1 rs2 -> + liveness_ok_function f -> + (fn_path f) ! pc = Some path -> + exists s2, path_step ge pge (psize path) stk2 f sp rs2 m pc t s2 /\ eqlive_states s1 s2. +Proof. + intros STEP STACKS EQLIVE LIVE PC. + unfold liveness_ok_function in LIVE. + exploit LIVE; eauto. + unfold path_checker. + inversion_SOME res; (* destruct res as [alive pc']. *) intros ICHECK. (* simpl. *) + inversion_SOME i; intros PC'. + destruct STEP as [st ISTEPS CONT|]. + - (* early_exit *) + intros; exploit ipath_checker_eqlive_stopped; eauto. + destruct 1 as (path2 & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + eapply eqlive_states_intro; eauto. + - (* normal_exit *) + intros; exploit ipath_checker_eqlive_normal; eauto. + destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). + exploit ipath_checker_isteps_continue; eauto. + intros PC3; rewrite <- PC3, <- PC2 in * |-. + exploit inst_checker_eqlive; eauto. + intros (s2 & LAST_STEP & EQLIVE2). + eexists; split; eauto. + eapply exec_normal_exit; eauto. + rewrite <- PC3, <- MEM; auto. +Qed. + +Theorem step_eqlive t s1 s1' s2: + step ge pge s1 t s1' -> + eqlive_states s1 s2 -> + exists s2', step ge pge s2 t s2' /\ eqlive_states s1' s2'. +Proof. + destruct 1 as [path stack f sp rs m pc t s PATH STEP | | | ]. + - intros EQLIVE; inv EQLIVE; simplify_someHyps. + intro PATH. + exploit path_step_eqlive; eauto. + intros (s2 & STEP2 & EQUIV2). + eexists; split; eauto. + eapply exec_path; eauto. + - intros EQLIVE; inv EQLIVE; inv LIVE. + exploit initialize_path. { eapply fn_entry_point_wf. } + intros (path & Hpath). + eexists; split. + * eapply exec_function_internal; eauto. + * eapply eqlive_states_intro; eauto. + eapply eqlive_reg_refl. + - intros EQLIVE; inv EQLIVE. + eexists; split. + * eapply exec_function_external; eauto. + * eapply eqlive_states_return; eauto. + - intros EQLIVE; inv EQLIVE. + inversion STACKS as [|s1 st1 s' s2 STACK STACKS']; subst; clear STACKS. + inv STACK. + exists (State s2 f sp pc (rs2 # res <- vres) m); split. + * apply exec_return. + * eapply eqlive_states_intro; eauto. +Qed. + +End LivenessProperties. diff --git a/scheduling/RTLpathSE_impl.v b/scheduling/RTLpathSE_impl.v new file mode 100644 index 00000000..afc9785e --- /dev/null +++ b/scheduling/RTLpathSE_impl.v @@ -0,0 +1,1631 @@ +(** Implementation and refinement of the symbolic execution + *) + +Require Import Coqlib Maps Floats. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL RTLpath. +Require Import Errors Duplicate. +Require Import RTLpathSE_theory. +Require Import Axioms. + +Local Open Scope error_monad_scope. +Local Open Scope option_monad_scope. + +(** * TODO: refine symbolic values/symbolic memories with hash-consed symbolic values *) + +(** * Implementation of local symbolic internal states - definitions and core simulation properties *) + +(** name : Hash-consed Symbolic Internal state local. Later on we will use the + refinement to introduce hash consing *) +Record hsistate_local := + { + (** [hsi_lsmem] represents the list of smem symbolic evaluations. + The first one of the list is the current smem *) + hsi_lsmem:> list smem; + (** For the values in registers: + 1) we store a list of sval evaluations + 2) we encode the symbolic regset by a PTree *) + hsi_ok_lsval: list sval; + hsi_sreg:> PTree.t sval + }. + +Definition hsi_sreg_get (hst: PTree.t sval) r: sval := + match PTree.get r hst with + | None => Sinput r + | Some sv => sv + end. + +(* NB: short cut *) +Definition hsi_sreg_eval ge sp (hst: PTree.t sval) r rs0 m0: option val := + match PTree.get r hst with + | None => Some (Regmap.get r rs0) + | Some sv => seval_sval ge sp sv rs0 m0 + end. + +Lemma hsi_sreg_eval_correct ge sp hst r rs0 m0: + hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (hsi_sreg_get hst r) rs0 m0. +Proof. + unfold hsi_sreg_eval, hsi_sreg_get; destruct (PTree.get r hst); simpl; auto. +Qed. + +Definition hsi_smem_get (hst: list smem): smem := + match hst with + | nil => Sinit + | sm::_ => sm + end. + +(* NB: short cut *) +Definition hsi_smem_eval ge sp (hst: list smem) rs0 m0 : option mem := + match hst with + | nil => Some m0 + | sm::_ => seval_smem ge sp sm rs0 m0 + end. + +Lemma hsi_smem_eval_correct ge sp hst rs0 m0: + hsi_smem_eval ge sp hst rs0 m0 = seval_smem ge sp (hsi_smem_get hst) rs0 m0. +Proof. + unfold hsi_smem_eval, hsi_smem_get; destruct hst; simpl; auto. +Qed. + + +(* negation of sabort_local *) +Definition sok_local (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) (st: sistate_local): Prop := + (st.(si_pre) ge sp rs0 m0) + /\ seval_smem ge sp st.(si_smem) rs0 m0 <> None + /\ forall (r: reg), seval_sval ge sp (si_sreg st r) rs0 m0 <> None. + +Lemma ssem_local_sok ge sp rs0 m0 st rs m: + ssem_local ge sp st rs0 m0 rs m -> sok_local ge sp rs0 m0 st. +Proof. + unfold sok_local, ssem_local. + intuition congruence. +Qed. + +Definition hsok_local ge sp rs0 m0 (hst: hsistate_local) : Prop := + (forall sv, List.In sv (hsi_ok_lsval hst) -> seval_sval ge sp sv rs0 m0 <> None) + /\ (forall sm, List.In sm (hsi_lsmem hst) -> seval_smem ge sp sm rs0 m0 <> None). + +(* refinement link between a (st: sistate_local) and (hst: hsistate_local) *) +Definition hsilocal_refines ge sp rs0 m0 (hst: hsistate_local) (st: sistate_local) := + (sok_local ge sp rs0 m0 st <-> hsok_local ge sp rs0 m0 hst) + /\ (hsok_local ge sp rs0 m0 hst -> hsi_smem_eval ge sp hst rs0 m0 = seval_smem ge sp st.(si_smem) rs0 m0) + /\ (hsok_local ge sp rs0 m0 hst -> forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (si_sreg st r) rs0 m0). + +Lemma ssem_local_refines_hok ge sp rs0 m0 hst st rs m: + ssem_local ge sp st rs0 m0 rs m -> hsilocal_refines ge sp rs0 m0 hst st -> hsok_local ge sp rs0 m0 hst. +Proof. + intros H0 (H1 & _ & _). apply H1. eapply ssem_local_sok. eauto. +Qed. + +Definition is_subset {A: Type} (lv2 lv1: list A) := forall v, In v lv2 -> In v lv1. + +Definition hsilocal_simu_core (hst1 hst2: hsistate_local) := + is_subset (hsi_lsmem hst2) (hsi_lsmem hst1) + /\ is_subset (hsi_ok_lsval hst2) (hsi_ok_lsval hst1) + /\ (forall r, hsi_sreg_get hst2 r = hsi_sreg_get hst1 r) + /\ hsi_smem_get hst1 = hsi_smem_get hst2. + +Lemma hsilocal_simu_core_nofail ge1 ge2 sp rs0 m0 hst1 hst2: + hsilocal_simu_core hst1 hst2 -> + (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> + hsok_local ge1 sp rs0 m0 hst1 -> + hsok_local ge2 sp rs0 m0 hst2. +Proof. + intros (MEMOK & RSOK & _ & _) GFS (OKV & OKM). constructor. + - intros sv INS. apply RSOK in INS. apply OKV in INS. erewrite seval_preserved; eauto. + - intros sm INS. apply MEMOK in INS. apply OKM in INS. erewrite smem_eval_preserved; eauto. +Qed. + +Remark istate_simulive_reflexive dm is: istate_simulive (fun _ : Regset.elt => True) dm is is. +Proof. + unfold istate_simulive. + repeat (constructor; auto). +Qed. + +Theorem hsilocal_simu_core_correct hst1 hst2 ge1 ge2 sp rs0 m0 rs m st1 st2: + hsilocal_simu_core hst1 hst2 -> + hsilocal_refines ge1 sp rs0 m0 hst1 st1 -> + hsilocal_refines ge2 sp rs0 m0 hst2 st2 -> + (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> + ssem_local ge1 sp st1 rs0 m0 rs m -> + ssem_local ge2 sp st2 rs0 m0 rs m. +Proof. + intros CORE HREF1 HREF2 GFS SEML. + exploit ssem_local_refines_hok; eauto. intro HOK1. + exploit hsilocal_simu_core_nofail; eauto. intro HOK2. + destruct SEML as (PRE & MEMEQ & RSEQ). + constructor; [|constructor]. + + destruct HREF2 as (OKEQ & _ & _). rewrite <- OKEQ in HOK2. apply HOK2. + + destruct HREF2 as (_ & MEMEQ2 & _). destruct HREF1 as (_ & MEMEQ1 & _). + destruct CORE as (_ & _ & _ & MEMEQ3). + rewrite <- MEMEQ2; auto. rewrite hsi_smem_eval_correct. rewrite <- MEMEQ3. + erewrite smem_eval_preserved; [| eapply GFS]. + rewrite <- hsi_smem_eval_correct. rewrite MEMEQ1; auto. + + intro r. destruct HREF2 as (_ & _ & A). destruct HREF1 as (_ & _ & B). + destruct CORE as (_ & _ & C & _). rewrite <- A; auto. rewrite hsi_sreg_eval_correct. + rewrite C. erewrite seval_preserved; [| eapply GFS]. rewrite <- hsi_sreg_eval_correct. + rewrite B; auto. +Qed. + +(* Syntax and semantics of symbolic exit states *) +(* TODO: add hash-consing *) +Record hsistate_exit := mk_hsistate_exit + { hsi_cond: condition; hsi_scondargs: list_sval; hsi_elocal: hsistate_local; hsi_ifso: node }. + +Definition hsiexit_simu_core dm f (hse1 hse2: hsistate_exit) := + (exists path, (fn_path f) ! (hsi_ifso hse1) = Some path) + /\ dm ! (hsi_ifso hse2) = Some (hsi_ifso hse1) + /\ hsi_cond hse1 = hsi_cond hse2 + /\ hsi_scondargs hse1 = hsi_scondargs hse2 (* FIXME - should there be something about okvals ? *) + /\ hsilocal_simu_core (hsi_elocal hse1) (hsi_elocal hse2). + +Definition hsiexit_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit) := OK tt (* TODO *). + +Theorem hsiexit_simu_coreb_correct hse1 hse2 dm f: + hsiexit_simu_coreb dm f hse1 hse2 = OK tt -> + hsiexit_simu_core dm f hse1 hse2. +Proof. +Admitted. + +(** NB: we split the refinement relation between a "static" part -- independendent of the initial context + and a "dynamic" part -- that depends on it +*) +Definition hsiexit_refines_stat (hext: hsistate_exit) (ext: sistate_exit): Prop := + hsi_cond hext = si_cond ext + /\ hsi_ifso hext = si_ifso ext. + +Definition hsok_exit ge sp rs m hse := hsok_local ge sp rs m (hsi_elocal hse). + +Definition hsiexit_refines_dyn ge sp rs0 m0 (hext: hsistate_exit) (ext: sistate_exit): Prop := + hsilocal_refines ge sp rs0 m0 (hsi_elocal hext) (si_elocal ext) + /\ seval_condition ge sp (hsi_cond hext) (hsi_scondargs hext) (hsi_smem_get (hsi_elocal hext)) rs0 m0 + = seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs0 m0. + +Definition hsiexit_simu dm f (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, + hsiexit_refines_stat hse1 se1 -> + hsiexit_refines_stat hse2 se2 -> + hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> + hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> + siexit_simu dm f ctx se1 se2. + +Lemma hsiexit_simu_core_nofail dm f hse1 hse2 ge1 ge2 sp rs m: + hsiexit_simu_core dm f hse1 hse2 -> + (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> + hsok_exit ge1 sp rs m hse1 -> + hsok_exit ge2 sp rs m hse2. +Proof. + intros CORE GFS HOK1. + destruct CORE as (_ & _ & _ & _ & CORE). + eapply hsilocal_simu_core_nofail; eauto. +Qed. + +Theorem hsiexit_simu_core_correct dm f hse1 hse2 ctx: + hsiexit_simu_core dm f hse1 hse2 -> + hsiexit_simu dm f ctx hse1 hse2. +Proof. + intros SIMUC (* HOK1 *) st1 st2 HREF1 HREF2 HDYN1 HDYN2. + assert (SEVALC: + seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond st1) (si_scondargs st1) (si_smem (si_elocal st1)) + (the_rs0 ctx) (the_m0 ctx) = + seval_condition (the_ge2 ctx) (the_sp ctx) (si_cond st2) (si_scondargs st2) (si_smem (si_elocal st2)) + (the_rs0 ctx) (the_m0 ctx)). + { destruct HDYN1 as (_ & SCOND1). rewrite <- SCOND1 by assumption. clear SCOND1. + destruct HDYN2 as (_ & SCOND2). rewrite <- SCOND2 by assumption. clear SCOND2. + destruct SIMUC as (_ & _ & CONDEQ & ARGSEQ & LSIMU). destruct LSIMU as (_ & _ & _ & MEMEQ). + rewrite CONDEQ. rewrite ARGSEQ. rewrite MEMEQ. erewrite <- seval_condition_preserved; eauto. + eapply ctx. } + constructor; [assumption|]. intros is1 SSEME. + assert (HOK1: hsok_exit (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1). { + unfold hsok_exit. destruct SSEME as (_ & SSEML & _). apply ssem_local_sok in SSEML. + destruct HDYN1 as (LREF & _). destruct LREF as (OKEQ & _ & _). rewrite <- OKEQ. assumption. } + exploit hsiexit_simu_core_nofail. 2: eapply ctx. all: eauto. intro HOK2. + exists (mk_istate (icontinue is1) (si_ifso st2) (irs is1) (imem is1)). simpl. constructor. + - constructor; [|constructor]. + + rewrite <- SEVALC. destruct SSEME as (SCOND & _ & _). assumption. + + destruct SSEME as (_ & SLOC & _). destruct SIMUC as (_ & _ & _ & _ & LSIMU). + destruct HDYN1 as (LREF1 & _). destruct HDYN2 as (LREF2 & _). + eapply hsilocal_simu_core_correct; eauto. apply ctx. + + reflexivity. + - unfold istate_simu. destruct (icontinue is1) eqn:ICONT. + * constructor; [|constructor]; simpl; auto. + constructor; auto. + * simpl. destruct SIMUC as ((path & PATH) & REVEQ & _ & _ & _ & _). + assert (PCEQ: hsi_ifso hse1 = ipc is1). { destruct SSEME as (_ & _ & PCEQ). destruct HREF1 as (_ & IFSO). congruence. } + exists path. constructor; [|constructor]. + + congruence. + + constructor; [|constructor]; simpl; auto. + constructor; auto. + + destruct HREF2 as (_ & IFSO). congruence. +Qed. + +Remark hsiexit_simu_siexit dm f ctx hse1 hse2 se1 se2: + hsiexit_simu dm f ctx hse1 hse2 -> + hsiexit_refines_stat hse1 se1 -> + hsiexit_refines_stat hse2 se2 -> + hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> + hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> + siexit_simu dm f ctx se1 se2. +Proof. + auto. +Qed. + +Definition hsiexits_simu dm f (ctx: simu_proof_context f) lhse1 lhse2: Prop := + list_forall2 (hsiexit_simu dm f ctx) lhse1 lhse2. + +Definition hsiexits_simu_core dm f lhse1 lhse2: Prop := + list_forall2 (hsiexit_simu_core dm f) lhse1 lhse2. + +Theorem hsiexits_simu_core_correct dm f lhse1 lhse2 ctx: + hsiexits_simu_core dm f lhse1 lhse2 -> + hsiexits_simu dm f ctx lhse1 lhse2. +Proof. + induction 1; [constructor|]. + constructor; [|apply IHlist_forall2; assumption]. + apply hsiexit_simu_core_correct; assumption. +Qed. + +Definition hsiexits_refines_stat lhse lse := + list_forall2 hsiexit_refines_stat lhse lse. + +Definition hsiexits_refines_dyn ge sp rs0 m0 lhse se := + list_forall2 (hsiexit_refines_dyn ge sp rs0 m0) lhse se. + +(** * Syntax and Semantics of symbolic internal state *) +Record hsistate := { hsi_pc: node; hsi_exits: list hsistate_exit; hsi_local: hsistate_local }. + +Definition hsistate_simu_core dm f (hse1 hse2: hsistate) := + dm ! (hsi_pc hse2) = Some (hsi_pc hse1) + /\ list_forall2 (hsiexit_simu_core dm f) (hsi_exits hse1) (hsi_exits hse2) + /\ hsilocal_simu_core (hsi_local hse1) (hsi_local hse2). + +Definition hsistate_refines_stat (hst: hsistate) (st:sistate): Prop := + hsi_pc hst = si_pc st + /\ hsiexits_refines_stat (hsi_exits hst) (si_exits st). + +Definition hsistate_refines_dyn ge sp rs0 m0 (hst: hsistate) (st:sistate): Prop := + hsiexits_refines_dyn ge sp rs0 m0 (hsi_exits hst) (si_exits st) + /\ hsilocal_refines ge sp rs0 m0 (hsi_local hst) (si_local st). + +Definition hsistate_simu dm f (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, + hsistate_refines_stat hst1 st1 -> + hsistate_refines_stat hst2 st2 -> + hsistate_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst1 st1 -> + hsistate_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst2 st2 -> + sistate_simu dm f st1 st2 ctx. + +Lemma siexits_simu_all_fallthrough dm f ctx: forall lse1 lse2, + siexits_simu dm f lse1 lse2 ctx -> + all_fallthrough (the_ge1 ctx) (the_sp ctx) lse1 (the_rs0 ctx) (the_m0 ctx) -> + all_fallthrough (the_ge2 ctx) (the_sp ctx) lse2 (the_rs0 ctx) (the_m0 ctx). +Proof. + induction 1; [unfold all_fallthrough; contradiction|]. + intros X ext INEXT. eapply all_fallthrough_revcons in X. destruct X as (SEVAL & ALLFU). + apply IHlist_forall2 in ALLFU. + destruct H as (CONDSIMU & _). + inv INEXT; [|eauto]. + erewrite <- CONDSIMU; eauto. +Qed. + +Lemma hsiexits_simu_siexits dm f ctx lhse1 lhse2: + hsiexits_simu dm f ctx lhse1 lhse2 -> + forall lse1 lse2, + hsiexits_refines_stat lhse1 lse1 -> + hsiexits_refines_stat lhse2 lse2 -> + hsiexits_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse1 lse1 -> + hsiexits_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse2 lse2 -> + siexits_simu dm f lse1 lse2 ctx. +Proof. + induction 1. + - intros. inv H. inv H0. constructor. + - intros lse1 lse2 SREF1 SREF2 DREF1 DREF2. inv SREF1. inv SREF2. inv DREF1. inv DREF2. + constructor; [| eapply IHlist_forall2; eauto]. + eapply hsiexit_simu_siexit; eauto. +Qed. + +Lemma siexits_simu_all_fallthrough_upto dm f ctx lse1 lse2: + siexits_simu dm f lse1 lse2 ctx -> forall ext1 lx1, + all_fallthrough_upto_exit (the_ge1 ctx) (the_sp ctx) ext1 lx1 lse1 (the_rs0 ctx) (the_m0 ctx) -> + exists ext2 lx2, + all_fallthrough_upto_exit (the_ge2 ctx) (the_sp ctx) ext2 lx2 lse2 (the_rs0 ctx) (the_m0 ctx) + /\ length lx1 = length lx2. +Proof. + induction 1. + - intros. destruct H as (ITAIL & ALLFU). eapply is_tail_false in ITAIL. contradiction. + - intros ext1 lx1 ALLFUE. + destruct ALLFUE as (ITAIL & ALLFU). inv ITAIL. + + eexists; eexists. + constructor; [| eapply list_forall2_length; eauto]. + constructor; [econstructor | eapply siexits_simu_all_fallthrough; eauto]. + + exploit IHlist_forall2; [constructor; eauto|]. + intros (ext2 & lx2 & ALLFUE2 & LENEQ). + eexists; eexists. constructor; eauto. + eapply all_fallthrough_upto_exit_cons; eauto. +Qed. + +Lemma list_forall2_nth_error {A} (l1 l2: list A) P: + list_forall2 P l1 l2 -> + forall x1 x2 n, + nth_error l1 n = Some x1 -> + nth_error l2 n = Some x2 -> + P x1 x2. +Proof. + induction 1. + - intros. rewrite nth_error_nil in H. discriminate. + - intros x1 x2 n. destruct n as [|n]; simpl. + + intros. inv H1. inv H2. assumption. + + apply IHlist_forall2. +Qed. + +Lemma is_tail_length {A} (l1 l2: list A): + is_tail l1 l2 -> + (length l1 <= length l2)%nat. +Proof. + induction l2. + - intro. destruct l1; auto. apply is_tail_false in H. contradiction. + - intros ITAIL. inv ITAIL; auto. + apply IHl2 in H1. clear IHl2. simpl. omega. +Qed. + +Lemma is_tail_nth_error {A} (l1 l2: list A) x: + is_tail (x::l1) l2 -> + nth_error l2 ((length l2) - length l1 - 1) = Some x. +Proof. + induction l2. + - intro ITAIL. apply is_tail_false in ITAIL. contradiction. + - intros ITAIL. assert (length (a::l2) = S (length l2)) by auto. rewrite H. clear H. + assert (forall n n', ((S n) - n' - 1)%nat = (n - n')%nat) by (intros; omega). rewrite H. clear H. + inv ITAIL. + + assert (forall n, (n - n)%nat = 0%nat) by (intro; omega). rewrite H. + simpl. reflexivity. + + exploit IHl2; eauto. intros. clear IHl2. + assert (forall n n', (n > n')%nat -> (n - n')%nat = S (n - n' - 1)%nat) by (intros; omega). + exploit (is_tail_length (x::l1)); eauto. intro. simpl in H2. + assert ((length l2 > length l1)%nat) by omega. clear H2. + rewrite H0; auto. +Qed. + +Theorem hsistate_simu_core_correct dm f hst1 hst2 ctx: + hsistate_simu_core dm f hst1 hst2 -> + hsistate_simu dm f hst1 hst2 ctx. +Proof. + intros SIMUC st1 st2 HREF1 HREF2 DREF1 DREF2 is1 SEMI. + destruct HREF1 as (PCREF1 & EREF1). destruct HREF2 as (PCREF2 & EREF2). + destruct DREF1 as (DEREF1 & LREF1). destruct DREF2 as (DEREF2 & LREF2). + destruct SIMUC as (PCSIMU & ESIMU & LSIMU). + exploit hsiexits_simu_core_correct; eauto. intro HESIMU. + unfold ssem_internal in SEMI. destruct (icontinue _) eqn:ICONT. + - destruct SEMI as (SSEML & PCEQ & ALLFU). + exploit hsilocal_simu_core_correct; eauto; [apply ctx|]. intro SSEML2. + exists (mk_istate (icontinue is1) (si_pc st2) (irs is1) (imem is1)). constructor. + + unfold ssem_internal. simpl. rewrite ICONT. constructor; [assumption | constructor; [reflexivity |]]. + eapply siexits_simu_all_fallthrough; eauto. eapply hsiexits_simu_siexits; eauto. + + unfold istate_simu. rewrite ICONT. constructor; [simpl; assumption | constructor; [| reflexivity]]. + constructor. + - destruct SEMI as (ext & lx & SSEME & ALLFU). + assert (SESIMU: siexits_simu dm f (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). + exploit siexits_simu_all_fallthrough_upto; eauto. intros (ext2 & lx2 & ALLFU2 & LENEQ). + assert (EXTSIMU: siexit_simu dm f ctx ext ext2). { + eapply list_forall2_nth_error; eauto. + - destruct ALLFU as (ITAIL & _). eapply is_tail_nth_error; eauto. + - destruct ALLFU2 as (ITAIL & _). eapply is_tail_nth_error in ITAIL. + assert (LENEQ': length (si_exits st1) = length (si_exits st2)) by (eapply list_forall2_length; eauto). + congruence. } + destruct EXTSIMU as (CONDEVAL & EXTSIMU). + apply EXTSIMU in SSEME. clear EXTSIMU. destruct SSEME as (is2 & SSEME2 & ISIMU). + exists (mk_istate (icontinue is1) (ipc is2) (irs is2) (imem is2)). constructor. + + unfold ssem_internal. simpl. rewrite ICONT. exists ext2, lx2. constructor; assumption. + + unfold istate_simu in *. rewrite ICONT in *. destruct ISIMU as (path & PATHEQ & ISIMULIVE & DMEQ). + destruct ISIMULIVE as (CONTEQ & REGEQ & MEMEQ). + exists path. repeat (constructor; auto). +Qed. + +(* Definition hfinal_refines hfv fv := forall pge ge sp npc stk f rs0 m0 rs' m' t s', + ssem_final pge ge sp npc stk f rs0 m0 hfv rs' m' t s' <-> ssem_final pge ge sp npc stk f rs0 m0 fv rs' m' t s'. *) + +(* FIXME - might be too strong, let's change it later.. *) +Definition hfinal_refines (hfv fv: sfval) := hfv = fv. + +Remark hfinal_refines_snone: hfinal_refines Snone Snone. +Proof. + reflexivity. +Qed. + +Definition hfinal_simu_core (dm: PTree.t node) (f: RTLpath.function) (hf1 hf2: sfval): Prop := + match hf1 with + | Scall sig1 svos1 lsv1 res1 pc1 => + match hf2 with + | Scall sig2 svos2 lsv2 res2 pc2 => + dm ! pc2 = Some pc1 /\ sig1 = sig2 /\ svos1 = svos2 /\ lsv1 = lsv2 /\ res1 = res2 + | _ => False + end + | Sbuiltin ef1 lbs1 br1 pc1 => + match hf2 with + | Sbuiltin ef2 lbs2 br2 pc2 => + dm ! pc2 = Some pc1 /\ ef1 = ef2 /\ lbs1 = lbs2 /\ br1 = br2 + | _ => False + end + | Sjumptable sv1 lpc1 => + match hf2 with + | Sjumptable sv2 lpc2 => + ptree_get_list dm lpc2 = Some lpc1 /\ sv1 = sv2 + | _ => False + end + (* Snone, Stailcall, Sreturn *) + | _ => hf1 = hf2 + end. + +Lemma svident_simu_refl f ctx s: + svident_simu f ctx s s. +Proof. + destruct s; constructor; [| reflexivity]. + erewrite <- seval_preserved; [| eapply ctx]. constructor. +Qed. + +Theorem hfinal_simu_core_correct dm f ctx opc1 opc2 hf1 hf2 f1 f2: + hfinal_simu_core dm f hf1 hf2 -> + hfinal_refines hf1 f1 -> + hfinal_refines hf2 f2 -> + dm ! opc2 = Some opc1 -> + sfval_simu dm f opc1 opc2 ctx f1 f2. +Proof. + intros CORE FREF1 FREF2 OPCEQ. + rewrite <- FREF1. rewrite <- FREF2. clear FREF1. clear FREF2. (* FIXME - to change when the refinement is more complex *) + destruct hf1. + (* Snone *) + - simpl in CORE. rewrite <- CORE. constructor. assumption. + (* Scall *) + - simpl in CORE. destruct hf2; try contradiction. destruct CORE as (PCEQ & ? & ? & ? & ?). subst. + constructor; [assumption | apply svident_simu_refl|]. + erewrite <- list_sval_eval_preserved; [| eapply ctx]. constructor. + (* Stailcall *) + - simpl in CORE. rewrite <- CORE. constructor; [apply svident_simu_refl|]. + erewrite <- list_sval_eval_preserved; [| eapply ctx]. constructor. + (* Sbuiltin *) + - simpl in CORE. destruct hf2; try contradiction. destruct CORE as (PCEQ & ? & ? & ?). subst. + constructor; [assumption | reflexivity]. + (* Sjumptable *) + - simpl in CORE. destruct hf2; try contradiction. destruct CORE as (PCEQ & ?). subst. + constructor; [assumption|]. + erewrite <- seval_preserved; [| eapply ctx]. constructor. + (* Sreturn *) + - simpl in CORE. subst. constructor. +Qed. + +Record hsstate := { hinternal:> hsistate; hfinal: sfval }. + +Definition hsstate_refines (hst: hsstate) (st:sstate): Prop := + hsistate_refines_stat (hinternal hst) (internal st) + /\ (forall ge sp rs0 m0, hsistate_refines_dyn ge sp rs0 m0 (hinternal hst) (internal st)) + /\ hfinal_refines (hfinal hst) (final st). + +Definition hsstate_simu_core (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := + hsistate_simu_core dm f (hinternal hst1) (hinternal hst2) + /\ hfinal_simu_core dm f (hfinal hst1) (hfinal hst2). + +Definition hsstate_simu dm f (hst1 hst2: hsstate) ctx: Prop := + forall st1 st2, + hsstate_refines hst1 st1 -> + hsstate_refines hst2 st2 -> sstate_simu dm f st1 st2 ctx. + +Theorem hsstate_simu_core_correct dm f ctx hst1 hst2: + hsstate_simu_core dm f hst1 hst2 -> + hsstate_simu dm f hst1 hst2 ctx. +Proof. + intros (SCORE & FSIMU). intros st1 st2 HREF1 HREF2. + destruct HREF1 as (SREF1 & DREF1 & FREF1). destruct HREF2 as (SREF2 & DREF2 & FREF2). + assert (PCEQ: dm ! (hsi_pc hst2) = Some (hsi_pc hst1)) by apply SCORE. + eapply hsistate_simu_core_correct in SCORE. + eapply hfinal_simu_core_correct in FSIMU; eauto. + constructor; [apply SCORE; auto|]. + destruct SREF1 as (PC1 & _). destruct SREF2 as (PC2 & _). rewrite <- PC1. rewrite <- PC2. + eapply FSIMU. +Qed. + +(** * Verificators of *_simu_core properties *) + +(* WARNING: ce code va bouger pas mal quand on aura le hash-consing ! *) +Fixpoint sval_simub (sv1 sv2: sval) := + match sv1 with + | Sinput r => + match sv2 with + | Sinput r' => if (Pos.eq_dec r r') then OK tt else Error (msg "sval_simub: Sinput different registers") + | _ => Error (msg "sval_simub: Sinput expected") + end + | Sop op lsv sm => + match sv2 with + | Sop op' lsv' sm' => + if (eq_operation op op') then + do _ <- list_sval_simub lsv lsv'; + smem_simub sm sm' + else Error (msg "sval_simub: different operations in Sop") + | _ => Error (msg "sval_simub: Sop expected") + end + | Sload sm trap chk addr lsv => + match sv2 with + | Sload sm' trap' chk' addr' lsv' => + if (trapping_mode_eq trap trap') then + if (chunk_eq chk chk') then + if (eq_addressing addr addr') then + do _ <- smem_simub sm sm'; + list_sval_simub lsv lsv' + else Error (msg "sval_simub: addressings do not match") + else Error (msg "sval_simub: chunks do not match") + else Error (msg "sval_simub: trapping modes do not match") + (* FIXME - should be refined once we introduce non trapping loads *) + | _ => Error (msg "sval_simub: Sload expected") + end + end +with list_sval_simub (lsv1 lsv2: list_sval) := + match lsv1 with + | Snil => + match lsv2 with + | Snil => OK tt + | _ => Error (msg "list_sval_simub: lists of different lengths (lsv2 is bigger)") + end + | Scons sv1 lsv1 => + match lsv2 with + | Snil => Error (msg "list_sval_simub: lists of different lengths (lsv1 is bigger)") + | Scons sv2 lsv2 => + do _ <- sval_simub sv1 sv2; + list_sval_simub lsv1 lsv2 + end + end +with smem_simub (sm1 sm2: smem) := + match sm1 with + | Sinit => + match sm2 with + | Sinit => OK tt + | _ => Error (msg "smem_simub: Sinit expected") + end + | Sstore sm chk addr lsv sv => + match sm2 with + | Sstore sm' chk' addr' lsv' sv' => + if (chunk_eq chk chk') then + if (eq_addressing addr addr') then + do _ <- smem_simub sm sm'; + do _ <- list_sval_simub lsv lsv'; + sval_simub sv sv' + else Error (msg "smem_simub: addressings do not match") + else Error (msg "smem_simub: chunks not match") + | _ => Error (msg "smem_simub: Sstore expected") + end + end. + +Lemma sval_simub_correct sv1: forall sv2, + sval_simub sv1 sv2 = OK tt -> sv1 = sv2. +Proof. + induction sv1 using sval_mut with + (P0 := fun lsv1 => forall lsv2, list_sval_simub lsv1 lsv2 = OK tt -> lsv1 = lsv2) + (P1 := fun sm1 => forall sm2, smem_simub sm1 sm2 = OK tt -> sm1 = sm2); simpl; auto. + (* Sinput *) + - destruct sv2; try discriminate. + destruct (Pos.eq_dec r r0); [congruence|discriminate]. + (* Sop *) + - destruct sv2; try discriminate. + destruct (eq_operation _ _); [|discriminate]. subst. + intro. explore. apply IHsv1 in EQ. apply IHsv0 in EQ0. congruence. + (* Sload *) + - destruct sv2; try discriminate. + destruct (trapping_mode_eq _ _); [|discriminate]. + destruct (chunk_eq _ _); [|discriminate]. + destruct (eq_addressing _ _); [|discriminate]. + intro. explore. assert (sm = sm0) by auto. assert (lsv = lsv0) by auto. + congruence. + (* Snil *) + - destruct lsv2; [|discriminate]. congruence. + (* Scons *) + - destruct lsv2; [discriminate|]. intro. explore. + apply IHsv1 in EQ. apply IHsv0 in EQ0. congruence. + (* Sinit *) + - destruct sm2; [|discriminate]. congruence. + (* Sstore *) + - destruct sm2; [discriminate|]. + destruct (chunk_eq _ _); [|discriminate]. + destruct (eq_addressing _ _); [|discriminate]. + intro. explore. + assert (sm = sm2) by auto. assert (lsv = lsv0) by auto. assert (sv1 = srce) by auto. + congruence. +Qed. + +Lemma list_sval_simub_correct lsv1: forall lsv2, + list_sval_simub lsv1 lsv2 = OK tt -> lsv1 = lsv2. +Proof. + induction lsv1; simpl; auto. + - destruct lsv2; try discriminate. reflexivity. + - destruct lsv2; try discriminate. intro. explore. + apply sval_simub_correct in EQ. assert (lsv1 = lsv2) by auto. + congruence. +Qed. + +Lemma smem_simub_correct sm1: forall sm2, + smem_simub sm1 sm2 = OK tt -> sm1 = sm2. +Proof. + induction sm1; simpl; auto. + - destruct sm2; try discriminate. reflexivity. + - destruct sm2; try discriminate. + destruct (chunk_eq _ _); [|discriminate]. + destruct (eq_addressing _ _); [|discriminate]. intro. explore. + apply sval_simub_correct in EQ2. apply list_sval_simub_correct in EQ1. + apply IHsm1 in EQ. congruence. +Qed. + +Definition is_structural {A: Type} (cmp: A -> A -> bool) := + forall x y, cmp x y = true -> x = y. + +Fixpoint is_part_of {A: Type} (cmp: A -> A -> bool) (elt: A) (lv: list A): bool := + match lv with + | nil => false + | v::lv => if (cmp elt v) then true else is_part_of cmp elt lv + end. + +Lemma is_part_of_correct {A: Type} cmp lv (e: A): + is_structural cmp -> + is_part_of cmp e lv = true -> + In e lv. +Proof. + induction lv. + - intros. simpl in H0. discriminate. + - intros. simpl in H0. destruct (cmp e a) eqn:CMP. + + apply H in CMP. subst. constructor; auto. + + right. apply IHlv; assumption. +Qed. + +(* Checks if lv2 is a subset of lv1 *) +Fixpoint is_subsetb {A: Type} (cmp: A -> A -> bool) (lv2 lv1: list A): bool := + match lv2 with + | nil => true + | v2 :: lv2 => if (is_part_of cmp v2 lv1) then is_subsetb cmp lv2 lv1 + else false + end. + +Lemma is_subset_cons {A: Type} (x: A) lv lx: + In x lv /\ is_subset lx lv -> is_subset (x::lx) lv. +Proof. + intros (ISIN & ISSUB). unfold is_subset. + intros. inv H. + - assumption. + - apply ISSUB. assumption. +Qed. + +Lemma is_subset_correct {A: Type} cmp (lv2 lv1: list A): + is_structural cmp -> + is_subsetb cmp lv2 lv1 = true -> + is_subset lv2 lv1. +Proof. + induction lv2. + - simpl. intros. intro. intro. apply in_nil in H1. contradiction. + - intros. simpl in H0. apply is_subset_cons. + explore. apply is_part_of_correct in EQ; [|assumption]. + apply IHlv2 in H0; [|assumption]. constructor; assumption. +Qed. + +Definition simub_bool {A: Type} (simub: A -> A -> res unit) (sv1 sv2: A) := + match simub sv1 sv2 with + | OK tt => true + | _ => false + end. + +Lemma simub_bool_correct {A: Type} simub (sv1 sv2: A): + (forall x y, simub x y = OK tt -> x = y) -> + simub_bool simub sv1 sv2 = true -> sv1 = sv2. +Proof. + intros. unfold simub_bool in H0. destruct (simub sv1 sv2) eqn:SIMU; explore. + - apply H. assumption. + - discriminate. +Qed. + +Definition hsilocal_simu_coreb hst1 hst2 := + if (is_subsetb (simub_bool smem_simub) (hsi_lsmem hst2) (hsi_lsmem hst1)) then + if (is_subsetb (simub_bool sval_simub) (hsi_ok_lsval hst2) (hsi_ok_lsval hst1)) then + (* TODO - compare on the whole ptree *) OK tt + else Error (msg "hsi_ok_lsval sets aren't included") + else Error (msg "hsi_lsmem sets aren't included"). + +Theorem hsilocal_simu_coreb_correct hst1 hst2: + hsilocal_simu_coreb hst1 hst2 = OK tt -> + hsilocal_simu_core hst1 hst2. +Proof. +Admitted. + +(* Definition hsiexit_simub (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit) := + if (eq_condition (hsi_cond hse1) (hsi_cond hse2)) then + do _ <- list_sval_simub (hsi_scondargs hse1) (hsi_scondargs hse2); + do _ <- hsilocal_simub dm f (hsi_elocal hse1) (hsi_elocal hse2); + revmap_check_single dm (hsi_ifso hse1) (hsi_ifso hse2) + else Error (msg "siexit_simub: conditions do not match") +. *) + +(* Fixpoint hsiexits_simub (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := + match lhse1 with + | nil => + match lhse2 with + | nil => OK tt + | _ => Error (msg "siexists_simub: sle1 and sle2 lengths do not match") + end + | hse1 :: lhse1 => + match lhse2 with + | nil => Error (msg "siexits_simub: sle1 and sle2 lengths do not match") + | hse2 :: lhse2 => + do _ <- hsiexit_simub dm f hse1 hse2; + do _ <- hsiexits_simub dm f lhse1 lhse2; + OK tt + end + end. *) + +(* Lemma hsiexits_simub_correct dm f ctx lhse1: forall lhse2, + hsiexits_simub dm f lhse1 lhse2 = OK tt -> + hsiexits_simu dm f ctx lhse1 lhse2. +Proof. +(* induction lhse1. + - simpl. intros. destruct lhse2; try discriminate. intros se1 se2 HEREFS1 HEREFS2 _ _. + inv HEREFS1. inv HEREFS2. constructor. + - (* simpl. *) unfold hsiexits_simub. intros. destruct lhse2; try discriminate. explore. + fold hsiexits_simub in EQ1. + eapply hsiexit_simub_correct in EQ. apply IHlhse1 in EQ1. + intros se1 se2 HEREFS1 HEREFS2 HEREFD1 HEREFD2. inv HEREFS1. inv HEREFS2. inv HEREFD1. inv HEREFD2. constructor; auto. + apply EQ1; assumption. *) +Admitted. + *) + +(* TODO *) +Definition hsiexits_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := OK tt. + +Theorem hsiexits_simu_coreb_correct dm f lhse1 lhse2: + hsiexits_simu_coreb dm f lhse1 lhse2 = OK tt -> + hsiexits_simu_core dm f lhse1 lhse2. +Proof. +Admitted. + +Definition hsistate_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate) := OK tt. (* TODO *) + +Theorem hsistate_simu_coreb_correct dm f hse1 hse2: + hsistate_simu_coreb dm f hse1 hse2 = OK tt -> + hsistate_simu_core dm f hse1 hse2. +Proof. +Admitted. + +Definition hsstate_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := OK tt. (* TODO *) + +Theorem hsstate_simu_coreb_correct dm f hst1 hst2: + hsstate_simu_coreb dm f hst1 hst2 = OK tt -> + hsstate_simu_core dm f hst1 hst2. +Proof. +Admitted. + +Definition hfinal_simu_coreb (dm: PTree.t node) (f: RTLpath.function) (hf1 hf2: sfval) := OK tt. (* TODO *) + +Theorem hfinal_simu_coreb_correct dm f hf1 hf2: + hfinal_simu_coreb dm f hf1 hf2 = OK tt -> + hfinal_simu_core dm f hf1 hf2. +Proof. +Admitted. + +Lemma hsistate_refines_stat_pceq st hst: + hsistate_refines_stat hst st -> + (hsi_pc hst) = (si_pc st). +Proof. + unfold hsistate_refines_stat; intuition. +Qed. + +Lemma hsistate_refines_dyn_local_refines ge sp rs0 m0 hst st: + hsistate_refines_dyn ge sp rs0 m0 hst st -> + hsilocal_refines ge sp rs0 m0 (hsi_local hst) (si_local st). +Proof. + unfold hsistate_refines_dyn; intuition. +Qed. + + + +Local Hint Resolve hsistate_refines_dyn_local_refines: core. + + + +(** * Symbolic execution of one internal step + TODO: to refine symbolic values/symbolic memories with hash-consed symbolic values +*) + +(** ** Assignment of memory *) +Definition hslocal_set_smem (hst:hsistate_local) (sm:smem) := + {| hsi_lsmem := sm::hsi_lsmem hst; + hsi_ok_lsval := hsi_ok_lsval hst; + hsi_sreg:= hsi_sreg hst + |}. + +Lemma sok_local_set_mem ge sp rs0 m0 st sm: + sok_local ge sp rs0 m0 (slocal_set_smem st sm) + <-> (sok_local ge sp rs0 m0 st /\ seval_smem ge sp sm rs0 m0 <> None). +Proof. + unfold slocal_set_smem, sok_local; simpl; intuition (subst; eauto). +Qed. + +Lemma hsok_local_set_mem ge sp rs0 m0 hst sm: + hsok_local ge sp rs0 m0 (hslocal_set_smem hst sm) + <-> (hsok_local ge sp rs0 m0 hst /\ seval_smem ge sp sm rs0 m0 <> None). +Proof. + unfold hslocal_set_smem, hsok_local; simpl; intuition (subst; eauto). +Qed. + +Lemma hslocal_set_mem_correct ge sp rs0 m0 hst st hsm sm: + hsilocal_refines ge sp rs0 m0 hst st -> + (hsok_local ge sp rs0 m0 hst -> seval_smem ge sp hsm rs0 m0 = seval_smem ge sp sm rs0 m0) -> + hsilocal_refines ge sp rs0 m0 (hslocal_set_smem hst hsm) (slocal_set_smem st sm). +Proof. + intros LOCREF. intros SMEMEQ. + destruct LOCREF as (OKEQ & SMEMEQ' & REGEQ). constructor; [| constructor ]. + - rewrite hsok_local_set_mem. + rewrite sok_local_set_mem. + constructor. + + intros (OKL & SMEMN). constructor. 2: rewrite SMEMEQ; auto. + all: rewrite <- OKEQ; assumption. + + intros (HOKL & HSMEM). rewrite OKEQ. constructor; auto. + rewrite <- SMEMEQ; auto. + - rewrite! hsok_local_set_mem. intros (HOKL & HSMEM). + simpl. apply SMEMEQ; assumption. + - rewrite hsok_local_set_mem. intros (HOKL & HSMEM). + simpl. intuition congruence. +Qed. + +(** ** Assignment of local state *) + +Definition hsist_set_local (hst: hsistate) (pc: node) (hnxt: hsistate_local): hsistate := + {| hsi_pc := pc; hsi_exits := hst.(hsi_exits); hsi_local:= hnxt |}. + +Lemma hsist_set_local_correct_stat hst st pc hnxt nxt: + hsistate_refines_stat hst st -> + hsistate_refines_stat (hsist_set_local hst pc hnxt) (sist_set_local st pc nxt). +Proof. + unfold hsistate_refines_stat; simpl; intuition. +Qed. + +Lemma hsist_set_local_correct_dyn ge sp rs0 m0 hst st pc hnxt nxt: + hsistate_refines_dyn ge sp rs0 m0 hst st -> + hsilocal_refines ge sp rs0 m0 hnxt nxt -> + hsistate_refines_dyn ge sp rs0 m0 (hsist_set_local hst pc hnxt) (sist_set_local st pc nxt). +Proof. + unfold hsistate_refines_dyn; simpl; intuition. +Qed. + +(** ** Assignment of registers *) + +(* locally new symbolic values during symbolic execution *) +Inductive root_sval: Type := +| Rop (op:operation) +| Rload (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) +. + +Definition root_apply (rsv: root_sval) (lsv: list sval) (sm: smem): sval := + match rsv with + | Rop op => Sop op (list_sval_inj lsv) sm + | Rload trap chunk addr => Sload sm trap chunk addr (list_sval_inj lsv) + end. +Coercion root_apply: root_sval >-> Funclass. + +Local Open Scope lazy_bool_scope. + +(* NB: return [false] if the rsv cannot fail *) +Definition may_trap (rsv: root_sval) (lsv: list sval) (sm: smem): bool := + match rsv with + | Rop op => is_trapping_op op ||| negb (Nat.eqb (length lsv) (args_of_operation op)) (* cf. lemma is_trapping_op_sound *) + | Rload TRAP _ _ => true + | _ => false + end. + +Lemma lazy_orb_negb_false (b1 b2:bool): + (b1 ||| negb b2) = false <-> (b1 = false /\ b2 = true). +Proof. + unfold negb; explore; simpl; intuition (try congruence). +Qed. + +(* not used yet *) +Lemma may_trap_correct (ge: RTL.genv) (sp:val) (rsv: root_sval) (rs0: regset) (m0: mem) (lsv: list sval) (sm: smem): + may_trap rsv lsv sm = false -> + seval_list_sval ge sp (list_sval_inj lsv) rs0 m0 <> None -> + seval_smem ge sp sm rs0 m0 <> None -> + seval_sval ge sp (rsv lsv sm) rs0 m0 <> None. +Proof. + destruct rsv; simpl; try congruence. + - rewrite lazy_orb_negb_false. intros (TRAP1 & TRAP2) OK1 OK2. + explore; try congruence. + eapply is_trapping_op_sound; eauto. + admit. (* TODO *) + - intros X OK1 OK2. + explore; try congruence. +Admitted. + +(* simplify a symbolic value before assignment to a register *) +Definition simplify (rsv: root_sval) lsv sm: sval := + match rsv with + | Rload TRAP chunk addr => Sload sm NOTRAP chunk addr (list_sval_inj lsv) + | Rop op => + match is_move_operation op lsv with + | Some arg => arg (* optimization of Omove *) + | None => + if op_depends_on_memory op then + rsv lsv sm + else + Sop op (list_sval_inj lsv) Sinit (* magically remove the dependency on sm ! *) + end + | _ => rsv lsv sm + end. + +Lemma simplify_correct (rsv: root_sval) lsv sm (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) v: + seval_sval ge sp (rsv lsv sm) rs0 m0 = Some v -> + seval_sval ge sp (simplify rsv lsv sm) rs0 m0 = Some v. +Proof. + destruct rsv; simpl; auto. + - (* Rop *) + destruct (seval_list_sval _ _ _ _) as [args|] eqn: Hargs; try congruence. + destruct (seval_smem _ _ _ _) as [m|] eqn: Hm; try congruence. + intros Hv. + destruct (is_move_operation _ _) eqn: Hmove. + + exploit is_move_operation_correct; eauto. + intros (Hop & Hlsv); subst; simpl in *. + explore. auto. + + clear Hmove; destruct (op_depends_on_memory op) eqn: Hop; simpl; explore; try congruence. + inversion Hargs; subst. + erewrite op_depends_on_memory_correct; eauto. + - (* Rload *) + destruct trap; simpl; auto. + destruct (seval_list_sval _ _ _ _) as [args|] eqn: Hargs; try congruence. + destruct (eval_addressing _ _ _ _) as [a|] eqn: Ha; try congruence. + destruct (seval_smem _ _ _ _) as [m|] eqn: Hm; try congruence. + intros H; rewrite H; auto. +Qed. + +Definition red_PTree_set (r:reg) (sv: sval) (hst: PTree.t sval): PTree.t sval := + match sv with + | Sinput r' => + if Pos.eq_dec r r' + then PTree.remove r' hst + else PTree.set r sv hst + | _ => PTree.set r sv hst + end. + +Lemma red_PTree_set_correct (r:reg) (sv: sval) (hst: PTree.t sval) ge sp rs0 m0: + hsi_sreg_eval ge sp (red_PTree_set r sv hst) r rs0 m0 = hsi_sreg_eval ge sp (PTree.set r sv hst) r rs0 m0. +Proof. + destruct sv; simpl; auto. + destruct (Pos.eq_dec r r0); auto. + subst; unfold hsi_sreg_eval. + rewrite PTree.grs, PTree.gss; simpl; auto. +Qed. + +(* naive version: +@Cyril: éventuellement, tu peux utiliser la version naive dans un premier temps pour simplifier les preuves... + +Definition naive_hslocal_set_sreg (hst:hsistate_local) (r:reg) (rsv:root_sval) lsv sm := + let sv := rsv lsv sm in + {| hsi_lsmem := hsi_lsmem hst; + hsi_ok_lsval := sv::(hsi_ok_lsval hst); + hsi_sreg:= PTree.set r sv (hsi_sreg hst) |}. +*) + +Definition hslocal_set_sreg (hst:hsistate_local) (r:reg) (rsv:root_sval) lsv sm := + {| hsi_lsmem := hsi_lsmem hst; + hsi_ok_lsval := if may_trap rsv lsv sm then (rsv lsv sm)::(hsi_ok_lsval hst) else hsi_ok_lsval hst; + hsi_sreg := red_PTree_set r (simplify rsv lsv sm) (hsi_sreg hst) |}. + +Definition ok_args ge sp rs0 m0 hst lsv sm := + hsok_local ge sp rs0 m0 hst -> + (seval_list_sval ge sp (list_sval_inj lsv) rs0 m0 <> None /\ seval_smem ge sp sm rs0 m0 <> None). + +Lemma hslocal_set_sreg_correct ge sp rs0 m0 hst st r (rsv:root_sval) lsv sm sv': + hsilocal_refines ge sp rs0 m0 hst st -> + (forall ge sp rs0 m0, + ok_args ge sp rs0 m0 hst lsv sm -> + (hsok_local ge sp rs0 m0 hst -> seval_sval ge sp sv' rs0 m0 = seval_sval ge sp (rsv lsv sm) rs0 m0) ) -> + hsilocal_refines ge sp rs0 m0 (hslocal_set_sreg hst r rsv lsv sm) (slocal_set_sreg st r sv'). +Admitted. + +(** ** Execution of one instruction *) + +Definition hsiexec_inst (i: instruction) (hst: hsistate): option hsistate := + match i with + | Inop pc' => + Some (hsist_set_local hst pc' hst.(hsi_local)) + | Iop op args dst pc' => + let prev := hst.(hsi_local) in + let vargs := List.map (hsi_sreg_get prev) args in + let next := hslocal_set_sreg prev dst (Rop op) vargs (hsi_smem_get prev) in + Some (hsist_set_local hst pc' next) + | Iload trap chunk addr args dst pc' => + let prev := hst.(hsi_local) in + let vargs := List.map (hsi_sreg_get prev) args in + let next := hslocal_set_sreg prev dst (Rload trap chunk addr) vargs (hsi_smem_get prev) in + Some (hsist_set_local hst pc' next) + | Istore chunk addr args src pc' => + let prev := hst.(hsi_local) in + let vargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in + let next := hslocal_set_smem prev (Sstore (hsi_smem_get prev) chunk addr vargs (hsi_sreg_get prev src)) in + Some (hsist_set_local hst pc' next) + | Icond cond args ifso ifnot _ => + let prev := hst.(hsi_local) in + let vargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in + let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in + Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |} + | _ => None (* TODO jumptable ? *) + end. + +Local Hint Resolve hsist_set_local_correct_stat + hsist_set_local_correct_dyn hslocal_set_mem_correct: core. + +Lemma seval_sval_refines ge sp rs0 m0 hst st p: + hsok_local ge sp rs0 m0 hst -> + hsilocal_refines ge sp rs0 m0 hst st -> + seval_sval ge sp (hsi_sreg_get hst p) rs0 m0 = seval_sval ge sp (si_sreg st p) rs0 m0. +Proof. + intros OKL HREF. destruct HREF as (_ & _ & RSEQ). + rewrite <- hsi_sreg_eval_correct; eauto. +Qed. + +Lemma seval_list_sval_refines ge sp rs0 m0 hst st l: + hsok_local ge sp rs0 m0 hst -> + hsilocal_refines ge sp rs0 m0 hst st -> + seval_list_sval ge sp (list_sval_inj (map (hsi_sreg_get hst) l)) rs0 m0 = + seval_list_sval ge sp (list_sval_inj (map (si_sreg st) l)) rs0 m0. +Proof. + intros OKL HLREF. destruct HLREF as (_ & _ & RSEQ). + induction l; simpl; auto. + erewrite <- RSEQ; auto. + rewrite IHl. + rewrite <- hsi_sreg_eval_correct. + reflexivity. +Qed. + +Lemma seval_smem_refines ge sp rs0 m0 hst st : + hsok_local ge sp rs0 m0 hst -> + hsilocal_refines ge sp rs0 m0 hst st -> + seval_smem ge sp (hsi_smem_get hst) rs0 m0 = seval_smem ge sp (si_smem st) rs0 m0. +Proof. + intros OKL HLREF. destruct HLREF as (_ & MSEQ & _). + rewrite <- hsi_smem_eval_correct. + auto. +Qed. + +Lemma seval_condition_refines hst st ge sp cond args rs m: + hsok_local ge sp rs m hst -> + hsilocal_refines ge sp rs m hst st -> + seval_condition ge sp cond args (hsi_smem_get hst) rs m + = seval_condition ge sp cond args (si_smem st) rs m. + Proof. + intros HOK (OKEQ & MEMEQ & RSEQ). unfold seval_condition. + rewrite <- MEMEQ; auto. rewrite hsi_smem_eval_correct. reflexivity. +Qed. + +Lemma hsiexec_inst_correct_None i hst st: + hsiexec_inst i hst = None -> siexec_inst i st = None. +Proof. + destruct i; simpl; congruence. +Qed. + + +Lemma hsiexec_inst_correct_stat i hst hst' st: + hsiexec_inst i hst = Some hst' -> + exists st', siexec_inst i st = Some st' + /\ (hsistate_refines_stat hst st -> hsistate_refines_stat hst' st'). +Proof. + destruct i; simpl; intros STEPI; inversion_clear STEPI; discriminate || eexists; split; eauto. + (* TODO *) +Admitted. + +Lemma hsiexec_inst_correct_dyn ge sp rs0 m0 i hst st hst' st': + hsiexec_inst i hst = Some hst' -> + siexec_inst i st = Some st' -> + hsistate_refines_dyn ge sp rs0 m0 hst st -> hsistate_refines_dyn ge sp rs0 m0 hst' st'. +Proof. + destruct i; simpl; intros STEP1 STEP2; inversion_clear STEP1; + inversion_clear STEP2; discriminate || (intro REF; eauto). + - (* Iop *) + eapply hsist_set_local_correct_dyn; eauto. + eapply hslocal_set_sreg_correct; eauto. + + simpl. admit. (* TODO *) + - (* Iload *) + eapply hsist_set_local_correct_dyn; eauto. + eapply hslocal_set_sreg_correct; eauto. + + simpl. admit. (* TODO *) + - (* Istore *) + eapply hsist_set_local_correct_dyn; eauto. + eapply hslocal_set_mem_correct; eauto. + intros. simpl. + erewrite seval_list_sval_refines; eauto. + erewrite seval_smem_refines; eauto. + erewrite seval_sval_refines; eauto. + - (* Icond *) + admit. (* TODO *) +Admitted. + + +Fixpoint hsiexec_path (path:nat) (f: function) (hst: hsistate): option hsistate := + match path with + | O => Some hst + | S p => + SOME i <- (fn_code f)!(hst.(hsi_pc)) IN + SOME hst1 <- hsiexec_inst i hst IN + hsiexec_path p f hst1 + end. + +Lemma hsiexec_path_correct_stat ps f hst hst' st: + hsiexec_path ps f hst = Some hst' -> + hsistate_refines_stat hst st -> + exists st', siexec_path ps f st = Some st' /\ hsistate_refines_stat hst' st'. +Proof. +Admitted. + +Lemma hsiexec_path_correct_dyn ge sp rs0 m0 ps f hst hst' st st': + hsiexec_path ps f hst = Some hst' -> + siexec_path ps f st = Some st' -> + hsistate_refines_stat hst st -> + hsistate_refines_stat hst' st' -> + hsistate_refines_dyn ge sp rs0 m0 hst st + -> hsistate_refines_dyn ge sp rs0 m0 hst' st'. +Proof. +Admitted. + + +Definition hsexec_final (i: instruction) (prev: hsistate_local): sfval := + match i with + | Icall sig ros args res pc => + let svos := sum_left_map (hsi_sreg_get prev) ros in + let sargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in + Scall sig svos sargs res pc + | Itailcall sig ros args => + let svos := sum_left_map (hsi_sreg_get prev) ros in + let sargs := list_sval_inj (List.map (hsi_sreg_get prev) args) in + Stailcall sig svos sargs + | Ibuiltin ef args res pc => + let sargs := List.map (builtin_arg_map (hsi_sreg_get prev)) args in + Sbuiltin ef sargs res pc + | Ireturn or => + let sor := SOME r <- or IN Some (hsi_sreg_get prev r) in + Sreturn sor + | Ijumptable reg tbl => + let sv := hsi_sreg_get prev reg in + Sjumptable sv tbl + | _ => Snone + end. + +(* Lemma local_refines_sreg_get hsl sl ge sp rs0 m0: + hsistate_local_refines hsl sl -> + sok_local ge sp sl rs0 m0 -> + hsi_sreg_get hsl = si_sreg sl. +Proof. + intros HREF SOKL. apply functional_extensionality. intro r. + destruct (HREF ge sp rs0 m0) as (OKEQ & MEMEQ & RSEQ). + apply OKEQ in SOKL. pose (RSEQ SOKL r) as EQ. + unfold hsi_sreg_get. +Admitted. *) + +Lemma sfind_function_conserves hsl sl pge ge sp s rs0 m0: + hsilocal_refines ge sp rs0 m0 hsl sl -> + sfind_function pge ge sp (sum_left_map (hsi_sreg_get hsl) s) rs0 m0 = + sfind_function pge ge sp (sum_left_map (si_sreg sl) s) rs0 m0. +Admitted. + +Lemma hsexec_final_correct hsl sl i: + (forall ge sp rs0 m0, hsilocal_refines ge sp rs0 m0 hsl sl) -> + hsexec_final i hsl = sexec_final i sl. +Proof. +(* destruct i; simpl; intros HLREF; try (apply hfinal_refines_snone). + (* Scall *) + - constructor. + + intro. inv H. constructor; auto. + ++ erewrite <- sfind_function_conserves; eauto. + ++ erewrite <- seval_list_sval_refines; eauto. + + intro. inv H. constructor; auto. + ++ erewrite sfind_function_conserves; eauto. + ++ erewrite seval_list_sval_refines; eauto. + (* Stailcall *) + - admit. + (* Sbuiltin *) + - admit. + (* Sjumptable *) + - admit. + (* Sreturn *) + - admit. *) +Admitted. + + +Definition init_hsistate_local := {| hsi_lsmem := Sinit::nil; + hsi_ok_lsval := nil; hsi_sreg := PTree.empty sval |}. + +Remark init_hsistate_local_correct ge sp rs0 m0: + hsilocal_refines ge sp rs0 m0 init_hsistate_local init_sistate_local. +Proof. + constructor; constructor; simpl. + - intro. destruct H as (_ & SMEM & SVAL). constructor; [contradiction|]. + intros. destruct H; [|contradiction]. subst. discriminate. + - intro. destruct H as (SVAL & SMEM). constructor; [simpl; auto|]. + constructor; simpl; discriminate. + - intros; simpl; reflexivity. + - intros. simpl. unfold hsi_sreg_eval. rewrite PTree.gempty. reflexivity. +Qed. + +Definition init_hsistate pc := {| hsi_pc := pc; hsi_exits := nil; hsi_local := init_hsistate_local |}. + +Remark init_hsistate_correct_stat pc: + hsistate_refines_stat (init_hsistate pc) (init_sistate pc). +Proof. + constructor; constructor; simpl; auto. +Qed. + +Remark init_hsistate_correct_dyn ge sp rs0 m0 pc: + hsistate_refines_dyn ge sp rs0 m0 (init_hsistate pc) (init_sistate pc). +Proof. + constructor; simpl; auto. + - apply list_forall2_nil. + - apply init_hsistate_local_correct. +Qed. + +Definition hsexec (f: function) (pc:node): option hsstate := + SOME path <- (fn_path f)!pc IN + SOME hst <- hsiexec_path path.(psize) f (init_hsistate pc) IN + SOME i <- (fn_code f)!(hst.(hsi_pc)) IN + Some (match hsiexec_inst i hst with + | Some hst' => {| hinternal := hst'; hfinal := Snone |} + | None => {| hinternal := hst; hfinal := hsexec_final i hst.(hsi_local) |} + end). + +Local Hint Resolve init_hsistate_correct_stat init_hsistate_correct_dyn hsexec_final_correct + hsiexec_inst_correct_dyn hsiexec_path_correct_dyn hfinal_refines_snone: core. + +Lemma hsexec_correct f pc hst: + hsexec f pc = Some hst -> + exists st, sexec f pc = Some st /\ hsstate_refines hst st. +Proof. + unfold hsexec. intro. explore_hyp. + unfold sexec. + rewrite EQ. + exploit hsiexec_path_correct_stat; eauto. + intros (st0 & SPATH & REF0). + generalize REF0; intros (PC0 & XREF0). rewrite SPATH. + erewrite <- PC0. rewrite EQ1. + destruct (hsiexec_inst i h) eqn:HINST. + + exploit hsiexec_inst_correct_stat; eauto. + intros (st1 & EQ2 & PC2 & REF2). + - split; eauto. + - rewrite EQ2. + repeat (econstructor; simpl; eauto). + + erewrite hsiexec_inst_correct_None; eauto. + repeat (econstructor; simpl; eauto). + unfold hfinal_refines. simpl; eauto. +Qed. + +(** * The simulation test of concrete symbolic execution *) + +Definition revmap_check_single (dm: PTree.t node) (n tn: node) : res unit := + match dm ! tn with + | None => Error (msg "revmap_check_single: no mapping for tn") + | Some res => if (Pos.eq_dec n res) then OK tt + else Error (msg "revmap_check_single: n and res do not match") + end. + +Lemma revmap_check_single_correct dm n tn: + revmap_check_single dm n tn = OK tt -> + dm ! tn = Some n. +Proof. + unfold revmap_check_single. explore; try discriminate. congruence. +Qed. + + +Local Hint Resolve genv_match ssem_local_refines_hok: core. + +Fixpoint revmap_check_list (dm: PTree.t node) (ln ln': list node): res unit := + match ln with + | nil => + match ln' with + | nil => OK tt + | _ => Error (msg "revmap_check_list: lists have different lengths") + end + | n::ln => + match ln' with + | nil => Error (msg "revmap_check_list: lists have different lengths") + | n'::ln' => do _ <- revmap_check_single dm n n'; revmap_check_list dm ln ln' + end + end. + +Lemma revmap_check_list_correct dm ln: forall ln', + revmap_check_list dm ln ln' = OK tt -> + ptree_get_list dm ln' = Some ln. +Proof. + induction ln. + - simpl. intros. destruct ln'; try discriminate. constructor; auto. + - simpl. intros; destruct ln'; try discriminate. explore. + apply IHln in EQ0. apply revmap_check_single_correct in EQ. + simpl. rewrite EQ. rewrite EQ0. reflexivity. +Qed. + +Definition svos_simub (svos1 svos2: sval + ident) := + match svos1 with + | inl sv1 => + match svos2 with + | inl sv2 => sval_simub sv1 sv2 + | _ => Error (msg "svos_simub: expected sval") + end + | inr id1 => + match svos2 with + | inr id2 => + if (ident_eq id1 id2) then OK tt + else Error (msg "svos_simub: ids do not match") + | _ => Error (msg "svos_simub: expected id") + end + end. + +Lemma svos_simub_correct svos1 svos2: + svos_simub svos1 svos2 = OK tt -> + svos1 = svos2. +Proof. + destruct svos1. + - simpl. destruct svos2; [|discriminate]. + intro. exploit sval_simub_correct; eauto. congruence. + - simpl. destruct svos2; [discriminate|]. + intro. explore. reflexivity. +Qed. + +Fixpoint builtin_arg_simub (bs bs': builtin_arg sval) := + match bs with + | BA sv => + match bs' with + | BA sv' => sval_simub sv sv' + | _ => Error (msg "builtin_arg_simub: BA expected") + end + | BA_int n => + match bs' with + | BA_int n' => if (Integers.int_eq n n') then OK tt else Error (msg "builtin_arg_simub: integers do not match") + | _ => Error (msg "buitin_arg_simub: BA_int expected") + end + | BA_long n => + match bs' with + | BA_long n' => if (int64_eq n n') then OK tt else Error (msg "builtin_arg_simub: integers do not match") + | _ => Error (msg "buitin_arg_simub: BA_long expected") + end + | BA_float f => + match bs' with + | BA_float f' => if (float_eq f f') then OK tt else Error (msg "builtin_arg_simub: floats do not match") + | _ => Error (msg "builtin_arg_simub: BA_float expected") + end + | BA_single f => + match bs' with + | BA_single f' => if (float32_eq f f') then OK tt else Error (msg "builtin_arg_simub: floats do not match") + | _ => Error (msg "builtin_arg_simub: BA_single expected") + end + | BA_loadstack chk ptr => + match bs' with + | BA_loadstack chk' ptr' => + if (chunk_eq chk chk') then + if (ptrofs_eq ptr ptr') then OK tt + else Error (msg "builtin_arg_simub: ptr do not match") + else Error (msg "builtin_arg_simub: chunks do not match") + | _ => Error (msg "builtin_arg_simub: BA_loadstack expected") + end + | BA_addrstack ptr => + match bs' with + | BA_addrstack ptr' => if (ptrofs_eq ptr ptr') then OK tt else Error (msg "builtin_arg_simub: ptr do not match") + | _ => Error (msg "builtin_arg_simub: BA_addrstack expected") + end + | BA_loadglobal chk id ofs => + match bs' with + | BA_loadglobal chk' id' ofs' => + if (chunk_eq chk chk') then + if (ident_eq id id') then + if (ptrofs_eq ofs ofs') then OK tt + else Error (msg "builtin_arg_simub: offsets do not match") + else Error (msg "builtin_arg_simub: identifiers do not match") + else Error (msg "builtin_arg_simub: chunks do not match") + | _ => Error (msg "builtin_arg_simub: BA_loadglobal expected") + end + | BA_addrglobal id ofs => + match bs' with + | BA_addrglobal id' ofs' => + if (ident_eq id id') then + if (ptrofs_eq ofs ofs') then OK tt + else Error (msg "builtin_arg_simub: offsets do not match") + else Error (msg "builtin_arg_simub: identifiers do not match") + | _ => Error (msg "builtin_arg_simub: BA_addrglobal expected") + end + | BA_splitlong lo hi => + match bs' with + | BA_splitlong lo' hi' => do _ <- builtin_arg_simub lo lo'; builtin_arg_simub hi hi' + | _ => Error (msg "builtin_arg_simub: BA_splitlong expected") + end + | BA_addptr b1 b2 => + match bs' with + | BA_addptr b1' b2' => do _ <- builtin_arg_simub b1 b1'; builtin_arg_simub b2 b2' + | _ => Error (msg "builtin_arg_simub: BA_addptr expected") + end + end. + +Lemma builtin_arg_simub_correct b1: forall b2, + builtin_arg_simub b1 b2 = OK tt -> b1 = b2. +Proof. + induction b1; simpl; destruct b2; try discriminate; auto; intros; try (explore; congruence). + - apply sval_simub_correct in H. congruence. + - explore. assert (b1_1 = b2_1) by auto. assert (b1_2 = b2_2) by auto. congruence. + - explore. assert (b1_1 = b2_1) by auto. assert (b1_2 = b2_2) by auto. congruence. +Qed. + +Fixpoint list_builtin_arg_simub lbs1 lbs2 := + match lbs1 with + | nil => + match lbs2 with + | nil => OK tt + | _ => Error (msg "list_builtin_arg_simub: lists of different lengths (lbs2 is bigger)") + end + | bs1::lbs1 => + match lbs2 with + | nil => Error (msg "list_builtin_arg_simub: lists of different lengths (lbs1 is bigger)") + | bs2::lbs2 => + do _ <- builtin_arg_simub bs1 bs2; + list_builtin_arg_simub lbs1 lbs2 + end + end. + +Lemma list_builtin_arg_simub_correct lsb1: forall lsb2, + list_builtin_arg_simub lsb1 lsb2 = OK tt -> lsb1 = lsb2. +Proof. + induction lsb1; intros; simpl; destruct lsb2; try discriminate; auto. + simpl in H. explore. apply builtin_arg_simub_correct in EQ. + assert (lsb1 = lsb2) by auto. congruence. +Qed. + +(* WARNING: ce code va bouger pas mal quand on aura le hash-consing ! *) +Definition sfval_simub (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (fv1 fv2: sfval) := + match fv1 with + | Snone => + match fv2 with + | Snone => revmap_check_single dm pc1 pc2 + | _ => Error (msg "sfval_simub: Snone expected") + end + | Scall sig svos lsv res pc1 => + match fv2 with + | Scall sig2 svos2 lsv2 res2 pc2 => + do _ <- revmap_check_single dm pc1 pc2; + if (signature_eq sig sig2) then + if (Pos.eq_dec res res2) then + do _ <- svos_simub svos svos2; + list_sval_simub lsv lsv2 + else Error (msg "sfval_simub: Scall res do not match") + else Error (msg "sfval_simub: Scall different signatures") + | _ => Error (msg "sfval_simub: Scall expected") + end + | Stailcall sig svos lsv => + match fv2 with + | Stailcall sig' svos' lsv' => + if (signature_eq sig sig') then + do _ <- svos_simub svos svos'; + list_sval_simub lsv lsv' + else Error (msg "sfval_simub: signatures do not match") + | _ => Error (msg "sfval_simub: Stailcall expected") + end + | Sbuiltin ef lbs br pc => + match fv2 with + | Sbuiltin ef' lbs' br' pc' => + if (external_function_eq ef ef') then + if (builtin_res_eq_pos br br') then + do _ <- revmap_check_single dm pc pc'; + list_builtin_arg_simub lbs lbs' + else Error (msg "sfval_simub: builtin res do not match") + else Error (msg "sfval_simub: external functions do not match") + | _ => Error (msg "sfval_simub: Sbuiltin expected") + end + | Sjumptable sv ln => + match fv2 with + | Sjumptable sv' ln' => + do _ <- revmap_check_list dm ln ln'; sval_simub sv sv' + | _ => Error (msg "sfval_simub: Sjumptable expected") + end + | Sreturn osv => + match fv2 with + | Sreturn osv' => + match osv with + | Some sv => + match osv' with + | Some sv' => sval_simub sv sv' + | None => Error (msg "sfval_simub sv' expected") + end + | None => + match osv' with + | Some sv' => Error (msg "None expected") + | None => OK tt + end + end + | _ => Error (msg "sfval_simub: Sreturn expected") + end + end. + +Lemma sfval_simub_correct dm f pc1 pc2 fv1 fv2 ctx: + sfval_simub dm f pc1 pc2 fv1 fv2 = OK tt -> + sfval_simu dm f pc1 pc2 ctx fv1 fv2. +Proof. + unfold sfval_simub. destruct fv1. + (* Snone *) + - destruct fv2; try discriminate. intro. + apply revmap_check_single_correct in H. constructor; auto. + (* Scall *) + - destruct fv2; try discriminate. intro. explore. + apply svos_simub_correct in EQ3. apply list_sval_simub_correct in EQ4. + subst. apply revmap_check_single_correct in EQ. constructor; auto. + + admit. + + admit. + (* Stailcall *) + - destruct fv2; try discriminate. intro. explore. + apply svos_simub_correct in EQ0. apply list_sval_simub_correct in EQ1. + subst. constructor; auto. + + admit. + + admit. + (* Sbuiltin *) + - destruct fv2; try discriminate. intro. explore. + apply revmap_check_single_correct in EQ1. apply list_builtin_arg_simub_correct in EQ2. + subst. constructor; auto. + (* Sjumptable *) + - destruct fv2; try discriminate. intro. explore. + apply revmap_check_list_correct in EQ. apply sval_simub_correct in EQ0. subst. + constructor; auto. + admit. + (* Sreturn *) + - destruct fv2; try discriminate. destruct o; destruct o0; try discriminate. + + intro. apply sval_simub_correct in H. subst. constructor; auto. + + constructor; auto. +Admitted. + +Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node) := + let (pc2, pc1) := m in + match (hsexec f pc1) with + | None => Error (msg "simu_check_single: hsexec f pc1 failed") + | Some hst1 => + match (hsexec tf pc2) with + | None => Error (msg "simu_check_single: hsexec tf pc2 failed") + | Some hst2 => hsstate_simu_coreb dm f hst1 hst2 + end + end. + +Lemma simu_check_single_correct dm tf f pc1 pc2: + simu_check_single dm f tf (pc2, pc1) = OK tt -> + sexec_simu dm f tf pc1 pc2. +Proof. + unfold simu_check_single. intro. + unfold sexec_simu. + intros st1 SEXEC. + explore. + exploit hsexec_correct; eauto. + intros (st2 & SEXEC2 & REF2). + clear EQ0. (* now, useless in principle and harmful for the next [exploit] *) + exploit hsexec_correct; eauto. + intros (st0 & SEXEC1 & REF1). + rewrite SEXEC1 in SEXEC; inversion SEXEC; subst. + eexists; split; eauto. + intros ctx. eapply hsstate_simu_coreb_correct in H. + eapply hsstate_simu_core_correct; eauto. +Qed. + +Fixpoint simu_check_rec (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) lm := + match lm with + | nil => OK tt + | m :: lm => do u1 <- simu_check_single dm f tf m; + do u2 <- simu_check_rec dm f tf lm; + OK tt + end. + +Lemma simu_check_rec_correct dm f tf pc1 pc2: forall lm, + simu_check_rec dm f tf lm = OK tt -> + In (pc2, pc1) lm -> + sexec_simu dm f tf pc1 pc2. +Proof. + induction lm. + - simpl. intuition. + - simpl. intros. explore. destruct H0. + + subst. eapply simu_check_single_correct; eauto. + + eapply IHlm; assumption. +Qed. + +Definition simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) := + simu_check_rec dm f tf (PTree.elements dm). + +Lemma simu_check_correct dm f tf: + simu_check dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + sexec_simu dm f tf pc1 pc2. +Proof. + unfold simu_check. intros. eapply PTree.elements_correct in H0. + eapply simu_check_rec_correct; eassumption. +Qed. \ No newline at end of file diff --git a/scheduling/RTLpathSE_impl_junk.v b/scheduling/RTLpathSE_impl_junk.v new file mode 100644 index 00000000..1b4efad7 --- /dev/null +++ b/scheduling/RTLpathSE_impl_junk.v @@ -0,0 +1,736 @@ +(** Implementation and refinement of the symbolic execution + +* a JUNK VERSION WITHOUT ANY FORMAL PROOF !!! + + *) + +Require Import Coqlib Maps Floats. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL RTLpath. +Require Import Errors Duplicate. +Require Import RTLpathSE_theory. +Require Import Axioms. + +Local Open Scope error_monad_scope. +Local Open Scope option_monad_scope. + +Require Export Impure.ImpHCons. +Export Notations. +Import HConsing. + +Local Open Scope impure. + +Import ListNotations. +Local Open Scope list_scope. + +(** * Implementation of Data-structure use in Hash-consing *) + +(** ** Implementation of symbolic values/symbolic memories with hash-consing data *) + +Inductive hsval := + | HSinput (r: reg) (hid:hashcode) + | HSop (op:operation) (hlsv: hlist_sval) (hsm: hsmem) (hid:hashcode) + | HSload (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval) (hid:hashcode) +with hlist_sval := + | HSnil (hid:hashcode) + | HScons (hsv: hsval) (hlsv: hlist_sval) (hid:hashcode) +(* symbolic memory *) +with hsmem := + | HSinit (hid:hashcode) + | HSstore (hsm: hsmem) (chunk:memory_chunk) (addr:addressing) (hlsv:hlist_sval) (srce: hsval) (hid:hashcode). + +Scheme hsval_mut := Induction for hsval Sort Prop +with hlist_sval_mut := Induction for hlist_sval Sort Prop +with hsmem_mut := Induction for hsmem Sort Prop. + +Definition hsval_get_hid (hsv: hsval): hashcode := + match hsv with + | HSinput _ hid => hid + | HSop _ _ _ hid => hid + | HSload _ _ _ _ _ hid => hid + end. + +Definition hlist_sval_get_hid (hlsv: hlist_sval): hashcode := + match hlsv with + | HSnil hid => hid + | HScons _ _ hid => hid + end. + +Definition hsmem_get_hid (hsm: hsmem ): hashcode := + match hsm with + | HSinit hid => hid + | HSstore _ _ _ _ _ hid => hid + end. + +Definition hsval_set_hid (hsv: hsval) (hid: hashcode): hsval := + match hsv with + | HSinput r _ => HSinput r hid + | HSop o hlsv hsm _ => HSop o hlsv hsm hid + | HSload hsm trap chunk addr hlsv _ => HSload hsm trap chunk addr hlsv hid + end. + +Definition hlist_sval_set_hid (hlsv: hlist_sval) (hid: hashcode): hlist_sval := + match hlsv with + | HSnil _ => HSnil hid + | HScons hsv hlsv _ => HScons hsv hlsv hid + end. + +Definition hsmem_set_hid (hsm: hsmem ) (hid: hashcode): hsmem := + match hsm with + | HSinit _ => HSinit hid + | HSstore hsm chunk addr hlsv srce _ => HSstore hsm chunk addr hlsv srce hid + end. + +(* Now, we build the hash-Cons value from a "hash_eq". + +Informal specification: + [hash_eq] must be consistent with the "hashed" constructors defined above. + +We expect that hashinfo values in the code of these "hashed" constructors verify: + + (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) +*) + +Definition hsval_hash_eq (sv1 sv2: hsval): ?? bool := + match sv1, sv2 with + | HSinput r1 _, HSinput r2 _ => struct_eq r1 r2 (* NB: really need a struct_eq here ? *) + | HSop op1 lsv1 sm1 _, HSop op2 lsv2 sm2 _ => + DO b1 <~ phys_eq lsv1 lsv2;; + DO b2 <~ phys_eq sm1 sm2;; + if b1 && b2 + then struct_eq op1 op2 (* NB: really need a struct_eq here ? *) + else RET false + | HSload sm1 trap1 chk1 addr1 lsv1 _, HSload sm2 trap2 chk2 addr2 lsv2 _ => + DO b1 <~ phys_eq lsv1 lsv2;; + DO b2 <~ phys_eq sm1 sm2;; + DO b3 <~ struct_eq trap1 trap2;; + DO b4 <~ struct_eq chk1 chk2;; + if b1 && b2 && b3 && b4 + then struct_eq addr1 addr2 + else RET false + | _,_ => RET false + end. + +Definition hlist_sval_hash_eq (lsv1 lsv2: hlist_sval): ?? bool := + match lsv1, lsv2 with + | HSnil _, HSnil _ => RET true + | HScons sv1 lsv1' _, HScons sv2 lsv2' _ => + DO b <~ phys_eq lsv1' lsv2';; + if b + then phys_eq sv1 sv2 + else RET false + | _,_ => RET false + end. + +Definition hsmem_hash_eq (sm1 sm2: hsmem): ?? bool := + match sm1, sm2 with + | HSinit _, HSinit _ => RET true + | HSstore sm1 chk1 addr1 lsv1 sv1 _, HSstore sm2 chk2 addr2 lsv2 sv2 _ => + DO b1 <~ phys_eq lsv1 lsv2;; + DO b2 <~ phys_eq sm1 sm2;; + DO b3 <~ phys_eq sv1 sv2;; + DO b4 <~ struct_eq chk1 chk2;; + if b1 && b2 && b3 && b4 + then struct_eq addr1 addr2 + else RET false + | _,_ => RET false + end. + +Definition hSVAL: hashP hsval := {| hash_eq := hsval_hash_eq; get_hid:=hsval_get_hid; set_hid:=hsval_set_hid |}. +Definition hLSVAL: hashP hlist_sval := {| hash_eq := hlist_sval_hash_eq; get_hid:= hlist_sval_get_hid; set_hid:= hlist_sval_set_hid |}. +Definition hSMEM: hashP hsmem := {| hash_eq := hsmem_hash_eq; get_hid:= hsmem_get_hid; set_hid:= hsmem_set_hid |}. + +Program Definition mk_hash_params: Dict.hash_params hsval := + {| + Dict.test_eq := phys_eq; + Dict.hashing := fun (ht: hsval) => RET (hsval_get_hid ht); + Dict.log := fun _ => RET () (* NB no log *) |}. +Obligation 1. + wlp_simplify. +Qed. + + +(* Symbolic final value -- from hash-consed values +It does not seem useful to hash-consed these final values (because they are final). +*) +Inductive hsfval := + | HSnone + | HScall (sig:signature) (svos: hsval + ident) (lsv:hlist_sval) (res:reg) (pc:node) + | HStailcall (sig:signature) (svos: hsval + ident) (lsv:hlist_sval) + | HSbuiltin (ef:external_function) (sargs: list (builtin_arg hsval)) (res: builtin_res reg) (pc:node) + | HSjumptable (sv: hsval) (tbl: list node) + | HSreturn (res:option hsval) +. + +(** ** Implementation of symbolic states +*) + +(** name : Hash-consed Symbolic Internal state local. *) +Record hsistate_local := + { + (** [hsi_smem] represents the current smem symbolic evaluations. + (we can recover the previous one from smem) *) + hsi_smem:> hsmem; + (** For the values in registers: + 1) we store a list of sval evaluations + 2) we encode the symbolic regset by a PTree *) + hsi_ok_lsval: list hsval; + hsi_sreg:> PTree.t hsval + }. + +(* Syntax and semantics of symbolic exit states *) +Record hsistate_exit := mk_hsistate_exit + { hsi_cond: condition; hsi_scondargs: hlist_sval; hsi_elocal: hsistate_local; hsi_ifso: node }. + + +(** ** Syntax and Semantics of symbolic internal state *) +Record hsistate := { hsi_pc: node; hsi_exits: list hsistate_exit; hsi_local: hsistate_local }. + +(** ** Syntax and Semantics of symbolic state *) +Record hsstate := { hinternal:> hsistate; hfinal: hsfval }. + + +(** * Implementation of symbolic execution *) +Section CanonBuilding. + +Variable hC_hsval: hashinfo hsval -> ?? hsval. +(*Hypothesis hC_hsval_correct: TODO *) + +Variable hC_hlist_sval: hashinfo hlist_sval -> ?? hlist_sval. +(*Hypothesis hC_hlist_sval_correct: TODO *) + +Variable hC_hsmem: hashinfo hsmem -> ?? hsmem. +(*Hypothesis hC_hsval_correct: TODO *) + +(* First, we wrap constructors for hashed values !*) + +Definition hSinput_hcodes (r: reg) := + DO hc <~ hash 1;; + DO hv <~ hash r;; + RET [hc;hv]. +Extraction Inline hSinput_hcodes. + +Definition hSinput (r:reg): ?? hsval := + DO hv <~ hSinput_hcodes r;; + hC_hsval {| hdata:=HSinput r unknown_hid; hcodes :=hv; |}. + + +Definition hSop_hcodes (op:operation) (hlsv: hlist_sval) (hsm: hsmem) := + DO hc <~ hash 2;; + DO hv <~ hash op;; + RET [hc;hv;hlist_sval_get_hid hlsv; hsmem_get_hid hsm]. +Extraction Inline hSop_hcodes. + +Definition hSop (op:operation) (hlsv: hlist_sval) (hsm: hsmem): ?? hsval := + DO hv <~ hSop_hcodes op hlsv hsm;; + hC_hsval {| hdata:=HSop op hlsv hsm unknown_hid; hcodes :=hv |}. + + +Definition hSload_hcodes (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval):= + DO hc <~ hash 3;; + DO hv1 <~ hash trap;; + DO hv2 <~ hash chunk;; + DO hv3 <~ hash addr;; + RET [hc;hsmem_get_hid hsm;hv1;hv2;hv3;hlist_sval_get_hid hlsv]. +Extraction Inline hSload_hcodes. + +Definition hSload (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval): ?? hsval := + DO hv <~ hSload_hcodes hsm trap chunk addr hlsv;; + hC_hsval {| hdata:=HSload hsm trap chunk addr hlsv unknown_hid; hcodes :=hv |}. + + +Definition hSnil (_: unit): ?? hlist_sval := + hC_hlist_sval {| hdata:=HSnil unknown_hid; hcodes := nil |}. + +Definition hScons (hsv: hsval) (hlsv: hlist_sval): ?? hlist_sval := + hC_hlist_sval {| hdata:=HScons hsv hlsv unknown_hid; hcodes := [hsval_get_hid hsv; hlist_sval_get_hid hlsv] |}. + +Definition hSinit (_: unit): ?? hsmem := + hC_hsmem {| hdata:=HSinit unknown_hid; hcodes := nil |}. + +Definition hSstore_hcodes (hsm: hsmem) (chunk: memory_chunk) (addr:addressing) (hlsv:hlist_sval) (srce: hsval):= + DO hv1 <~ hash chunk;; + DO hv2 <~ hash addr;; + RET [hsmem_get_hid hsm;hv1;hv2;hlist_sval_get_hid hlsv;hsval_get_hid srce]. +Extraction Inline hSstore_hcodes. + +Definition hSstore (hsm: hsmem) (chunk:memory_chunk) (addr:addressing) (hlsv:hlist_sval) (srce: hsval): ?? hsmem := + DO hv <~ hSstore_hcodes hsm chunk addr hlsv srce;; + hC_hsmem {| hdata:=HSstore hsm chunk addr hlsv srce unknown_hid; hcodes := hv |}. + + +Definition hsi_sreg_get (hst: PTree.t hsval) r: ?? hsval := + match PTree.get r hst with + | None => hSinput r + | Some sv => RET sv + end. + +Fixpoint hlist_args (hst: PTree.t hsval) (l: list reg): ?? hlist_sval := + match l with + | nil => hSnil() + | r::l => + DO v <~ hsi_sreg_get hst r;; + DO hlsv <~ hlist_args hst l;; + hScons v hlsv + end. + +(** ** Assignment of memory *) +Definition hslocal_store (hst:hsistate_local) chunk addr args src: ?? hsistate_local := + let pt := hst.(hsi_sreg) in + DO hargs <~ hlist_args pt args;; + DO hsrc <~ hsi_sreg_get pt src;; + DO hm <~ hSstore hst chunk addr hargs hsrc;; + RET {| hsi_smem := hm; + hsi_ok_lsval := hsi_ok_lsval hst; + hsi_sreg:= hsi_sreg hst + |}. + +(** ** Assignment of local state *) + +Definition hsist_set_local (hst: hsistate) (pc: node) (hnxt: hsistate_local): hsistate := + {| hsi_pc := pc; hsi_exits := hst.(hsi_exits); hsi_local:= hnxt |}. + +(** ** Assignment of registers *) + +(* locally new symbolic values during symbolic execution *) +Inductive root_sval: Type := +| Rop (op:operation) +| Rload (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) +. + +Definition root_apply (rsv: root_sval) (lsv: list reg) (hst: hsistate_local) : ?? hsval := + DO hlsv <~ hlist_args hst lsv;; + match rsv with + | Rop op => hSop op hlsv hst + | Rload trap chunk addr => hSload hst trap chunk addr hlsv + end. + +Local Open Scope lazy_bool_scope. + +(* NB: return [false] if the rsv cannot fail *) +Definition may_trap (rsv: root_sval) (lsv: list reg): bool := + match rsv with + | Rop op => is_trapping_op op ||| negb (Nat.eqb (length lsv) (args_of_operation op)) (* cf. lemma is_trapping_op_sound *) + | Rload TRAP _ _ => true + | _ => false + end. + +(* simplify a symbolic value before assignment to a register *) +Definition simplify (rsv: root_sval) (lsv: list reg) (hst: hsistate_local): ?? hsval := + match rsv with + | Rop op => + match is_move_operation op lsv with + | Some arg => hsi_sreg_get hst arg (* optimization of Omove *) + | None => + DO hsi <~ hSinit ();; + DO hlsv <~ hlist_args hst lsv;; + hSop op hlsv hsi (* magically remove the dependency on sm ! *) + end + | Rload _ chunk addr => + DO hlsv <~ hlist_args hst lsv;; + hSload hst NOTRAP chunk addr hlsv + end. + +Definition red_PTree_set (r:reg) (sv: hsval) (hst: PTree.t hsval): PTree.t hsval := + match sv with + | HSinput r' _ => + if Pos.eq_dec r r' + then PTree.remove r' hst + else PTree.set r sv hst + | _ => PTree.set r sv hst + end. + +Definition hslocal_set_sreg (hst:hsistate_local) (r:reg) (rsv:root_sval) lsv: ?? hsistate_local := + DO hsiok <~ + (if may_trap rsv lsv + then DO hv <~ root_apply rsv lsv hst;; RET (hv::(hsi_ok_lsval hst)) + else RET (hsi_ok_lsval hst));; + DO simp <~ simplify rsv lsv hst;; + RET {| hsi_smem := hst; + hsi_ok_lsval := hsiok; + hsi_sreg := red_PTree_set r simp (hsi_sreg hst) |}. + +(** ** Execution of one instruction *) + +Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) := + match i with + | Inop pc' => + RET (Some (hsist_set_local hst pc' hst.(hsi_local))) + | Iop op args dst pc' => + DO next <~ hslocal_set_sreg hst.(hsi_local) dst (Rop op) args;; + RET (Some (hsist_set_local hst pc' next)) + | Iload trap chunk addr args dst pc' => + DO next <~ hslocal_set_sreg hst.(hsi_local) dst (Rload trap chunk addr) args;; + RET (Some (hsist_set_local hst pc' next)) + | Istore chunk addr args src pc' => + DO next <~ hslocal_store hst.(hsi_local) chunk addr args src;; + RET (Some (hsist_set_local hst pc' next)) + | Icond cond args ifso ifnot _ => + let prev := hst.(hsi_local) in + DO vargs <~ hlist_args prev args ;; + let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in + RET (Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |}) + | _ => RET None (* TODO jumptable ? *) + end. + +Definition some_or_fail {A} (o: option A) (msg: pstring): ?? A := + match o with + | Some x => RET x + | None => FAILWITH msg + end. + +Fixpoint hsiexec_path (path:nat) (f: function) (hst: hsistate): ?? hsistate := + match path with + | O => RET hst + | S p => + DO i <~ some_or_fail ((fn_code f)!(hst.(hsi_pc))) "hsiexec_path.internal_error.1";; + DO ohst1 <~ hsiexec_inst i hst;; + DO hst1 <~ some_or_fail ohst1 "hsiexec_path.internal_error.2";; + hsiexec_path p f hst1 + end. + +Fixpoint hbuiltin_arg (hst: PTree.t hsval) (arg : builtin_arg reg): ?? builtin_arg hsval := + match arg with + | BA r => + DO v <~ hsi_sreg_get hst r;; + RET (BA v) + | BA_int n => RET (BA_int n) + | BA_long n => RET (BA_long n) + | BA_float f0 => RET (BA_float f0) + | BA_single s => RET (BA_single s) + | BA_loadstack chunk ptr => RET (BA_loadstack chunk ptr) + | BA_addrstack ptr => RET (BA_addrstack ptr) + | BA_loadglobal chunk id ptr => RET (BA_loadglobal chunk id ptr) + | BA_addrglobal id ptr => RET (BA_addrglobal id ptr) + | BA_splitlong ba1 ba2 => + DO v1 <~ hbuiltin_arg hst ba1;; + DO v2 <~ hbuiltin_arg hst ba2;; + RET (BA_splitlong v1 v2) + | BA_addptr ba1 ba2 => + DO v1 <~ hbuiltin_arg hst ba1;; + DO v2 <~ hbuiltin_arg hst ba2;; + RET (BA_addptr v1 v2) + end. + +Fixpoint hbuiltin_args (hst: PTree.t hsval) (args: list (builtin_arg reg)): ?? list (builtin_arg hsval) := + match args with + | nil => RET nil + | a::l => + DO ha <~ hbuiltin_arg hst a;; + DO hl <~ hbuiltin_args hst l;; + RET (ha::hl) + end. + +Definition hsum_left (hst: PTree.t hsval) (ros: reg + ident): ?? (hsval + ident) := + match ros with + | inl r => DO hr <~ hsi_sreg_get hst r;; RET (inl hr) + | inr s => RET (inr s) + end. + +Definition hsexec_final (i: instruction) (hst: PTree.t hsval): ?? hsfval := + match i with + | Icall sig ros args res pc => + DO svos <~ hsum_left hst ros;; + DO sargs <~ hlist_args hst args;; + RET (HScall sig svos sargs res pc) + | Itailcall sig ros args => + DO svos <~ hsum_left hst ros;; + DO sargs <~ hlist_args hst args;; + RET (HStailcall sig svos sargs) + | Ibuiltin ef args res pc => + DO sargs <~ hbuiltin_args hst args;; + RET (HSbuiltin ef sargs res pc) + | Ijumptable reg tbl => + DO sv <~ hsi_sreg_get hst reg;; + RET (HSjumptable sv tbl) + | Ireturn or => + match or with + | Some r => DO hr <~ hsi_sreg_get hst r;; RET (HSreturn (Some hr)) + | None => RET (HSreturn None) + end + | _ => RET (HSnone) + end. + +Definition init_hsistate_local (_:unit): ?? hsistate_local + := DO hm <~ hSinit ();; + RET {| hsi_smem := hm; hsi_ok_lsval := nil; hsi_sreg := PTree.empty hsval |}. + +Definition init_hsistate pc: ?? hsistate + := DO hst <~ init_hsistate_local ();; + RET {| hsi_pc := pc; hsi_exits := nil; hsi_local := hst |}. + +Definition hsexec (f: function) (pc:node): ?? hsstate := + DO path <~ some_or_fail ((fn_path f)!pc) "hsexec.internal_error.1";; + DO hinit <~ init_hsistate pc;; + DO hst <~ hsiexec_path path.(psize) f hinit;; + DO i <~ some_or_fail ((fn_code f)!(hst.(hsi_pc))) "hsexec.internal_error.2";; + DO ohst <~ hsiexec_inst i hst;; + match ohst with + | Some hst' => RET {| hinternal := hst'; hfinal := HSnone |} + | None => DO hsvf <~ hsexec_final i hst.(hsi_local);; + RET {| hinternal := hst; hfinal := hsvf |} + end. + +End CanonBuilding. + +(** * The simulation test of concrete hash-consed symbolic execution *) + +Definition phys_check {A} (x y:A) (msg: pstring): ?? unit := + DO b <~ phys_eq x y;; + assert_b b msg;; + RET tt. + +Definition struct_check {A} (x y:A) (msg: pstring): ?? unit := + DO b <~ struct_eq x y;; + assert_b b msg;; + RET tt. + +Definition option_eq_check {A} (o1 o2: option A): ?? unit := + match o1, o2 with + | Some x1, Some x2 => phys_check x1 x2 "option_eq_check: data physically differ" + | None, None => RET tt + | _, _ => FAILWITH "option_eq_check: structure differs" + end. + +Lemma option_eq_check_correct A (o1 o2: option A): WHEN option_eq_check o1 o2 ~> _ THEN o1=o2. +Proof. + wlp_simplify. +Qed. +Global Opaque option_eq_check. +Global Hint Resolve option_eq_check_correct:wlp. + +Import PTree. + +Fixpoint PTree_eq_check {A} (d1 d2: PTree.t A): ?? unit := + match d1, d2 with + | Leaf, Leaf => RET tt + | Node l1 o1 r1, Node l2 o2 r2 => + option_eq_check o1 o2;; + PTree_eq_check l1 l2;; + PTree_eq_check r1 r2 + | _, _ => FAILWITH "PTree_eq_check: some key is absent" + end. + +Lemma PTree_eq_check_correct A d1: forall (d2: t A), + WHEN PTree_eq_check d1 d2 ~> _ THEN forall x, PTree.get x d1 = PTree.get x d2. +Proof. + induction d1 as [|l1 Hl1 o1 r1 Hr1]; destruct d2 as [|l2 o2 r2]; simpl; + wlp_simplify. destruct x; simpl; auto. +Qed. +Global Opaque PTree_eq_check. + +Fixpoint PTree_frame_eq_check {A} (frame: list positive) (d1 d2: PTree.t A): ?? unit := + match frame with + | nil => RET tt + | k::l => + option_eq_check (PTree.get k d1) (PTree.get k d2);; + PTree_frame_eq_check l d1 d2 + end. + +Lemma PTree_frame_eq_check_correct A l (d1 d2: t A): + WHEN PTree_frame_eq_check l d1 d2 ~> _ THEN forall x, List.In x l -> PTree.get x d1 = PTree.get x d2. +Proof. + induction l as [|k l]; simpl; wlp_simplify. + subst; auto. +Qed. +Global Opaque PTree_frame_eq_check. + +Definition hsilocal_simu_check hst1 hst2 : ?? unit := + phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_simu_check: hsi_smem sets aren't equiv";; + Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; + PTree_eq_check (hsi_sreg hst1) (hsi_sreg hst2). + +Definition revmap_check_single (dm: PTree.t node) (n tn: node) : ?? unit := + DO res <~ some_or_fail (dm ! tn) "revmap_check_single: no mapping for tn";; + struct_check n res "revmap_check_single: n and res are physically different". + +Definition hsilocal_frame_simu_check frame hst1 hst2 : ?? unit := + phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_frame_simu_check: hsi_smem sets aren't equiv";; + Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; + PTree_frame_eq_check frame (hsi_sreg hst1) (hsi_sreg hst2). + +Definition hsiexit_simu_check (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit): ?? unit := + struct_check (hsi_cond hse1) (hsi_cond hse2) "hsiexit_simu_check: conditions do not match";; + phys_check (hsi_scondargs hse1) (hsi_scondargs hse2) "hsiexit_simu_check: args do not match";; + revmap_check_single dm (hsi_ifso hse1) (hsi_ifso hse2);; + DO path <~ some_or_fail ((fn_path f) ! (hsi_ifso hse1)) "hsiexit_simu_check: internal error";; + hsilocal_frame_simu_check (Regset.elements path.(input_regs)) (hsi_elocal hse1) (hsi_elocal hse2). + +Fixpoint hsiexits_simu_check (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := + match lhse1,lhse2 with + | nil, nil => RET tt + | hse1 :: lhse1, hse2 :: lhse2 => + hsiexit_simu_check dm f hse1 hse2;; + hsiexits_simu_check dm f lhse1 lhse2 + | _, _ => FAILWITH "siexists_simu_check: lengths do not match" + end. + +Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsistate) := + hsilocal_simu_check (hsi_local hst1) (hsi_local hst2);; + hsiexits_simu_check dm f (hsi_exits hst1) (hsi_exits hst2). + +Fixpoint revmap_check_list (dm: PTree.t node) (ln ln': list node): ?? unit := + match ln, ln' with + | nil, nil => RET tt + | n::ln, n'::ln' => + revmap_check_single dm n n';; + revmap_check_list dm ln ln' + | _, _ => FAILWITH "revmap_check_list: lists have different lengths" + end. + +Definition svos_simu_check (svos1 svos2: hsval + ident) := + match svos1, svos2 with + | inl sv1, inl sv2 => phys_check sv1 sv2 "svos_simu_check: sval mismatch" + | inr id1, inr id2 => phys_check id1 id2 "svos_simu_check: symbol mismatch" + | _, _ => FAILWITH "svos_simu_check: type mismatch" + end. + +Fixpoint builtin_arg_simu_check (bs bs': builtin_arg hsval) := + match bs, bs' with + | BA sv, BA sv' => phys_check sv sv' "builtin_arg_simu_check: sval mismatch" + | BA_splitlong lo hi, BA_splitlong lo' hi' => + builtin_arg_simu_check lo lo';; + builtin_arg_simu_check hi hi' + | BA_addptr b1 b2, BA_addptr b1' b2' => + builtin_arg_simu_check b1 b1';; + builtin_arg_simu_check b2 b2' + | _, _ => struct_check bs bs' "builtin_arg_simu_check: basic mismatch" + end. + +Fixpoint list_builtin_arg_simu_check lbs1 lbs2 := + match lbs1, lbs2 with + | nil, nil => RET tt + | bs1::lbs1, bs2::lbs2 => + builtin_arg_simu_check bs1 bs2;; + list_builtin_arg_simu_check lbs1 lbs2 + | _, _ => FAILWITH "list_builtin_arg_simu_check: length mismatch" + end. + +Definition sfval_simu_check (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (fv1 fv2: hsfval) := + match fv1, fv2 with + | HSnone, HSnone => revmap_check_single dm pc1 pc2 + | HScall sig1 svos1 lsv1 res1 pc1, HScall sig2 svos2 lsv2 res2 pc2 => + revmap_check_single dm pc1 pc2;; + phys_check sig1 sig2 "sfval_simu_check: Scall different signatures";; + phys_check res1 res2 "sfval_simu_check: Scall res do not match";; + svos_simu_check svos1 svos2;; + phys_check lsv1 lsv2 "sfval_simu_check: Scall args do not match" + | HStailcall sig1 svos1 lsv1, HStailcall sig2 svos2 lsv2 => + phys_check sig1 sig2 "sfval_simu_check: Stailcall different signatures";; + svos_simu_check svos1 svos2;; + phys_check lsv1 lsv2 "sfval_simu_check: Stailcall args do not match" + | HSbuiltin ef1 lbs1 br1 pc1, HSbuiltin ef2 lbs2 br2 pc2 => + revmap_check_single dm pc1 pc2;; + phys_check ef1 ef2 "sfval_simu_check: builtin ef do not match";; + phys_check br1 br2 "sfval_simu_check: builtin br do not match";; + list_builtin_arg_simu_check lbs1 lbs2 + | HSjumptable sv ln, HSjumptable sv' ln' => + revmap_check_list dm ln ln';; + phys_check sv sv' "sfval_simu_check: Sjumptable sval do not match" + | HSreturn osv1, HSreturn osv2 => + option_eq_check osv1 osv2 + | _, _ => FAILWITH "sfval_simu_check: structure mismatch" + end. + +Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := + hsistate_simu_check dm f (hinternal hst1) (hinternal hst2);; + sfval_simu_check dm f (hsi_pc hst1) (hsi_pc hst2) (hfinal hst1) (hfinal hst2). + +Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node): ?? unit := + let (pc2, pc1) := m in + (* creating the hash-consing tables *) + DO hC_sval <~ hCons hSVAL;; + DO hC_hlist_sval <~ hCons hLSVAL;; + DO hC_hsmem <~ hCons hSMEM;; + let hsexec := hsexec hC_sval.(hC) hC_hlist_sval.(hC) hC_hsmem.(hC) in + (* performing the hash-consed executions *) + DO hst1 <~ hsexec f pc1;; + DO hst2 <~ hsexec tf pc2;; + (* comparing the executions *) + hsstate_simu_check dm f hst1 hst2. + +Lemma simu_check_single_correct dm tf f pc1 pc2: + WHEN simu_check_single dm f tf (pc2, pc1) ~> _ THEN + sexec_simu dm f tf pc1 pc2. +Admitted. +Global Opaque simu_check_single. +Global Hint Resolve simu_check_single_correct: wlp. + +Fixpoint simu_check_rec (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) lm : ?? unit := + match lm with + | nil => RET tt + | m :: lm => + simu_check_single dm f tf m;; + simu_check_rec dm f tf lm + end. + +Lemma simu_check_rec_correct dm f tf lm: + WHEN simu_check_rec dm f tf lm ~> _ THEN + forall pc1 pc2, In (pc2, pc1) lm -> sexec_simu dm f tf pc1 pc2. +Proof. + induction lm; wlp_simplify. + match goal with + | X: (_,_) = (_,_) |- _ => inversion X; subst + end. + subst; eauto. +Qed. +Global Opaque simu_check_rec. +Global Hint Resolve simu_check_rec_correct: wlp. + +Definition imp_simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function): ?? unit := + simu_check_rec dm f tf (PTree.elements dm);; + println("simu_check OK!"). + +Local Hint Resolve PTree.elements_correct: core. +Lemma imp_simu_check_correct dm f tf: + WHEN imp_simu_check dm f tf ~> _ THEN + forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2. +Proof. + wlp_simplify. +Qed. +Global Opaque imp_simu_check. +Global Hint Resolve imp_simu_check_correct: wlp. + +Program Definition aux_simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function): ?? bool := + DO r <~ + (TRY + imp_simu_check dm f tf;; + RET true + CATCH_FAIL s, _ => + println ("simu_check_failure:" +; s);; + RET false + ENSURE (fun b => b=true -> forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2));; + RET (`r). +Obligation 1. + split; wlp_simplify. discriminate. +Qed. + +Lemma aux_simu_check_correct dm f tf: + WHEN aux_simu_check dm f tf ~> b THEN + b=true -> forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2. +Proof. + unfold aux_simu_check; wlp_simplify. + destruct exta; simpl; auto. +Qed. + +(* Coerce aux_simu_check into a pure function (this is a little unsafe like all oracles in CompCert). *) + +Import UnsafeImpure. + +Definition simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) : res unit := + match unsafe_coerce (aux_simu_check dm f tf) with + | Some true => OK tt + | _ => Error (msg "simu_check has failed") + end. + +Lemma simu_check_correct dm f tf: + simu_check dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + sexec_simu dm f tf pc1 pc2. +Proof. + unfold simu_check. + destruct (unsafe_coerce (aux_simu_check dm f tf)) as [[|]|] eqn:Hres; simpl; try discriminate. + intros; eapply aux_simu_check_correct; eauto. + eapply unsafe_coerce_not_really_correct; eauto. +Qed. \ No newline at end of file diff --git a/scheduling/RTLpathSE_theory.v b/scheduling/RTLpathSE_theory.v new file mode 100644 index 00000000..5002b7c5 --- /dev/null +++ b/scheduling/RTLpathSE_theory.v @@ -0,0 +1,1778 @@ +(* A theory of symbolic execution on RTLpath + +NB: an efficient implementation with hash-consing will be defined in RTLpathSE_impl.v + +*) + +Require Import Coqlib Maps Floats. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL RTLpath. +Require Import Errors Duplicate. + +Local Open Scope error_monad_scope. + +(* Enhanced from kvx/Asmblockgenproof.v *) +Ltac explore_hyp := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => (let EQ1 := fresh "EQ" in (destruct var eqn:EQ1; try discriminate)) + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + | [ H : Some _ = Some _ |- _ ] => inv H + | [ x : unit |- _ ] => destruct x + end. + +Ltac explore := explore_hyp; + repeat match goal with + | [ |- context[if ?b then _ else _] ] => (let EQ1 := fresh "IEQ" in destruct b eqn:EQ1) + | [ |- context[match ?m with | _ => _ end] ] => (let DEQ1 := fresh "DEQ" in destruct m eqn:DEQ1) + | [ |- context[match ?m as _ return _ with | _ => _ end]] => (let DREQ1 := fresh "DREQ" in destruct m eqn:DREQ1) + end. + +(* Ltac explore := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => (let EQ1 := fresh "EQ" in (destruct var eqn:EQ1; try discriminate)) + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => (let EQ1 := fresh "IEQ" in destruct b eqn:EQ1) + | [ |- context[match ?m with | _ => _ end] ] => (let DEQ1 := fresh "DEQ" in destruct m eqn:DEQ1) + | [ |- context[match ?m as _ return _ with | _ => _ end]] => (let DREQ1 := fresh "DREQ" in destruct m eqn:DREQ1) + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + | [ H : Some _ = Some _ |- _ ] => inv H + | [ x : unit |- _ ] => destruct x + end. *) + +(** * Syntax and semantics of symbolic values *) + +(* symbolic value *) +Inductive sval := + | Sinput (r: reg) + | Sop (op:operation) (lsv: list_sval) (sm: smem) + | Sload (sm: smem) (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) (lsv:list_sval) +with list_sval := + | Snil + | Scons (sv: sval) (lsv: list_sval) +(* symbolic memory *) +with smem := + | Sinit + | Sstore (sm: smem) (chunk:memory_chunk) (addr:addressing) (lsv:list_sval) (srce: sval). + +Scheme sval_mut := Induction for sval Sort Prop +with list_sval_mut := Induction for list_sval Sort Prop +with smem_mut := Induction for smem Sort Prop. + +Fixpoint list_sval_inj (l: list sval): list_sval := + match l with + | nil => Snil + | v::l => Scons v (list_sval_inj l) + end. + +Local Open Scope option_monad_scope. + +Fixpoint seval_sval (ge: RTL.genv) (sp:val) (sv: sval) (rs0: regset) (m0: mem): option val := + match sv with + | Sinput r => Some (rs0#r) + | Sop op l sm => + SOME args <- seval_list_sval ge sp l rs0 m0 IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + eval_operation ge sp op args m + | Sload sm trap chunk addr lsv => + match trap with + | TRAP => + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + SOME a <- eval_addressing ge sp addr args IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + Mem.loadv chunk m a + | NOTRAP => + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + match (eval_addressing ge sp addr args) with + | None => Some (default_notrap_load_value chunk) + | Some a => + SOME m <- seval_smem ge sp sm rs0 m0 IN + match (Mem.loadv chunk m a) with + | None => Some (default_notrap_load_value chunk) + | Some val => Some val + end + end + end + end +with seval_list_sval (ge: RTL.genv) (sp:val) (lsv: list_sval) (rs0: regset) (m0: mem): option (list val) := + match lsv with + | Snil => Some nil + | Scons sv lsv' => + SOME v <- seval_sval ge sp sv rs0 m0 IN + SOME lv <- seval_list_sval ge sp lsv' rs0 m0 IN + Some (v::lv) + end +with seval_smem (ge: RTL.genv) (sp:val) (sm: smem) (rs0: regset) (m0: mem): option mem := + match sm with + | Sinit => Some m0 + | Sstore sm chunk addr lsv srce => + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + SOME a <- eval_addressing ge sp addr args IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + SOME sv <- seval_sval ge sp srce rs0 m0 IN + Mem.storev chunk m a sv + end. + +(* Syntax and Semantics of local symbolic internal states *) +(* [si_pre] is a precondition on initial ge, sp, rs0, m0 *) +Record sistate_local := { si_pre: RTL.genv -> val -> regset -> mem -> Prop; si_sreg: reg -> sval; si_smem: smem }. + +(* Predicate on which (rs, m) is a possible final state after evaluating [st] on (rs0, m0) *) +Definition ssem_local (ge: RTL.genv) (sp:val) (st: sistate_local) (rs0: regset) (m0: mem) (rs: regset) (m: mem): Prop := + st.(si_pre) ge sp rs0 m0 + /\ seval_smem ge sp st.(si_smem) rs0 m0 = Some m + /\ forall (r:reg), seval_sval ge sp (st.(si_sreg) r) rs0 m0 = Some (rs#r). + +Definition sabort_local (ge: RTL.genv) (sp:val) (st: sistate_local) (rs0: regset) (m0: mem): Prop := + ~(st.(si_pre) ge sp rs0 m0) + \/ seval_smem ge sp st.(si_smem) rs0 m0 = None + \/ exists (r: reg), seval_sval ge sp (st.(si_sreg) r) rs0 m0 = None. + +(* Syntax and semantics of symbolic exit states *) +Record sistate_exit := mk_sistate_exit + { si_cond: condition; si_scondargs: list_sval; si_elocal: sistate_local; si_ifso: node }. + +Definition seval_condition ge sp (cond: condition) (lsv: list_sval) (sm: smem) rs0 m0 : option bool := + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + eval_condition cond args m. + +Definition all_fallthrough ge sp (lx: list sistate_exit) rs0 m0: Prop := + forall ext, List.In ext lx -> + seval_condition ge sp ext.(si_cond) ext.(si_scondargs) ext.(si_elocal).(si_smem) rs0 m0 = Some false. + +Lemma all_fallthrough_revcons ge sp ext rs m lx: + all_fallthrough ge sp (ext::lx) rs m -> + seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs m = Some false + /\ all_fallthrough ge sp lx rs m. +Proof. + intros ALLFU. constructor. + - assert (In ext (ext::lx)) by (constructor; auto). apply ALLFU in H. assumption. + - intros ext' INEXT. assert (In ext' (ext::lx)) by (apply in_cons; auto). + apply ALLFU in H. assumption. +Qed. + +(** Semantic of an exit in pseudo code: + if si_cond (si_condargs) + si_elocal; goto if_so + else () +*) + +Definition ssem_exit (ge: RTL.genv) (sp: val) (ext: sistate_exit) (rs: regset) (m: mem) rs' m' (pc': node) : Prop := + seval_condition ge sp (si_cond ext) (si_scondargs ext) ext.(si_elocal).(si_smem) rs m = Some true + /\ ssem_local ge sp (si_elocal ext) rs m rs' m' + /\ (si_ifso ext) = pc'. + +(* Either an abort on the condition evaluation OR an abort on the sistate_local IF the condition was true *) +Definition sabort_exit (ge: RTL.genv) (sp: val) (ext: sistate_exit) (rs: regset) (m: mem) : Prop := + let sev_cond := seval_condition ge sp (si_cond ext) (si_scondargs ext) ext.(si_elocal).(si_smem) rs m in + sev_cond = None + \/ (sev_cond = Some true /\ sabort_local ge sp ext.(si_elocal) rs m). + +(** * Syntax and Semantics of symbolic internal state *) +Record sistate := { si_pc: node; si_exits: list sistate_exit; si_local: sistate_local }. + +Definition all_fallthrough_upto_exit ge sp ext lx' lx rs m : Prop := + is_tail (ext::lx') lx /\ all_fallthrough ge sp lx' rs m. + +(** Semantic of a sistate in pseudo code: + si_exit1; si_exit2; ...; si_exitn; + si_local; goto si_pc *) + +(* Note: in RTLpath, is.(icontinue) = false iff we took an early exit *) + +Definition ssem_internal (ge: RTL.genv) (sp:val) (st: sistate) (rs: regset) (m: mem) (is: istate): Prop := + if (is.(icontinue)) + then + ssem_local ge sp st.(si_local) rs m is.(irs) is.(imem) + /\ st.(si_pc) = is.(ipc) + /\ all_fallthrough ge sp st.(si_exits) rs m + else exists ext lx, + ssem_exit ge sp ext rs m is.(irs) is.(imem) is.(ipc) + /\ all_fallthrough_upto_exit ge sp ext lx st.(si_exits) rs m. + +Definition sabort (ge: RTL.genv) (sp: val) (st: sistate) (rs: regset) (m: mem): Prop := + (* No early exit was met but we aborted on the si_local *) + (all_fallthrough ge sp st.(si_exits) rs m /\ sabort_local ge sp st.(si_local) rs m) + (* OR we aborted on an evaluation of one of the early exits *) + \/ (exists ext lx, all_fallthrough_upto_exit ge sp ext lx st.(si_exits) rs m /\ sabort_exit ge sp ext rs m). + +Definition ssem_internal_opt ge sp (st: sistate) rs0 m0 (ois: option istate): Prop := + match ois with + | Some is => ssem_internal ge sp st rs0 m0 is + | None => sabort ge sp st rs0 m0 + end. + +Definition ssem_internal_opt2 ge sp (ost: option sistate) rs0 m0 (ois: option istate) : Prop := + match ost with + | Some st => ssem_internal_opt ge sp st rs0 m0 ois + | None => ois=None + end. + +(** * An internal state represents a parallel program ! + + We prove below that the semantics [ssem_internal_opt] is deterministic. + + *) + +Definition istate_eq ist1 ist2 := + ist1.(icontinue) = ist2.(icontinue) /\ + ist1.(ipc) = ist2.(ipc) /\ + (forall r, (ist1.(irs)#r) = ist2.(irs)#r) /\ + ist1.(imem) = ist2.(imem). + +Lemma all_fallthrough_noexit ge sp ext lx rs0 m0 rs m pc: + ssem_exit ge sp ext rs0 m0 rs m pc -> + In ext lx -> + all_fallthrough ge sp lx rs0 m0 -> + False. +Proof. + Local Hint Resolve is_tail_in: core. + intros SSEM INE ALLF. + destruct SSEM as (SSEM & SSEM'). + unfold all_fallthrough in ALLF. rewrite ALLF in SSEM; eauto. + discriminate. +Qed. + +Lemma ssem_internal_exclude_incompatible_continue ge sp st rs m is1 is2: + is1.(icontinue) = true -> + is2.(icontinue) = false -> + ssem_internal ge sp st rs m is1 -> + ssem_internal ge sp st rs m is2 -> + False. +Proof. + Local Hint Resolve all_fallthrough_noexit: core. + unfold ssem_internal. + intros CONT1 CONT2. + rewrite CONT1, CONT2; simpl. + intuition eauto. + destruct H0 as (ext & lx & SSEME & ALLFU). + destruct ALLFU as (ALLFU & ALLFU'). + eapply all_fallthrough_noexit; eauto. +Qed. + +Lemma ssem_internal_determ_continue ge sp st rs m is1 is2: + ssem_internal ge sp st rs m is1 -> + ssem_internal ge sp st rs m is2 -> + is1.(icontinue) = is2.(icontinue). +Proof. + Local Hint Resolve ssem_internal_exclude_incompatible_continue: core. + destruct (Bool.bool_dec is1.(icontinue) is2.(icontinue)) as [|H]; auto. + intros H1 H2. assert (absurd: False); intuition. + destruct (icontinue is1) eqn: His1, (icontinue is2) eqn: His2; eauto. +Qed. + +Lemma ssem_local_determ ge sp st rs0 m0 rs1 m1 rs2 m2: + ssem_local ge sp st rs0 m0 rs1 m1 -> + ssem_local ge sp st rs0 m0 rs2 m2 -> + (forall r, rs1#r = rs2#r) /\ m1 = m2. +Proof. + unfold ssem_local. intuition try congruence. + generalize (H5 r); rewrite H4; congruence. +Qed. + +(* TODO: lemma to move in Coqlib *) +Lemma is_tail_bounded_total {A} (l1 l2 l3: list A): is_tail l1 l3 -> is_tail l2 l3 + -> is_tail l1 l2 \/ is_tail l2 l1. +Proof. + Local Hint Resolve is_tail_cons: core. + induction 1 as [|i l1 l3 T1 IND]; simpl; auto. + intros T2; inversion T2; subst; auto. +Qed. + +Lemma exit_cond_determ ge sp rs0 m0 l1 l2: + is_tail l1 l2 -> forall ext1 lx1 ext2 lx2, + l1=(ext1 :: lx1) -> + l2=(ext2 :: lx2) -> + all_fallthrough ge sp lx1 rs0 m0 -> + seval_condition ge sp (si_cond ext1) (si_scondargs ext1) (si_smem (si_elocal ext1)) rs0 m0 = Some true -> + all_fallthrough ge sp lx2 rs0 m0 -> + ext1=ext2. +Proof. + destruct 1 as [l1|i l1 l3 T1]; intros ext1 lx1 ext2 lx2 EQ1 EQ2; subst; + inversion EQ2; subst; auto. + intros D1 EVAL NYE. + Local Hint Resolve is_tail_in: core. + unfold all_fallthrough in NYE. + rewrite NYE in EVAL; eauto. + try congruence. +Qed. + +Lemma ssem_exit_determ ge sp ext rs0 m0 rs1 m1 pc1 rs2 m2 pc2: + ssem_exit ge sp ext rs0 m0 rs1 m1 pc1 -> + ssem_exit ge sp ext rs0 m0 rs2 m2 pc2 -> + pc1 = pc2 /\ (forall r, rs1#r = rs2#r) /\ m1 = m2. +Proof. + Local Hint Resolve exit_cond_determ eq_sym: core. + intros SSEM1 SSEM2. destruct SSEM1 as (SEVAL1 & SLOC1 & PCEQ1). destruct SSEM2 as (SEVAL2 & SLOC2 & PCEQ2). subst. + destruct (ssem_local_determ ge sp (si_elocal ext) rs0 m0 rs1 m1 rs2 m2); auto. +Qed. + +Remark is_tail_inv_left {A: Type} (a a': A) l l': + is_tail (a::l) (a'::l') -> + (a = a' /\ l = l') \/ (In a l' /\ is_tail l (a'::l')). +Proof. + intros. inv H. + - left. eauto. + - right. econstructor. + + eapply is_tail_in; eauto. + + eapply is_tail_cons_left; eauto. +Qed. + +Lemma ssem_internal_determ ge sp st rs m is1 is2: + ssem_internal ge sp st rs m is1 -> + ssem_internal ge sp st rs m is2 -> + istate_eq is1 is2. +Proof. + unfold istate_eq. + intros SEM1 SEM2. + exploit (ssem_internal_determ_continue ge sp st rs m is1 is2); eauto. + intros CONTEQ. unfold ssem_internal in * |-. rewrite CONTEQ in * |- *. + destruct (icontinue is2). + - destruct (ssem_local_determ ge sp (si_local st) rs m (irs is1) (imem is1) (irs is2) (imem is2)); + intuition (try congruence). + - destruct SEM1 as (ext1 & lx1 & SSEME1 & ALLFU1). destruct SEM2 as (ext2 & lx2 & SSEME2 & ALLFU2). + destruct ALLFU1 as (ALLFU1 & ALLFU1'). destruct ALLFU2 as (ALLFU2 & ALLFU2'). + destruct SSEME1 as (SSEME1 & SSEME1' & SSEME1''). destruct SSEME2 as (SSEME2 & SSEME2' & SSEME2''). + assert (X:ext1=ext2). + { destruct (is_tail_bounded_total (ext1 :: lx1) (ext2 :: lx2) (si_exits st)) as [TAIL|TAIL]; eauto. } + subst. destruct (ssem_local_determ ge sp (si_elocal ext2) rs m (irs is1) (imem is1) (irs is2) (imem is2)); auto. + intuition. congruence. +Qed. + +Lemma ssem_local_exclude_sabort_local ge sp loc rs m rs' m': + ssem_local ge sp loc rs m rs' m' -> +(* all_fallthrough ge sp (si_exits st) rs m -> *) + sabort_local ge sp loc rs m -> + False. +Proof. + intros SIML (* ALLF *) ABORT. inv SIML. destruct H0 as (H0 & H0'). + inversion ABORT as [ABORT1 | [ABORT2 | ABORT3]]; [ | | inv ABORT3]; congruence. +Qed. + +(* TODO: remove this JUNK ? +Lemma ssem_local_exclude_sabort_exit ge sp st ext lx rs m rs' m': + ssem_local ge sp (si_local st) rs m rs' m' -> + all_fallthrough ge sp (si_exits st) rs m -> + is_tail (ext :: lx) (si_exits st) -> + sabort_exit ge sp ext rs m -> + False. +Proof. + intros SSEML ALLF TAIL ABORT. + inv ABORT. + - exploit ALLF; eauto. congruence. + - (* FIXME Problem : if we have a ssem_local, this means we ONLY evaluated the conditions, + but we NEVER actually evaluated the si_elocal from the sistate_exit ! So we cannot prove + a lack of abort on the si_elocal.. We must change the definitions *) +Abort. +*) + +Lemma ssem_local_exclude_sabort ge sp st rs m rs' m': + ssem_local ge sp (si_local st) rs m rs' m' -> + all_fallthrough ge sp (si_exits st) rs m -> + sabort ge sp st rs m -> + False. +Proof. + intros SIML ALLF ABORT. + inv ABORT. + - intuition; eapply ssem_local_exclude_sabort_local; eauto. + - destruct H as (ext & lx & ALLFU & SABORT). + destruct ALLFU as (TAIL & _). eapply is_tail_in in TAIL. + eapply ALLF in TAIL. + destruct SABORT as [CONDFAIL | (CONDTRUE & ABORTL)]; congruence. +Qed. + +Lemma ssem_exit_fallthrough_upto_exit ge sp ext ext' lx lx' exits rs m rs' m' pc': + ssem_exit ge sp ext rs m rs' m' pc' -> + all_fallthrough_upto_exit ge sp ext lx exits rs m -> + all_fallthrough_upto_exit ge sp ext' lx' exits rs m -> + is_tail (ext'::lx') (ext::lx). +Proof. + intros SSEME ALLFU ALLFU'. + destruct ALLFU as (ISTAIL & ALLFU). destruct ALLFU' as (ISTAIL' & ALLFU'). + destruct (is_tail_bounded_total (ext::lx) (ext'::lx') exits); eauto. + inv H. + - econstructor; eauto. + - eapply is_tail_in in H2. eapply ALLFU' in H2. + destruct SSEME as (SEVAL & _). congruence. +Qed. + +Lemma ssem_exit_exclude_sabort_exit ge sp ext rs m rs' m' pc': + ssem_exit ge sp ext rs m rs' m' pc' -> + sabort_exit ge sp ext rs m -> + False. +Proof. + intros A B. destruct A as (A & A' & A''). inv B. + - congruence. + - destruct H as (_ & H). eapply ssem_local_exclude_sabort_local; eauto. +Qed. + +Lemma ssem_exit_exclude_sabort ge sp ext st lx rs m rs' m' pc': + ssem_exit ge sp ext rs m rs' m' pc' -> + all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs m -> + sabort ge sp st rs m -> + False. +Proof. + intros SSEM ALLFU ABORT. + inv ABORT. + - destruct H as (ALLF & _). destruct ALLFU as (TAIL & _). + eapply is_tail_in in TAIL. + destruct SSEM as (SEVAL & _ & _). + eapply ALLF in TAIL. congruence. + - destruct H as (ext' & lx' & ALLFU' & ABORT). + exploit ssem_exit_fallthrough_upto_exit; eauto. intros ITAIL. + destruct ALLFU as (ALLFU1 & ALLFU2). destruct ALLFU' as (ALLFU1' & ALLFU2'). + exploit (is_tail_inv_left ext' ext lx' lx); eauto. intro. inv H. + + inv H0. eapply ssem_exit_exclude_sabort_exit; eauto. + + destruct H0 as (INE & TAIL). eapply ALLFU2 in INE. destruct ABORT as [ABORT | (ABORT & ABORT')]; congruence. +Qed. + +Lemma ssem_internal_exclude_sabort ge sp st rs m is: + sabort ge sp st rs m -> + ssem_internal ge sp st rs m is -> False. +Proof. + intros ABORT SEM. + unfold ssem_internal in SEM. destruct icontinue. + - destruct SEM as (SEM1 & SEM2 & SEM3). + eapply ssem_local_exclude_sabort; eauto. + - destruct SEM as (ext & lx & SEM1 & SEM2). eapply ssem_exit_exclude_sabort; eauto. +Qed. + +Definition istate_eq_opt ist1 oist := + exists ist2, oist = Some ist2 /\ istate_eq ist1 ist2. + +Lemma ssem_internal_opt_determ ge sp st rs m ois is: + ssem_internal_opt ge sp st rs m ois -> + ssem_internal ge sp st rs m is -> + istate_eq_opt is ois. +Proof. + destruct ois as [is1|]; simpl; eauto. + - intros; eexists; intuition; eapply ssem_internal_determ; eauto. + - intros; exploit ssem_internal_exclude_sabort; eauto. destruct 1. +Qed. + +(** * Symbolic execution of one internal step *) + +Definition slocal_set_sreg (st:sistate_local) (r:reg) (sv:sval) := + {| si_pre:=(fun ge sp rs m => seval_sval ge sp (st.(si_sreg) r) rs m <> None /\ (st.(si_pre) ge sp rs m)); + si_sreg:=fun y => if Pos.eq_dec r y then sv else st.(si_sreg) y; + si_smem:= st.(si_smem)|}. + +Definition slocal_set_smem (st:sistate_local) (sm:smem) := + {| si_pre:=(fun ge sp rs m => seval_smem ge sp st.(si_smem) rs m <> None /\ (st.(si_pre) ge sp rs m)); + si_sreg:= st.(si_sreg); + si_smem:= sm |}. + +Definition sist_set_local (st: sistate) (pc: node) (nxt: sistate_local): sistate := + {| si_pc := pc; si_exits := st.(si_exits); si_local:= nxt |}. + + +Definition siexec_inst (i: instruction) (st: sistate): option sistate := + match i with + | Inop pc' => + Some (sist_set_local st pc' st.(si_local)) + | Iop op args dst pc' => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let next := slocal_set_sreg prev dst (Sop op vargs prev.(si_smem)) in + Some (sist_set_local st pc' next) + | Iload trap chunk addr args dst pc' => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let next := slocal_set_sreg prev dst (Sload prev.(si_smem) trap chunk addr vargs) in + Some (sist_set_local st pc' next) + | Istore chunk addr args src pc' => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let next := slocal_set_smem prev (Sstore prev.(si_smem) chunk addr vargs (prev.(si_sreg) src)) in + Some (sist_set_local st pc' next) + | Icond cond args ifso ifnot _ => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let ex := {| si_cond:=cond; si_scondargs:=vargs; si_elocal := prev; si_ifso := ifso |} in + Some {| si_pc := ifnot; si_exits := ex::st.(si_exits); si_local := prev |} + | _ => None (* TODO jumptable ? *) + end. + + +Lemma seval_list_sval_inj ge sp l rs0 m0 (sreg: reg -> sval) rs: + (forall r : reg, seval_sval ge sp (sreg r) rs0 m0 = Some (rs # r)) -> + seval_list_sval ge sp (list_sval_inj (map sreg l)) rs0 m0 = Some (rs ## l). +Proof. + intros H; induction l as [|r l]; simpl; auto. + inversion_SOME v. + inversion_SOME lv. + generalize (H r). + try_simplify_someHyps. +Qed. + +Lemma slocal_set_sreg_preserves_sabort_local ge sp st rs0 m0 r sv: + sabort_local ge sp st rs0 m0 -> + sabort_local ge sp (slocal_set_sreg st r sv) rs0 m0. +Proof. + unfold sabort_local. simpl; intuition. + destruct H as [r1 H]. destruct (Pos.eq_dec r r1) as [TEST|TEST] eqn: HTEST. + - subst; rewrite H; intuition. + - right. right. exists r1. rewrite HTEST. auto. +Qed. + +Lemma slocal_set_smem_preserves_sabort_local ge sp st rs0 m0 m: + sabort_local ge sp st rs0 m0 -> + sabort_local ge sp (slocal_set_smem st m) rs0 m0. +Proof. + unfold sabort_local. simpl; intuition. +Qed. + +Lemma all_fallthrough_upto_exit_cons ge sp ext lx ext' exits rs m: + all_fallthrough_upto_exit ge sp ext lx exits rs m -> + all_fallthrough_upto_exit ge sp ext lx (ext'::exits) rs m. +Proof. + intros. inv H. econstructor; eauto. +Qed. + +Lemma all_fallthrough_cons ge sp exits rs m ext: + all_fallthrough ge sp exits rs m -> + seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs m = Some false -> + all_fallthrough ge sp (ext::exits) rs m. +Proof. + intros. unfold all_fallthrough in *. intros. + inv H1; eauto. +Qed. + +Lemma siexec_inst_preserves_sabort i ge sp rs m st st': + siexec_inst i st = Some st' -> + sabort ge sp st rs m -> sabort ge sp st' rs m. +Proof. + intros SISTEP ABORT. + destruct i; simpl in SISTEP; try discriminate; inv SISTEP; unfold sabort; simpl. + (* NOP *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* OP *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. eapply slocal_set_sreg_preserves_sabort_local; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* LOAD *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. eapply slocal_set_sreg_preserves_sabort_local; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* STORE *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. eapply slocal_set_smem_preserves_sabort_local; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* COND *) + * remember ({| si_cond := _; si_scondargs := _; si_elocal := _; si_ifso := _ |}) as ext. + destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - destruct (seval_condition ge sp (si_cond ext) (si_scondargs ext) + (si_smem (si_elocal ext)) rs m) eqn:SEVAL; [destruct b|]. + (* case true *) + + right. exists ext, (si_exits st). + constructor. + ++ constructor. econstructor; eauto. eauto. + ++ unfold sabort_exit. right. constructor; eauto. + subst. simpl. eauto. + (* case false *) + + left. constructor; eauto. eapply all_fallthrough_cons; eauto. + (* case None *) + + right. exists ext, (si_exits st). constructor. + ++ constructor. econstructor; eauto. eauto. + ++ unfold sabort_exit. left. eauto. + - right. exists ext0, lx0. constructor; eauto. eapply all_fallthrough_upto_exit_cons; eauto. +Qed. + +Lemma siexec_inst_WF i st: + siexec_inst i st = None -> default_succ i = None. +Proof. + destruct i; simpl; unfold sist_set_local; simpl; congruence. +Qed. + +Lemma siexec_inst_default_succ i st st': + siexec_inst i st = Some st' -> default_succ i = Some (st'.(si_pc)). +Proof. + destruct i; simpl; unfold sist_set_local; simpl; try congruence; + intro H; inversion_clear H; simpl; auto. +Qed. + + +Lemma seval_list_sval_inj_not_none ge sp st rs0 m0 rs: forall l, + (forall r, List.In r l -> seval_sval ge sp (si_sreg (si_local st) r) rs0 m0 = Some rs # r) -> + seval_list_sval ge sp (list_sval_inj (map (si_sreg (si_local st)) l)) rs0 m0 = None -> + False. +Proof. + induction l. + - intros. simpl in H0. discriminate. + - intros ALLR. simpl. + inversion_SOME v. + + intro SVAL. inversion_SOME lv; [discriminate|]. + assert (forall r : reg, In r l -> seval_sval ge sp (si_sreg (si_local st) r) rs0 m0 = Some rs # r). + { intros r INR. eapply ALLR. right. assumption. } + intro SVALLIST. intro. eapply IHl; eauto. + + intros. exploit (ALLR a); [constructor; eauto|]. congruence. +Qed. + +Lemma siexec_inst_correct ge sp i st rs0 m0 rs m: + ssem_local ge sp st.(si_local) rs0 m0 rs m -> + all_fallthrough ge sp st.(si_exits) rs0 m0 -> + ssem_internal_opt2 ge sp (siexec_inst i st) rs0 m0 (istep ge i sp rs m). +Proof. + intros (PRE & MEM & REG) NYE. + destruct i; simpl; auto. + + (* Nop *) + constructor; [|constructor]; simpl; auto. + constructor; auto. + + (* Op *) + inversion_SOME v; intros OP; simpl. + - constructor; [|constructor]; simpl; auto. + constructor; simpl; auto. + * constructor; auto. congruence. + * constructor; auto. + intro r0. destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst. rewrite Regmap.gss; simpl; auto. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + - left. constructor; simpl; auto. + unfold sabort_local. right. right. + simpl. exists r. destruct (Pos.eq_dec r r); try congruence. + simpl. erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + + (* LOAD *) + inversion_SOME a0; intro ADD. + { inversion_SOME v; intros LOAD; simpl. + - explore_destruct; unfold ssem_internal, ssem_local; simpl; intuition. + * unfold ssem_internal. simpl. constructor; [|constructor]; auto. + constructor; constructor; simpl; auto. congruence. intro r0. + destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst; rewrite Regmap.gss; simpl. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + * unfold ssem_internal. simpl. constructor; [|constructor]; auto. + constructor; constructor; simpl; auto. congruence. intro r0. + destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst; rewrite Regmap.gss; simpl. + inversion_SOME args; intros ARGS; [|exploit seval_list_sval_inj_not_none; eauto; contradiction]. + exploit seval_list_sval_inj; eauto. intro ARGS'. erewrite ARGS in ARGS'. inv ARGS'. rewrite ADD. + inversion_SOME m2. intro SMEM. + assert (m = m2) by congruence. subst. rewrite LOAD. reflexivity. + - explore_destruct; unfold sabort, sabort_local; simpl. + * unfold sabort. simpl. left. constructor; auto. + right. right. exists r. simpl. destruct (Pos.eq_dec r r); try congruence. + simpl. erewrite seval_list_sval_inj; simpl; auto. + rewrite ADD; simpl; auto. try_simplify_someHyps. + * unfold ssem_internal. simpl. constructor; [|constructor]; auto. + constructor; constructor; simpl; auto. congruence. intro r0. + destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst; rewrite Regmap.gss; simpl. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. intros SMEM SEVAL. + rewrite LOAD. reflexivity. + } { rewrite ADD. destruct t. + - simpl. left; eauto. simpl. econstructor; eauto. + right. right. simpl. exists r. destruct (Pos.eq_dec r r); [|contradiction]. + simpl. inversion_SOME args. intro SLS. + eapply seval_list_sval_inj in REG. rewrite REG in SLS. inv SLS. + rewrite ADD. reflexivity. + - simpl. constructor; [|constructor]; simpl; auto. + constructor; simpl; constructor; auto; [congruence|]. + intro r0. destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst. simpl. rewrite Regmap.gss. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. intro SMEM. rewrite ADD. reflexivity. + } + + (* STORE *) + inversion_SOME a0; intros ADD. + { inversion_SOME m'; intros STORE; simpl. + - unfold ssem_internal, ssem_local; simpl; intuition. + * congruence. + * erewrite seval_list_sval_inj; simpl; auto. + erewrite REG. + try_simplify_someHyps. + - unfold sabort, sabort_local; simpl. + left. constructor; auto. right. left. + erewrite seval_list_sval_inj; simpl; auto. + erewrite REG. + try_simplify_someHyps. } + { unfold sabort, sabort_local; simpl. + left. constructor; auto. right. left. + erewrite seval_list_sval_inj; simpl; auto. + erewrite ADD; simpl; auto. } + + (* COND *) + Local Hint Resolve is_tail_refl: core. + Local Hint Unfold ssem_local: core. + inversion_SOME b; intros COND. + { destruct b; simpl; unfold ssem_internal, ssem_local; simpl. + - remember (mk_sistate_exit _ _ _ _) as ext. exists ext, (si_exits st). + constructor; constructor; subst; simpl; auto. + unfold seval_condition. subst; simpl. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + - intuition. unfold all_fallthrough in * |- *. simpl. + intuition. subst. simpl. + unfold seval_condition. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. } + { unfold sabort. simpl. right. + remember (mk_sistate_exit _ _ _ _) as ext. exists ext, (si_exits st). + constructor; [constructor; subst; simpl; auto|]. + left. subst; simpl; auto. + unfold seval_condition. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. } +Qed. + + +Lemma siexec_inst_correct_None ge sp i st rs0 m0 rs m: + ssem_local ge sp (st.(si_local)) rs0 m0 rs m -> + siexec_inst i st = None -> + istep ge i sp rs m = None. +Proof. + intros (PRE & MEM & REG). + destruct i; simpl; unfold sist_set_local, ssem_internal, ssem_local; simpl; try_simplify_someHyps. +Qed. + +(** * Symbolic execution of the internal steps of a path *) +Fixpoint siexec_path (path:nat) (f: function) (st: sistate): option sistate := + match path with + | O => Some st + | S p => + SOME i <- (fn_code f)!(st.(si_pc)) IN + SOME st1 <- siexec_inst i st IN + siexec_path p f st1 + end. + +Lemma siexec_inst_add_exits i st st': + siexec_inst i st = Some st' -> + ( si_exits st' = si_exits st \/ exists ext, si_exits st' = ext :: si_exits st ). +Proof. + destruct i; simpl; intro SISTEP; inversion_clear SISTEP; unfold siexec_inst; simpl; (discriminate || eauto). +Qed. + +Lemma siexec_inst_preserves_allfu ge sp ext lx rs0 m0 st st' i: + all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs0 m0 -> + siexec_inst i st = Some st' -> + all_fallthrough_upto_exit ge sp ext lx (si_exits st') rs0 m0. +Proof. + intros ALLFU SISTEP. destruct ALLFU as (ISTAIL & ALLF). + constructor; eauto. + destruct i; simpl in SISTEP; inversion_clear SISTEP; simpl; (discriminate || eauto). +Qed. + +Lemma siexec_path_correct_false ge sp f rs0 m0 st' is: + forall path, + is.(icontinue)=false -> + forall st, ssem_internal ge sp st rs0 m0 is -> + siexec_path path f st = Some st' -> + ssem_internal ge sp st' rs0 m0 is. +Proof. + induction path; simpl. + - intros. congruence. + - intros ICF st SSEM STEQ'. + destruct ((fn_code f) ! (si_pc st)) eqn:FIC; [|discriminate]. + destruct (siexec_inst _ _) eqn:SISTEP; [|discriminate]. + eapply IHpath. 3: eapply STEQ'. eauto. + unfold ssem_internal in SSEM. rewrite ICF in SSEM. + destruct SSEM as (ext & lx & SEXIT & ALLFU). + unfold ssem_internal. rewrite ICF. exists ext, lx. + constructor; auto. eapply siexec_inst_preserves_allfu; eauto. +Qed. + +Lemma siexec_path_preserves_sabort ge sp path f rs0 m0 st': forall st, + siexec_path path f st = Some st' -> + sabort ge sp st rs0 m0 -> sabort ge sp st' rs0 m0. +Proof. + Local Hint Resolve siexec_inst_preserves_sabort: core. + induction path; simpl. + + unfold sist_set_local; try_simplify_someHyps. + + intros st; inversion_SOME i. + inversion_SOME st1; eauto. +Qed. + +Lemma siexec_path_WF path f: forall st, + siexec_path path f st = None -> nth_default_succ (fn_code f) path st.(si_pc) = None. +Proof. + induction path; simpl. + + unfold sist_set_local. intuition congruence. + + intros st; destruct ((fn_code f) ! (si_pc st)); simpl; try tauto. + destruct (siexec_inst i st) as [st1|] eqn: Hst1; simpl. + - intros; erewrite siexec_inst_default_succ; eauto. + - intros; erewrite siexec_inst_WF; eauto. +Qed. + +Lemma siexec_path_default_succ path f st': forall st, + siexec_path path f st = Some st' -> nth_default_succ (fn_code f) path st.(si_pc) = Some st'.(si_pc). +Proof. + induction path; simpl. + + unfold sist_set_local. intros st H. inversion_clear H; simpl; try congruence. + + intros st; destruct ((fn_code f) ! (si_pc st)); simpl; try congruence. + destruct (siexec_inst i st) as [st1|] eqn: Hst1; simpl; try congruence. + intros; erewrite siexec_inst_default_succ; eauto. +Qed. + +Lemma siexec_path_correct_true ge sp path (f:function) rs0 m0: forall st is, + is.(icontinue)=true -> + ssem_internal ge sp st rs0 m0 is -> + nth_default_succ (fn_code f) path st.(si_pc) <> None -> + ssem_internal_opt2 ge sp (siexec_path path f st) rs0 m0 + (isteps ge path f sp is.(irs) is.(imem) is.(ipc)) + . +Proof. + Local Hint Resolve siexec_path_correct_false siexec_path_preserves_sabort siexec_path_WF: core. + induction path; simpl. + + intros st is CONT INV WF; + unfold ssem_internal, sist_set_local in * |- *; + try_simplify_someHyps. simpl. + destruct is; simpl in * |- *; subst; intuition auto. + + intros st is CONT; unfold ssem_internal at 1; rewrite CONT. + intros (LOCAL & PC & NYE) WF. + rewrite <- PC. + inversion_SOME i; intro Hi; rewrite Hi in WF |- *; simpl; auto. + exploit siexec_inst_correct; eauto. + inversion_SOME st1; intros Hst1; erewrite Hst1; simpl. + - inversion_SOME is1; intros His1;rewrite His1; simpl. + * destruct (icontinue is1) eqn:CONT1. + (* icontinue is0 = true *) + intros; eapply IHpath; eauto. + destruct i; simpl in * |- *; unfold sist_set_local in * |- *; try_simplify_someHyps. + (* icontinue is0 = false -> EARLY EXIT *) + destruct (siexec_path path f st1) as [st2|] eqn: Hst2; simpl; eauto. + destruct WF. erewrite siexec_inst_default_succ; eauto. + (* try_simplify_someHyps; eauto. *) + * destruct (siexec_path path f st1) as [st2|] eqn: Hst2; simpl; eauto. + - intros His1;rewrite His1; simpl; auto. +Qed. + +(** REM: in the following two unused lemmas *) + +Lemma siexec_path_right_assoc_decompose f path: forall st st', + siexec_path (S path) f st = Some st' -> + exists st0, siexec_path path f st = Some st0 /\ siexec_path 1%nat f st0 = Some st'. +Proof. + induction path; simpl; eauto. + intros st st'. + inversion_SOME i1. + inversion_SOME st1. + try_simplify_someHyps; eauto. +Qed. + +Lemma siexec_path_right_assoc_compose f path: forall st st0 st', + siexec_path path f st = Some st0 -> + siexec_path 1%nat f st0 = Some st' -> + siexec_path (S path) f st = Some st'. +Proof. + induction path. + + intros st st0 st' H. simpl in H. + try_simplify_someHyps; auto. + + intros st st0 st'. + assert (X:exists x, x=(S path)); eauto. + destruct X as [x X]. + intros H1 H2. rewrite <- X. + generalize H1; clear H1. simpl. + inversion_SOME i1. intros Hi1; rewrite Hi1. + inversion_SOME st1. intros Hst1; rewrite Hst1. + subst; eauto. +Qed. + +(** * Symbolic (final) value of a path *) +Inductive sfval := + | Snone + | Scall (sig:signature) (svos: sval + ident) (lsv:list_sval) (res:reg) (pc:node) + (* NB: [res] the return register is hard-wired ! Is it restrictive ? *) + | Stailcall: signature -> sval + ident -> list_sval -> sfval + | Sbuiltin (ef:external_function) (sargs: list (builtin_arg sval)) (res: builtin_res reg) (pc:node) + | Sjumptable (sv: sval) (tbl: list node) + | Sreturn: option sval -> sfval +. + +Definition sfind_function (pge: RTLpath.genv) (ge: RTL.genv) (sp: val) (svos : sval + ident) (rs0: regset) (m0: mem): option fundef := + match svos with + | inl sv => SOME v <- seval_sval ge sp sv rs0 m0 IN Genv.find_funct pge v + | inr symb => SOME b <- Genv.find_symbol pge symb IN Genv.find_funct_ptr pge b + end. + +Section SEVAL_BUILTIN_ARG. (* adapted from Events.v *) + +Variable ge: RTL.genv. +Variable sp: val. +Variable m: mem. +Variable rs0: regset. +Variable m0: mem. + +Inductive seval_builtin_arg: builtin_arg sval -> val -> Prop := + | seval_BA: forall x v, + seval_sval ge sp x rs0 m0 = Some v -> + seval_builtin_arg (BA x) v + | seval_BA_int: forall n, + seval_builtin_arg (BA_int n) (Vint n) + | seval_BA_long: forall n, + seval_builtin_arg (BA_long n) (Vlong n) + | seval_BA_float: forall n, + seval_builtin_arg (BA_float n) (Vfloat n) + | seval_BA_single: forall n, + seval_builtin_arg (BA_single n) (Vsingle n) + | seval_BA_loadstack: forall chunk ofs v, + Mem.loadv chunk m (Val.offset_ptr sp ofs) = Some v -> + seval_builtin_arg (BA_loadstack chunk ofs) v + | seval_BA_addrstack: forall ofs, + seval_builtin_arg (BA_addrstack ofs) (Val.offset_ptr sp ofs) + | seval_BA_loadglobal: forall chunk id ofs v, + Mem.loadv chunk m (Senv.symbol_address ge id ofs) = Some v -> + seval_builtin_arg (BA_loadglobal chunk id ofs) v + | seval_BA_addrglobal: forall id ofs, + seval_builtin_arg (BA_addrglobal id ofs) (Senv.symbol_address ge id ofs) + | seval_BA_splitlong: forall hi lo vhi vlo, + seval_builtin_arg hi vhi -> seval_builtin_arg lo vlo -> + seval_builtin_arg (BA_splitlong hi lo) (Val.longofwords vhi vlo) + | seval_BA_addptr: forall a1 a2 v1 v2, + seval_builtin_arg a1 v1 -> seval_builtin_arg a2 v2 -> + seval_builtin_arg (BA_addptr a1 a2) + (if Archi.ptr64 then Val.addl v1 v2 else Val.add v1 v2). + +Definition seval_builtin_args (al: list (builtin_arg sval)) (vl: list val) : Prop := + list_forall2 seval_builtin_arg al vl. + +Lemma seval_builtin_arg_determ: + forall a v, seval_builtin_arg a v -> forall v', seval_builtin_arg a v' -> v' = v. +Proof. + induction 1; intros v' EV; inv EV; try congruence. + f_equal; eauto. + apply IHseval_builtin_arg1 in H3. apply IHseval_builtin_arg2 in H5. subst; auto. +Qed. + +Lemma eval_builtin_args_determ: + forall al vl, seval_builtin_args al vl -> forall vl', seval_builtin_args al vl' -> vl' = vl. +Proof. + induction 1; intros v' EV; inv EV; f_equal; eauto using seval_builtin_arg_determ. +Qed. + +End SEVAL_BUILTIN_ARG. + +Inductive ssem_final (pge: RTLpath.genv) (ge: RTL.genv) (sp:val) (npc: node) stack (f: function) (rs0: regset) (m0: mem): sfval -> regset -> mem -> trace -> state -> Prop := + | exec_Snone rs m: + ssem_final pge ge sp npc stack f rs0 m0 Snone rs m E0 (State stack f sp npc rs m) + | exec_Scall rs m sig svos lsv args res pc fd: + sfind_function pge ge sp svos rs0 m0 = Some fd -> + funsig fd = sig -> + seval_list_sval ge sp lsv rs0 m0 = Some args -> + ssem_final pge ge sp npc stack f rs0 m0 (Scall sig svos lsv res pc) rs m + E0 (Callstate (Stackframe res f sp pc rs :: stack) fd args m) + | exec_Stailcall stk rs m sig svos args fd m' lsv: + sfind_function pge ge sp svos rs0 m0 = Some fd -> + funsig fd = sig -> + sp = Vptr stk Ptrofs.zero -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + seval_list_sval ge sp lsv rs0 m0 = Some args -> + ssem_final pge ge sp npc stack f rs0 m0 (Stailcall sig svos lsv) rs m + E0 (Callstate stack fd args m') + | exec_Sbuiltin m' rs m vres res pc t sargs ef vargs: + seval_builtin_args ge sp m rs0 m0 sargs vargs -> + external_call ef ge vargs m t vres m' -> + ssem_final pge ge sp npc stack f rs0 m0 (Sbuiltin ef sargs res pc) rs m + t (State stack f sp pc (regmap_setres res vres rs) m') + | exec_Sjumptable sv tbl pc' n rs m: + seval_sval ge sp sv rs0 m0 = Some (Vint n) -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> + ssem_final pge ge sp npc stack f rs0 m0 (Sjumptable sv tbl) rs m + E0 (State stack f sp pc' rs m) + | exec_Sreturn stk osv rs m m' v: + sp = (Vptr stk Ptrofs.zero) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + match osv with Some sv => seval_sval ge sp sv rs0 m0 | None => Some Vundef end = Some v -> + ssem_final pge ge sp npc stack f rs0 m0 (Sreturn osv) rs m + E0 (Returnstate stack v m') +. + +Record sstate := { internal:> sistate; final: sfval }. + +Inductive ssem pge (ge: RTL.genv) (sp:val) (st: sstate) stack f (rs0: regset) (m0: mem): trace -> state -> Prop := + | ssem_early is: + is.(icontinue) = false -> + ssem_internal ge sp st rs0 m0 is -> + ssem pge ge sp st stack f rs0 m0 E0 (State stack f sp is.(ipc) is.(irs) is.(imem)) + | ssem_normal is t s: + is.(icontinue) = true -> + ssem_internal ge sp st rs0 m0 is -> + ssem_final pge ge sp st.(si_pc) stack f rs0 m0 st.(final) is.(irs) is.(imem) t s -> + ssem pge ge sp st stack f rs0 m0 t s + . + +(* NB: generic function that could be put into [AST] file *) +Fixpoint builtin_arg_map {A B} (f: A -> B) (arg: builtin_arg A) : builtin_arg B := + match arg with + | BA x => BA (f x) + | BA_int n => BA_int n + | BA_long n => BA_long n + | BA_float f => BA_float f + | BA_single s => BA_single s + | BA_loadstack chunk ptr => BA_loadstack chunk ptr + | BA_addrstack ptr => BA_addrstack ptr + | BA_loadglobal chunk id ptr => BA_loadglobal chunk id ptr + | BA_addrglobal id ptr => BA_addrglobal id ptr + | BA_splitlong ba1 ba2 => BA_splitlong (builtin_arg_map f ba1) (builtin_arg_map f ba2) + | BA_addptr ba1 ba2 => BA_addptr (builtin_arg_map f ba1) (builtin_arg_map f ba2) + end. + +Lemma seval_builtin_arg_correct ge sp rs m rs0 m0 sreg: forall arg varg, + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + eval_builtin_arg ge (fun r => rs # r) sp m arg varg -> + seval_builtin_arg ge sp m rs0 m0 (builtin_arg_map sreg arg) varg. +Proof. + induction arg. + all: try (intros varg SEVAL BARG; inv BARG; constructor; congruence). + - intros varg SEVAL BARG. inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. + - intros varg SEVAL BARG. inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. +Qed. + +Lemma seval_builtin_args_correct ge sp rs m rs0 m0 sreg args vargs: + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + eval_builtin_args ge (fun r => rs # r) sp m args vargs -> + seval_builtin_args ge sp m rs0 m0 (map (builtin_arg_map sreg) args) vargs. +Proof. + induction 2. + - constructor. + - simpl. constructor; [| assumption]. + eapply seval_builtin_arg_correct; eauto. +Qed. + +Lemma seval_builtin_arg_complete ge sp rs m rs0 m0 sreg: forall arg varg, + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + seval_builtin_arg ge sp m rs0 m0 (builtin_arg_map sreg arg) varg -> + eval_builtin_arg ge (fun r => rs # r) sp m arg varg. +Proof. + induction arg. + all: intros varg SEVAL BARG; try (inv BARG; constructor; congruence). + - inv BARG. rewrite SEVAL in H0. inv H0. constructor. + - inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. + - inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. +Qed. + +Lemma seval_builtin_args_complete ge sp rs m rs0 m0 sreg: forall args vargs, + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + seval_builtin_args ge sp m rs0 m0 (map (builtin_arg_map sreg) args) vargs -> + eval_builtin_args ge (fun r => rs # r) sp m args vargs. +Proof. + induction args. + - simpl. intros. inv H0. constructor. + - intros vargs SEVAL BARG. simpl in BARG. inv BARG. + constructor; [| eapply IHargs; eauto]. + eapply seval_builtin_arg_complete; eauto. +Qed. + +(** * Symbolic execution of final step *) +Definition sexec_final (i: instruction) (prev: sistate_local): sfval := + match i with + | Icall sig ros args res pc => + let svos := sum_left_map prev.(si_sreg) ros in + let sargs := list_sval_inj (List.map prev.(si_sreg) args) in + Scall sig svos sargs res pc + | Itailcall sig ros args => + let svos := sum_left_map prev.(si_sreg) ros in + let sargs := list_sval_inj (List.map prev.(si_sreg) args) in + Stailcall sig svos sargs + | Ibuiltin ef args res pc => + let sargs := List.map (builtin_arg_map prev.(si_sreg)) args in + Sbuiltin ef sargs res pc + | Ireturn or => + let sor := SOME r <- or IN Some (prev.(si_sreg) r) in + Sreturn sor + | Ijumptable reg tbl => + let sv := prev.(si_sreg) reg in + Sjumptable sv tbl + | _ => Snone + end. + +Lemma sexec_final_correct pge ge sp i (f:function) pc st stack rs0 m0 t rs m s: + (fn_code f) ! pc = Some i -> + pc = st.(si_pc) -> + ssem_local ge sp (si_local st) rs0 m0 rs m -> + path_last_step ge pge stack f sp pc rs m t s -> + siexec_inst i st = None -> + ssem_final pge ge sp pc stack f rs0 m0 (sexec_final i (si_local st)) rs m t s. +Proof. + intros PC1 PC2 (PRE&MEM®) LAST Hi. destruct LAST; subst; try_simplify_someHyps; simpl. + + (* Snone *) destruct i; simpl in Hi |- *; unfold sist_set_local in Hi; try congruence. + + (* Icall *) intros; eapply exec_Scall; auto. + - destruct ros; simpl in * |- *; auto. + rewrite REG; auto. + - erewrite seval_list_sval_inj; simpl; auto. + + (* Itailcall *) intros. eapply exec_Stailcall; auto. + - destruct ros; simpl in * |- *; auto. + rewrite REG; auto. + - erewrite seval_list_sval_inj; simpl; auto. + + (* Ibuiltin *) intros. eapply exec_Sbuiltin; eauto. + eapply seval_builtin_args_correct; eauto. + + (* Ijumptable *) intros. eapply exec_Sjumptable; eauto. congruence. + + (* Ireturn *) intros; eapply exec_Sreturn; simpl; eauto. + destruct or; simpl; auto. +Qed. + +Lemma sexec_final_complete i (f:function) pc st ge pge sp stack rs0 m0 t rs m s: + (fn_code f) ! pc = Some i -> + pc = st.(si_pc) -> + ssem_local ge sp (si_local st) rs0 m0 rs m -> + ssem_final pge ge sp pc stack f rs0 m0 (sexec_final i (si_local st)) rs m t s -> + siexec_inst i st = None -> + path_last_step ge pge stack f sp pc rs m t s. +Proof. + intros PC1 PC2 (PRE&MEM®) LAST HSIS. + destruct i as [ (* Inop *) | (* Iop *) | (* Iload *) | (* Istore *) + | (* Icall *) sig ros args res pc' + | (* Itailcall *) sig ros args + | (* Ibuiltin *) ef bargs br pc' + | (* Icond *) + | (* Ijumptable *) jr tbl + | (*Ireturn*) or]; + subst; try_simplify_someHyps; try (unfold sist_set_local in HSIS; try congruence); + inversion LAST; subst; clear LAST; simpl in * |- *. + + (* Icall *) + erewrite seval_list_sval_inj in * |- ; simpl; try_simplify_someHyps; auto. + intros; eapply exec_Icall; eauto. + destruct ros; simpl in * |- *; auto. + rewrite REG in * |- ; auto. + + (* Itailcall *) + intros HPC SMEM. erewrite seval_list_sval_inj in H10; auto. inv H10. + eapply exec_Itailcall; eauto. + destruct ros; simpl in * |- *; auto. + rewrite REG in * |- ; auto. + + (* Ibuiltin *) intros HPC SMEM. + eapply exec_Ibuiltin; eauto. + eapply seval_builtin_args_complete; eauto. + + (* Ijumptable *) intros HPC SMEM. + eapply exec_Ijumptable; eauto. + congruence. + + (* Ireturn *) + intros; subst. enough (v=regmap_optget or Vundef rs) as ->. + * eapply exec_Ireturn; eauto. + * intros; destruct or; simpl; congruence. +Qed. + +(** * Main function of the symbolic execution *) + +Definition init_sistate_local := {| si_pre:= fun _ _ _ _ => True; si_sreg:= fun r => Sinput r; si_smem:= Sinit |}. + +Definition init_sistate pc := {| si_pc:= pc; si_exits:=nil; si_local:= init_sistate_local |}. + +Lemma init_ssem_internal ge sp pc rs m: ssem_internal ge sp (init_sistate pc) rs m (mk_istate true pc rs m). +Proof. + unfold ssem_internal, ssem_local, all_fallthrough; simpl. intuition. +Qed. + +Definition sexec (f: function) (pc:node): option sstate := + SOME path <- (fn_path f)!pc IN + SOME st <- siexec_path path.(psize) f (init_sistate pc) IN + SOME i <- (fn_code f)!(st.(si_pc)) IN + Some (match siexec_inst i st with + | Some st' => {| internal := st'; final := Snone |} + | None => {| internal := st; final := sexec_final i st.(si_local) |} + end). + +Lemma final_node_path_simpl f path pc: + (fn_path f)!pc = Some path -> nth_default_succ_inst (fn_code f) path.(psize) pc <> None. +Proof. + intros; exploit final_node_path; eauto. + intros (i & NTH & DUM). + congruence. +Qed. + +Lemma symb_path_last_step i st st' ge pge stack (f:function) sp pc rs m t s: + (fn_code f) ! pc = Some i -> + pc = st.(si_pc) -> + siexec_inst i st = Some st' -> + path_last_step ge pge stack f sp pc rs m t s -> + exists mk_istate, + istep ge i sp rs m = Some mk_istate + /\ t = E0 + /\ s = (State stack f sp mk_istate.(ipc) mk_istate.(RTLpath.irs) mk_istate.(imem)). +Proof. + intros PC1 PC2 Hst' LAST; destruct LAST; subst; try_simplify_someHyps; simpl. +Qed. + +(* NB: each concrete execution can be executed on the symbolic state (produced from [sexec]) +(sexec is a correct over-approximation) +*) +Theorem sexec_correct f pc pge ge sp path stack rs m t s: + (fn_path f)!pc = Some path -> + path_step ge pge path.(psize) stack f sp rs m pc t s -> + exists st, sexec f pc = Some st /\ ssem pge ge sp st stack f rs m t s. +Proof. + Local Hint Resolve init_ssem_internal: core. + intros PATH STEP; unfold sexec; rewrite PATH; simpl. + lapply (final_node_path_simpl f path pc); eauto. intro WF. + exploit (siexec_path_correct_true ge sp path.(psize) f rs m (init_sistate pc) (mk_istate true pc rs m)); simpl; eauto. + { intros ABS. apply WF; unfold nth_default_succ_inst. rewrite ABS; auto. } + (destruct (nth_default_succ_inst (fn_code f) path.(psize) pc) as [i|] eqn: Hi; [clear WF|congruence]). + destruct STEP as [sti STEPS CONT|sti t s STEPS CONT LAST]; + (* intro Hst *) + (rewrite STEPS; unfold ssem_internal_opt2; destruct (siexec_path _ _ _) as [st|] eqn: Hst; try congruence); + (* intro SEM *) + (simpl; unfold ssem_internal; simpl; rewrite CONT; intro SEM); + (* intro Hi' *) + ( assert (Hi': (fn_code f) ! (si_pc st) = Some i); + [ unfold nth_default_succ_inst in Hi; + exploit siexec_path_default_succ; eauto; simpl; + intros DEF; rewrite DEF in Hi; auto + | clear Hi; rewrite Hi' ]); + (* eexists *) + (eexists; constructor; eauto). + - (* early *) + eapply ssem_early; eauto. + unfold ssem_internal; simpl; rewrite CONT. + destruct (siexec_inst i st) as [st'|] eqn: Hst'; simpl; eauto. + destruct SEM as (ext & lx & SEM & ALLFU). exists ext, lx. + constructor; auto. eapply siexec_inst_preserves_allfu; eauto. + - destruct SEM as (SEM & PC & HNYE). + destruct (siexec_inst i st) as [st'|] eqn: Hst'; simpl. + + (* normal on Snone *) + rewrite <- PC in LAST. + exploit symb_path_last_step; eauto; simpl. + intros (mk_istate & ISTEP & Ht & Hs); subst. + exploit siexec_inst_correct; eauto. simpl. + erewrite Hst', ISTEP; simpl. + clear LAST CONT STEPS PC SEM HNYE Hst Hi' Hst' ISTEP st sti i. + intro SEM; destruct (mk_istate.(icontinue)) eqn: CONT. + { (* icontinue mk_istate = true *) + eapply ssem_normal; simpl; eauto. + unfold ssem_internal in SEM. + rewrite CONT in SEM. + destruct SEM as (SEM & PC & HNYE). + rewrite <- PC. + eapply exec_Snone. } + { eapply ssem_early; eauto. } + + (* normal non-Snone instruction *) + eapply ssem_normal; eauto. + * unfold ssem_internal; simpl; rewrite CONT; intuition. + * simpl. eapply sexec_final_correct; eauto. + rewrite PC; auto. +Qed. + +(* TODO: déplacer les trucs sur equiv_stackframe dans RTLpath ? *) +Inductive equiv_stackframe: stackframe -> stackframe -> Prop := + | equiv_stackframe_intro res f sp pc rs1 rs2 + (EQUIV: forall r : positive, rs1 !! r = rs2 !! r): + equiv_stackframe (Stackframe res f sp pc rs1) (Stackframe res f sp pc rs2). + +Inductive equiv_state: state -> state -> Prop := + | State_equiv stack f sp pc rs1 m rs2 + (EQUIV: forall r, rs1#r = rs2#r): + equiv_state (State stack f sp pc rs1 m) (State stack f sp pc rs2 m) + | Call_equiv stk stk' f args m + (STACKS: list_forall2 equiv_stackframe stk stk'): + equiv_state (Callstate stk f args m) (Callstate stk' f args m) + | Return_equiv stk stk' v m + (STACKS: list_forall2 equiv_stackframe stk stk'): + equiv_state (Returnstate stk v m) (Returnstate stk' v m). + +Lemma equiv_stackframe_refl stf: equiv_stackframe stf stf. +Proof. + destruct stf. constructor; auto. +Qed. + +Lemma equiv_stack_refl stk: list_forall2 equiv_stackframe stk stk. +Proof. + Local Hint Resolve equiv_stackframe_refl: core. + induction stk; simpl; constructor; auto. +Qed. + +Lemma equiv_state_refl s: equiv_state s s. +Proof. + Local Hint Resolve equiv_stack_refl: core. + induction s; simpl; constructor; auto. +Qed. + +(* +Lemma equiv_stackframe_trans stf1 stf2 stf3: + equiv_stackframe stf1 stf2 -> equiv_stackframe stf2 stf3 -> equiv_stackframe stf1 stf3. +Proof. + destruct 1; intros EQ; inv EQ; try econstructor; eauto. + intros; eapply eq_trans; eauto. +Qed. + +Lemma equiv_stack_trans stk1 stk2: + list_forall2 equiv_stackframe stk1 stk2 -> + forall stk3, list_forall2 equiv_stackframe stk2 stk3 -> + list_forall2 equiv_stackframe stk1 stk3. +Proof. + Local Hint Resolve equiv_stackframe_trans. + induction 1; intros stk3 EQ; inv EQ; econstructor; eauto. +Qed. + +Lemma equiv_state_trans s1 s2 s3: equiv_state s1 s2 -> equiv_state s2 s3 -> equiv_state s1 s3. +Proof. + Local Hint Resolve equiv_stack_trans. + destruct 1; intros EQ; inv EQ; econstructor; eauto. + intros; eapply eq_trans; eauto. +Qed. +*) + +Lemma regmap_setres_eq (rs rs': regset) res vres: + (forall r, rs # r = rs' # r) -> + forall r, (regmap_setres res vres rs) # r = (regmap_setres res vres rs') # r. +Proof. + intros RSEQ r. destruct res; simpl; try congruence. + destruct (peq x r). + - subst. repeat (rewrite Regmap.gss). reflexivity. + - repeat (rewrite Regmap.gso); auto. +Qed. + +Lemma ssem_final_equiv pge ge sp (f:function) st sv stack rs0 m0 t rs1 rs2 m s: + ssem_final pge ge sp st stack f rs0 m0 sv rs1 m t s -> + (forall r, rs1#r = rs2#r) -> + exists s', equiv_state s s' /\ ssem_final pge ge sp st stack f rs0 m0 sv rs2 m t s'. +Proof. + Local Hint Resolve equiv_stack_refl: core. + destruct 1. + - (* Snone *) intros; eexists; econstructor. + + eapply State_equiv; eauto. + + eapply exec_Snone. + - (* Scall *) + intros; eexists; econstructor. + 2: { eapply exec_Scall; eauto. } + apply Call_equiv; auto. + repeat (constructor; auto). + - (* Stailcall *) + intros; eexists; econstructor; [| eapply exec_Stailcall; eauto]. + apply Call_equiv; auto. + - (* Sbuiltin *) + intros; eexists; econstructor; [| eapply exec_Sbuiltin; eauto]. + constructor. eapply regmap_setres_eq; eauto. + - (* Sjumptable *) + intros; eexists; econstructor; [| eapply exec_Sjumptable; eauto]. + constructor. assumption. + - (* Sreturn *) + intros; eexists; econstructor; [| eapply exec_Sreturn; eauto]. + eapply equiv_state_refl; eauto. +Qed. + +Lemma siexec_inst_early_exit_absurd i st st' ge sp rs m rs' m' pc': + siexec_inst i st = Some st' -> + (exists ext lx, ssem_exit ge sp ext rs m rs' m' pc' /\ + all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs m) -> + all_fallthrough ge sp (si_exits st') rs m -> + False. +Proof. + intros SIEXEC (ext & lx & SSEME & ALLFU) ALLF. destruct ALLFU as (TAIL & _). + exploit siexec_inst_add_exits; eauto. destruct 1 as [SIEQ | (ext0 & SIEQ)]. + - rewrite SIEQ in *. eapply all_fallthrough_noexit. eauto. 2: eapply ALLF. eapply is_tail_in. eassumption. + - rewrite SIEQ in *. eapply all_fallthrough_noexit. eauto. 2: eapply ALLF. eapply is_tail_in. + constructor. eassumption. +Qed. + +Lemma is_tail_false {A: Type}: forall (l: list A) a, is_tail (a::l) nil -> False. +Proof. + intros. eapply is_tail_incl in H. unfold incl in H. pose (H a). + assert (In a (a::l)) by (constructor; auto). assert (In a nil) by auto. apply in_nil in H1. + contradiction. +Qed. + +Lemma cons_eq_false {A: Type}: forall (l: list A) a, + a :: l = l -> False. +Proof. + induction l; intros. + - discriminate. + - inv H. apply IHl in H2. contradiction. +Qed. + +Lemma app_cons_nil_eq {A: Type}: forall l' l (a:A), + (l' ++ a :: nil) ++ l = l' ++ a::l. +Proof. + induction l'; intros. + - simpl. reflexivity. + - simpl. rewrite IHl'. reflexivity. +Qed. + +Lemma app_eq_false {A: Type}: forall l (l': list A) a, + l' ++ a :: l = l -> False. +Proof. + induction l; intros. + - apply app_eq_nil in H. destruct H as (_ & H). apply cons_eq_false in H. contradiction. + - destruct l' as [|a' l']. + + simpl in H. apply cons_eq_false in H. contradiction. + + rewrite <- app_comm_cons in H. inv H. + apply (IHl (l' ++ (a0 :: nil)) a). rewrite app_cons_nil_eq. assumption. +Qed. + +Lemma is_tail_false_gen {A: Type}: forall (l: list A) l' a, is_tail (l'++(a::l)) l -> False. +Proof. + induction l. + - intros. destruct l' as [|a' l']. + + simpl in H. apply is_tail_false in H. contradiction. + + rewrite <- app_comm_cons in H. apply is_tail_false in H. contradiction. + - intros. inv H. + + apply app_eq_false in H2. contradiction. + + apply (IHl (l' ++ (a0 :: nil)) a). rewrite app_cons_nil_eq. assumption. +Qed. + +Lemma is_tail_eq {A: Type}: forall (l l': list A), + is_tail l' l -> + is_tail l l' -> + l = l'. +Proof. + destruct l as [|a l]; intros l' ITAIL ITAIL'. + - destruct l' as [|i' l']; auto. apply is_tail_false in ITAIL. contradiction. + - inv ITAIL; auto. + destruct l' as [|i' l']. { apply is_tail_false in ITAIL'. contradiction. } + exploit is_tail_trans. eapply ITAIL'. eauto. intro ABSURD. + apply (is_tail_false_gen l nil a) in ABSURD. contradiction. +Qed. + +(* NB: each execution of a symbolic state (produced from [sexec]) represents a concrete execution + (sexec is exact). +*) +Theorem sexec_exact f pc pge ge sp path stack st rs m t s1: + (fn_path f)!pc = Some path -> + sexec f pc = Some st -> + ssem pge ge sp st stack f rs m t s1 -> + exists s2, path_step ge pge path.(psize) stack f sp rs m pc t s2 /\ + equiv_state s1 s2. +Proof. + Local Hint Resolve init_ssem_internal: core. + unfold sexec; intros PATH SSTEP SEM; rewrite PATH in SSTEP. + lapply (final_node_path_simpl f path pc); eauto. intro WF. + exploit (siexec_path_correct_true ge sp path.(psize) f rs m (init_sistate pc) (mk_istate true pc rs m)); simpl; eauto. + { intros ABS. apply WF; unfold nth_default_succ_inst. rewrite ABS; auto. } + (destruct (nth_default_succ_inst (fn_code f) path.(psize) pc) as [i|] eqn: Hi; [clear WF|congruence]). + unfold nth_default_succ_inst in Hi. + destruct (siexec_path path.(psize) f (init_sistate pc)) as [st0|] eqn: Hst0; simpl. + 2:{ (* absurd case *) + exploit siexec_path_WF; eauto. + simpl; intros NDS; rewrite NDS in Hi; congruence. } + exploit siexec_path_default_succ; eauto; simpl. + intros NDS; rewrite NDS in Hi. + rewrite Hi in SSTEP. + intros ISTEPS. try_simplify_someHyps. + destruct (siexec_inst i st0) as [st'|] eqn:Hst'; simpl. + + (* exit on Snone instruction *) + assert (SEM': t = E0 /\ exists is, ssem_internal ge sp st' rs m is + /\ s1 = (State stack f sp (if (icontinue is) then (si_pc st') else (ipc is)) (irs is) (imem is))). + { destruct SEM as [is CONT SEM|is t s CONT SEM1 SEM2]; simpl in * |- *. + - repeat (econstructor; eauto). + rewrite CONT; eauto. + - inversion SEM2. repeat (econstructor; eauto). + rewrite CONT; eauto. } + clear SEM; subst. destruct SEM' as [X (is & SEM & X')]; subst. + intros. + destruct (isteps ge (psize path) f sp rs m pc) as [is0|] eqn:RISTEPS; simpl in *. + * unfold ssem_internal in ISTEPS. destruct (icontinue is0) eqn: ICONT0. + ** (* icontinue is0=true: path_step by normal_exit *) + destruct ISTEPS as (SEMis0&H1&H2). + rewrite H1 in * |-. + exploit siexec_inst_correct; eauto. + rewrite Hst'; simpl. + intros; exploit ssem_internal_opt_determ; eauto. + destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). + eexists. econstructor 1. + *** eapply exec_normal_exit; eauto. + eapply exec_istate; eauto. + *** rewrite EQ1. + enough ((ipc st) = (if icontinue st then si_pc st' else ipc is)) as ->. + { rewrite EQ2, EQ4. eapply State_equiv; auto. } + destruct (icontinue st) eqn:ICONT; auto. + exploit siexec_inst_default_succ; eauto. + erewrite istep_normal_exit; eauto. + try_simplify_someHyps. + ** (* The concrete execution has not reached "i" => early exit *) + unfold ssem_internal in SEM. + destruct (icontinue is) eqn:ICONT. + { destruct SEM as (SEML & SIPC & ALLF). + exploit siexec_inst_early_exit_absurd; eauto. contradiction. } + + eexists. econstructor 1. + *** eapply exec_early_exit; eauto. + *** destruct ISTEPS as (ext & lx & SSEME & ALLFU). destruct SEM as (ext' & lx' & SSEME' & ALLFU'). + eapply siexec_inst_preserves_allfu in ALLFU; eauto. + exploit ssem_exit_fallthrough_upto_exit; eauto. + exploit ssem_exit_fallthrough_upto_exit. eapply SSEME. eapply ALLFU. eapply ALLFU'. + intros ITAIL ITAIL'. apply is_tail_eq in ITAIL; auto. clear ITAIL'. + inv ITAIL. exploit ssem_exit_determ. eapply SSEME. eapply SSEME'. intros (IPCEQ & IRSEQ & IMEMEQ). + rewrite <- IPCEQ. rewrite <- IMEMEQ. constructor. congruence. + * (* The concrete execution has not reached "i" => abort case *) + eapply siexec_inst_preserves_sabort in ISTEPS; eauto. + exploit ssem_internal_exclude_sabort; eauto. contradiction. + + destruct SEM as [is CONT SEM|is t s CONT SEM1 SEM2]; simpl in * |- *. + - (* early exit *) + intros. + exploit ssem_internal_opt_determ; eauto. + destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). + eexists. econstructor 1. + * eapply exec_early_exit; eauto. + * rewrite EQ2, EQ4; eapply State_equiv. auto. + - (* normal exit non-Snone instruction *) + intros. + exploit ssem_internal_opt_determ; eauto. + destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). + unfold ssem_internal in SEM1. + rewrite CONT in SEM1. destruct SEM1 as (SEM1 & PC0 & NYE0). + exploit ssem_final_equiv; eauto. + clear SEM2; destruct 1 as (s' & Ms' & SEM2). + rewrite ! EQ4 in * |-; clear EQ4. + rewrite ! EQ2 in * |-; clear EQ2. + exists s'; intuition. + eapply exec_normal_exit; eauto. + eapply sexec_final_complete; eauto. + * congruence. + * unfold ssem_local in * |- *. + destruct SEM1 as (A & B & C). constructor; [|constructor]; eauto. + intro r. congruence. + * congruence. +Qed. + +(** * Simulation of RTLpath code w.r.t symbolic execution *) + +Section SymbValPreserved. + +Variable ge ge': RTL.genv. + +Hypothesis symbols_preserved_RTL: forall s, Genv.find_symbol ge' s = Genv.find_symbol ge s. + +Hypothesis senv_preserved_RTL: Senv.equiv ge ge'. + +Lemma senv_find_symbol_preserved id: + Senv.find_symbol ge id = Senv.find_symbol ge' id. +Proof. + destruct senv_preserved_RTL as (A & B & C). congruence. +Qed. + +Lemma senv_symbol_address_preserved id ofs: + Senv.symbol_address ge id ofs = Senv.symbol_address ge' id ofs. +Proof. + unfold Senv.symbol_address. rewrite senv_find_symbol_preserved. + reflexivity. +Qed. + +Lemma seval_preserved sp sv rs0 m0: + seval_sval ge sp sv rs0 m0 = seval_sval ge' sp sv rs0 m0. +Proof. + Local Hint Resolve symbols_preserved_RTL: core. + induction sv using sval_mut with (P0 := fun lsv => seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv rs0 m0) + (P1 := fun sm => seval_smem ge sp sm rs0 m0 = seval_smem ge' sp sm rs0 m0); simpl; auto. + + rewrite IHsv; clear IHsv. destruct (seval_list_sval _ _ _ _); auto. + rewrite IHsv0; clear IHsv0. destruct (seval_smem _ _ _ _); auto. + erewrite eval_operation_preserved; eauto. + + rewrite IHsv0; clear IHsv0. destruct (seval_list_sval _ _ _ _); auto. + erewrite <- eval_addressing_preserved; eauto. + destruct (eval_addressing _ sp _ _); auto. + rewrite IHsv; auto. + + rewrite IHsv; clear IHsv. destruct (seval_sval _ _ _ _); auto. + rewrite IHsv0; auto. + + rewrite IHsv0; clear IHsv0. destruct (seval_list_sval _ _ _ _); auto. + erewrite <- eval_addressing_preserved; eauto. + destruct (eval_addressing _ sp _ _); auto. + rewrite IHsv; clear IHsv. destruct (seval_smem _ _ _ _); auto. + rewrite IHsv1; auto. +Qed. + +Lemma seval_builtin_arg_preserved sp m rs0 m0: + forall bs varg, + seval_builtin_arg ge sp m rs0 m0 bs varg -> + seval_builtin_arg ge' sp m rs0 m0 bs varg. +Proof. + induction 1. + all: try (constructor; auto). + - rewrite <- seval_preserved. assumption. + - rewrite <- senv_symbol_address_preserved. assumption. + - rewrite senv_symbol_address_preserved. eapply seval_BA_addrglobal. +Qed. + +Lemma seval_builtin_args_preserved sp m rs0 m0 lbs vargs: + seval_builtin_args ge sp m rs0 m0 lbs vargs -> + seval_builtin_args ge' sp m rs0 m0 lbs vargs. +Proof. + induction 1; constructor; eauto. + eapply seval_builtin_arg_preserved; auto. +Qed. + +Lemma list_sval_eval_preserved sp lsv rs0 m0: + seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv rs0 m0. +Proof. + induction lsv; simpl; auto. + rewrite seval_preserved. destruct (seval_sval _ _ _ _); auto. + rewrite IHlsv; auto. +Qed. + +Lemma smem_eval_preserved sp sm rs0 m0: + seval_smem ge sp sm rs0 m0 = seval_smem ge' sp sm rs0 m0. +Proof. + induction sm; simpl; auto. + rewrite list_sval_eval_preserved. destruct (seval_list_sval _ _ _ _); auto. + erewrite <- eval_addressing_preserved; eauto. + destruct (eval_addressing _ sp _ _); auto. + rewrite IHsm; clear IHsm. destruct (seval_smem _ _ _ _); auto. + rewrite seval_preserved; auto. +Qed. + +Lemma seval_condition_preserved sp cond lsv sm rs0 m0: + seval_condition ge sp cond lsv sm rs0 m0 = seval_condition ge' sp cond lsv sm rs0 m0. +Proof. + unfold seval_condition. + rewrite list_sval_eval_preserved. destruct (seval_list_sval _ _ _ _); auto. + rewrite smem_eval_preserved; auto. +Qed. + +End SymbValPreserved. + +Require Import RTLpathLivegen RTLpathLivegenproof. + +(** * DEFINITION OF SIMULATION BETWEEN (ABSTRACT) SYMBOLIC EXECUTIONS +*) + +Definition istate_simulive alive (srce: PTree.t node) (is1 is2: istate): Prop := + is1.(icontinue) = is2.(icontinue) + /\ eqlive_reg alive is1.(irs) is2.(irs) + /\ is1.(imem) = is2.(imem). + +Definition istate_simu f (srce: PTree.t node) is1 is2: Prop := + if is1.(icontinue) then + (* TODO: il faudra raffiner le (fun _ => True) si on veut autoriser l'oracle à + ajouter du "code mort" sur des registres non utilisés (loop invariant code motion à la David) + Typiquement, pour connaître la frame des registres vivants, il faudra faire une propagation en arrière + sur la dernière instruction du superblock. *) + istate_simulive (fun _ => True) srce is1 is2 + else + exists path, f.(fn_path)!(is1.(ipc)) = Some path + /\ istate_simulive (fun r => Regset.In r path.(input_regs)) srce is1 is2 + /\ srce!(is2.(ipc)) = Some is1.(ipc). + +Record simu_proof_context {f1: RTLpath.function} := { + liveness_hyps: liveness_ok_function f1; + the_ge1: RTL.genv; + the_ge2: RTL.genv; + genv_match: forall s, Genv.find_symbol the_ge1 s = Genv.find_symbol the_ge2 s; + the_sp: val; + the_rs0: regset; + the_m0: mem +}. +Arguments simu_proof_context: clear implicits. + +(* NOTE: a pure semantic definition on [sistate], for a total freedom in refinements *) +Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) (st1 st2: sistate) (ctx: simu_proof_context f): Prop := + forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) st1 (the_rs0 ctx) (the_m0 ctx) is1 -> + exists is2, ssem_internal (the_ge2 ctx) (the_sp ctx) st2 (the_rs0 ctx) (the_m0 ctx) is2 + /\ istate_simu f dm is1 is2. + +Definition opt_simu {A} (o1: option A) (o2: option A) := + o1 <> None -> o2 = o1. + +Lemma opt_simu_Some {A} (a:A) (o1: option A) (o2: option A): + opt_simu o1 o2 -> o1 = Some a -> o2 = Some a. +Proof. + unfold opt_simu. intros H1 H2; subst; rewrite H1; congruence. +Qed. + +Inductive svident_simu (f: RTLpath.function) (ctx: simu_proof_context f): (sval + ident) -> (sval + ident) -> Prop := + | Sleft_simu sv1 sv2: + opt_simu (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) + (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) + -> svident_simu f ctx (inl sv1) (inl sv2) + | Sright_simu id1 id2: + id1 = id2 + -> svident_simu f ctx (inr id1) (inr id2) + . + + +Fixpoint ptree_get_list (pt: PTree.t node) (lp: list positive) : option (list positive) := + match lp with + | nil => Some nil + | p1::lp => SOME p2 <- pt!p1 IN + SOME lp2 <- (ptree_get_list pt lp) IN + Some (p2 :: lp2) + end. + +Lemma ptree_get_list_nth dm p2: forall lp2 lp1, + ptree_get_list dm lp2 = Some lp1 -> + forall n, list_nth_z lp2 n = Some p2 -> + exists p1, + list_nth_z lp1 n = Some p1 /\ dm ! p2 = Some p1. +Proof. + induction lp2. + - simpl. intros. inv H. simpl in *. discriminate. + - intros lp1 PGL n LNZ. simpl in PGL. explore. + inv LNZ. destruct (zeq n 0) eqn:ZEQ. + + subst. inv H0. exists n0. simpl; constructor; auto. + + exploit IHlp2; eauto. intros (p1 & LNZ & DMEQ). + eexists. simpl. rewrite ZEQ. + constructor; eauto. +Qed. + +Lemma ptree_get_list_nth_rev dm p1: forall lp2 lp1, + ptree_get_list dm lp2 = Some lp1 -> + forall n, list_nth_z lp1 n = Some p1 -> + exists p2, + list_nth_z lp2 n = Some p2 /\ dm ! p2 = Some p1. +Proof. + induction lp2. + - simpl. intros. inv H. simpl in *. discriminate. + - intros lp1 PGL n LNZ. simpl in PGL. explore. + inv LNZ. destruct (zeq n 0) eqn:ZEQ. + + subst. inv H0. exists a. simpl; constructor; auto. + + exploit IHlp2; eauto. intros (p2 & LNZ & DMEQ). + eexists. simpl. rewrite ZEQ. + constructor; eauto. congruence. +Qed. + +(* NOTE: we need to mix semantical simulation and syntactic definition on [sfval] in order to abstract the [match_states] *) +Inductive sfval_simu (dm: PTree.t node) (f: RTLpath.function) (opc1 opc2: node) (ctx: simu_proof_context f): sfval -> sfval -> Prop := + | Snone_simu: + dm!opc2 = Some opc1 -> + sfval_simu dm f opc1 opc2 ctx Snone Snone + | Scall_simu sig svos1 svos2 lsv1 lsv2 res pc1 pc2: + dm!pc2 = Some pc1 -> + svident_simu f ctx svos1 svos2 -> + opt_simu (seval_list_sval (the_ge1 ctx) (the_sp ctx) lsv1 (the_rs0 ctx) (the_m0 ctx)) + (seval_list_sval (the_ge2 ctx) (the_sp ctx) lsv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Scall sig svos1 lsv1 res pc1) (Scall sig svos2 lsv2 res pc2) + | Stailcall_simu sig svos1 svos2 lsv1 lsv2: + svident_simu f ctx svos1 svos2 -> + opt_simu (seval_list_sval (the_ge1 ctx) (the_sp ctx) lsv1 (the_rs0 ctx) (the_m0 ctx)) + (seval_list_sval (the_ge2 ctx) (the_sp ctx) lsv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Stailcall sig svos1 lsv1) (Stailcall sig svos2 lsv2) + | Sbuiltin_simu ef lbs1 lbs2 br pc1 pc2: + dm!pc2 = Some pc1 -> + lbs1 = lbs2 -> (* FIXME: TOO STRONG *) + sfval_simu dm f opc1 opc2 ctx (Sbuiltin ef lbs1 br pc1) (Sbuiltin ef lbs2 br pc2) + | Sjumptable_simu sv1 sv2 lpc1 lpc2: + ptree_get_list dm lpc2 = Some lpc1 -> + opt_simu (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) + (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Sjumptable sv1 lpc1) (Sjumptable sv2 lpc2) + | Sreturn_simu os: + sfval_simu dm f opc1 opc2 ctx (Sreturn os) (Sreturn os). + +Definition sstate_simu dm f (s1 s2: sstate) (ctx: simu_proof_context f): Prop := + sistate_simu dm f s1.(internal) s2.(internal) ctx + /\ sfval_simu dm f s1.(si_pc) s2.(si_pc) ctx s1.(final) s2.(final). + +Definition sexec_simu dm (f1 f2: RTLpath.function) pc1 pc2: Prop := + forall st1, sexec f1 pc1 = Some st1 -> + exists st2, sexec f2 pc2 = Some st2 /\ forall ctx, sstate_simu dm f1 st1 st2 ctx. + +(** Maybe it could be useful to develop a small theory here to help in decomposing the simulation test ? + +Here are intermediate definitions. + +*) + +Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := + forall is1, ssem_local (the_ge1 ctx) (the_sp ctx) sl1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) -> + exists is2, ssem_local (the_ge2 ctx) (the_sp ctx) sl2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) + /\ istate_simu f dm is1 is2. + +Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof_context f) (se1 se2: sistate_exit) := + (seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond se1) (si_scondargs se1) + (si_smem (si_elocal se1)) (the_rs0 ctx) (the_m0 ctx)) + = (seval_condition (the_ge2 ctx) (the_sp ctx) (si_cond se2) (si_scondargs se2) + (si_smem (si_elocal se2)) (the_rs0 ctx) (the_m0 ctx)) + /\ forall is1, + ssem_exit (the_ge1 ctx) (the_sp ctx) se1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) (ipc is1) -> + exists is2, + ssem_exit (the_ge2 ctx) (the_sp ctx) se2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) (ipc is2) + /\ istate_simu f dm is1 is2. + +Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := + list_forall2 (siexit_simu dm f ctx) lse1 lse2. + diff --git a/scheduling/RTLpathScheduler.v b/scheduling/RTLpathScheduler.v new file mode 100644 index 00000000..b70c1685 --- /dev/null +++ b/scheduling/RTLpathScheduler.v @@ -0,0 +1,333 @@ +(** RTLpath Scheduling from an external oracle. + +This module is inspired from [Duplicate] and [Duplicateproof] + +*) + +Require Import AST Linking Values Maps Globalenvs Smallstep Registers. +Require Import Coqlib Maps Events Errors Op. +Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory RTLpathSE_impl_junk. + + +Notation "'ASSERT' A 'WITH' MSG 'IN' B" := (if A then B else Error (msg MSG)) + (at level 200, A at level 100, B at level 200) + : error_monad_scope. + +Local Open Scope error_monad_scope. +Local Open Scope positive_scope. + +(** External oracle returning the new RTLpath function and a mapping of new path_entries to old path_entries + +NB: the new RTLpath function is generated from the fn_code, the fn_entrypoint and the fn_path +It requires to check that the path structure is wf ! + +*) + +(* Returns: new code, new entrypoint, new pathmap, revmap + * Indeed, the entrypoint might not be the same if the entrypoint node is moved further down + * a path ; same reasoning for the pathmap *) +Axiom untrusted_scheduler: RTLpath.function -> code * node * path_map * (PTree.t node). + +Extract Constant untrusted_scheduler => "RTLpathScheduleraux.scheduler". + +Program Definition function_builder (tfr: RTL.function) (tpm: path_map) : + { r : res RTLpath.function | forall f', r = OK f' -> fn_RTL f' = tfr} := + match RTLpathLivegen.function_checker tfr tpm with + | false => Error (msg "In function_builder: (tfr, tpm) is not wellformed") + | true => OK {| fn_RTL := tfr; fn_path := tpm |} + end. +Next Obligation. + apply function_checker_path_entry. auto. +Defined. Next Obligation. + apply function_checker_wellformed_path_map. auto. +Defined. + +Definition entrypoint_check (dm: PTree.t node) (fr tfr: RTL.function) : res unit := + match dm ! (fn_entrypoint tfr) with + | None => Error (msg "No mapping for (entrypoint tfr)") + | Some etp => if (Pos.eq_dec (fn_entrypoint fr) etp) then OK tt + else Error (msg "Entrypoints do not match") + end. + +Lemma entrypoint_check_correct fr tfr dm: + entrypoint_check dm fr tfr = OK tt -> + dm ! (fn_entrypoint tfr) = Some (fn_entrypoint fr). +Proof. + unfold entrypoint_check. explore; try discriminate. congruence. +Qed. + +Definition path_entry_check_single (pm tpm: path_map) (m: node * node) := + let (pc2, pc1) := m in + match (tpm ! pc2) with + | None => Error (msg "pc2 isn't an entry of tpm") + | Some _ => + match (pm ! pc1) with + | None => Error (msg "pc1 isn't an entry of pm") + | Some _ => OK tt + end + end. + +Lemma path_entry_check_single_correct pm tpm pc1 pc2: + path_entry_check_single pm tpm (pc2, pc1) = OK tt -> + path_entry tpm pc2 /\ path_entry pm pc1. +Proof. + unfold path_entry_check_single. intro. explore. + constructor; congruence. +Qed. + +(* Inspired from Duplicate.verify_mapping_rec *) +Fixpoint path_entry_check_rec (pm tpm: path_map) lm := + match lm with + | nil => OK tt + | m :: lm => do u1 <- path_entry_check_single pm tpm m; + do u2 <- path_entry_check_rec pm tpm lm; + OK tt + end. + +Lemma path_entry_check_rec_correct pm tpm pc1 pc2: forall lm, + path_entry_check_rec pm tpm lm = OK tt -> + In (pc2, pc1) lm -> + path_entry tpm pc2 /\ path_entry pm pc1. +Proof. + induction lm. + - simpl. intuition. + - simpl. intros. explore. destruct H0. + + subst. eapply path_entry_check_single_correct; eauto. + + eapply IHlm; assumption. +Qed. + +Definition path_entry_check (dm: PTree.t node) (pm tpm: path_map) := path_entry_check_rec pm tpm (PTree.elements dm). + +Lemma path_entry_check_correct dm pm tpm: + path_entry_check dm pm tpm = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + path_entry tpm pc2 /\ path_entry pm pc1. +Proof. + unfold path_entry_check. intros. eapply PTree.elements_correct in H0. + eapply path_entry_check_rec_correct; eassumption. +Qed. + +Definition function_equiv_checker (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) : res unit := + let pm := fn_path f in + let fr := fn_RTL f in + let tpm := fn_path tf in + let tfr := fn_RTL tf in + do _ <- entrypoint_check dm fr tfr; + do _ <- path_entry_check dm pm tpm; + do _ <- simu_check dm f tf; + OK tt. + +Lemma function_equiv_checker_entrypoint f tf dm: + function_equiv_checker dm f tf = OK tt -> + dm ! (fn_entrypoint tf) = Some (fn_entrypoint f). +Proof. + unfold function_equiv_checker. intros. explore. + eapply entrypoint_check_correct; eauto. +Qed. + +Lemma function_equiv_checker_pathentry1 f tf dm: + function_equiv_checker dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + path_entry (fn_path tf) pc2. +Proof. + unfold function_equiv_checker. intros. explore. + exploit path_entry_check_correct. eassumption. all: eauto. intuition. +Qed. + +Lemma function_equiv_checker_pathentry2 f tf dm: + function_equiv_checker dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + path_entry (fn_path f) pc1. +Proof. + unfold function_equiv_checker. intros. explore. + exploit path_entry_check_correct. eassumption. all: eauto. intuition. +Qed. + +Lemma function_equiv_checker_correct f tf dm: + function_equiv_checker dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + sexec_simu dm f tf pc1 pc2. +Proof. + unfold function_equiv_checker. intros. explore. + eapply simu_check_correct; eauto. +Qed. + +Definition verified_scheduler (f: RTLpath.function) : res (RTLpath.function * (PTree.t node)) := + let (tctetpm, dm) := untrusted_scheduler f in + let (tcte, tpm) := tctetpm in + let (tc, te) := tcte in + let tfr := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in + do tf <- proj1_sig (function_builder tfr tpm); + do tt <- function_equiv_checker dm f tf; +(* do _ <- injective_checker dm; *) + OK (tf, dm). + +Theorem verified_scheduler_correct f tf dm: + verified_scheduler f = OK (tf, dm) -> + fn_sig f = fn_sig tf + /\ fn_params f = fn_params tf + /\ fn_stacksize f = fn_stacksize tf + /\ dm ! (fn_entrypoint tf) = Some (fn_entrypoint f) + /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> path_entry (fn_path f) pc1) + /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> path_entry (fn_path tf) pc2) + /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2) +(* /\ is_injective dm *) +. +Proof. + intros VERIF. unfold verified_scheduler in VERIF. explore. + Local Hint Resolve function_equiv_checker_entrypoint + function_equiv_checker_pathentry1 function_equiv_checker_pathentry2 + function_equiv_checker_correct (* injective_checker_correct *): core. + destruct (function_builder _ _) as [res H]; simpl in * |- *; auto. + apply H in EQ2. rewrite EQ2. simpl. + repeat (constructor; eauto). + - exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. +Qed. + +Record match_function (dupmap: PTree.t node) (f1 f2: RTLpath.function): Prop := { + preserv_fnsig: fn_sig f1 = fn_sig f2; + preserv_fnparams: fn_params f1 = fn_params f2; + preserv_fnstacksize: fn_stacksize f1 = fn_stacksize f2; + preserv_entrypoint: dupmap!(f2.(fn_entrypoint)) = Some f1.(fn_entrypoint); + dupmap_path_entry1: forall pc1 pc2, dupmap!pc2 = Some pc1 -> path_entry (fn_path f1) pc1; + dupmap_path_entry2: forall pc1 pc2, dupmap!pc2 = Some pc1 -> path_entry (fn_path f2) pc2; + dupmap_correct: forall pc1 pc2, dupmap!pc2 = Some pc1 -> sexec_simu dupmap f1 f2 pc1 pc2; +(* dupmap_injective: is_injective dupmap *) +}. + +Program Definition transf_function (f: RTLpath.function): + { r : res RTLpath.function | forall f', r = OK f' -> exists dm, match_function dm f f'} := + match (verified_scheduler f) with + | Error e => Error e + | OK (tf, dm) => OK tf + end. +Next Obligation. + exploit verified_scheduler_correct; eauto. + intros (A & B & C & D & E & F & G (* & H *)). + exists dm. econstructor; eauto. +Defined. + +Theorem match_function_preserves f f' dm: + match_function dm f f' -> + fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'. +Proof. + intros. + destruct H as [SIG PARAM SIZE ENTRY CORRECT]. + intuition. +Qed. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef (fun f => proj1_sig (transf_function f)) f. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. + +(** * Preservation proof *) + +Local Notation ext alive := (fun r => Regset.In r alive). + +Inductive match_fundef: RTLpath.fundef -> RTLpath.fundef -> Prop := + | match_Internal dupmap f f': match_function dupmap f f' -> match_fundef (Internal f) (Internal f') + | match_External ef: match_fundef (External ef) (External ef). + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + | match_stackframe_intro dupmap res f sp pc rs1 rs2 f' pc' path + (TRANSF: match_function dupmap f f') + (DUPLIC: dupmap!pc' = Some pc) + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: forall v, eqlive_reg (ext path.(input_regs)) (rs1 # res <- v) (rs2 # res <- v)): + match_stackframes (Stackframe res f sp pc rs1) (Stackframe res f' sp pc' rs2). + +Inductive match_states: state -> state -> Prop := + | match_states_intro dupmap st f sp pc rs1 rs2 m st' f' pc' path + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: match_function dupmap f f') + (DUPLIC: dupmap!pc' = Some pc) + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: eqlive_reg (ext path.(input_regs)) rs1 rs2): + match_states (State st f sp pc rs1 m) (State st' f' sp pc' rs2 m) + | match_states_call st st' f f' args m + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: match_fundef f f') + (LIVE: liveness_ok_fundef f): + match_states (Callstate st f args m) (Callstate st' f' args m) + | match_states_return st st' v m + (STACKS: list_forall2 match_stackframes st st'): + match_states (Returnstate st v m) (Returnstate st' v m). + +Lemma match_stackframes_equiv stf1 stf2 stf3: + match_stackframes stf1 stf2 -> equiv_stackframe stf2 stf3 -> match_stackframes stf1 stf3. +Proof. + destruct 1; intros EQ; inv EQ; try econstructor; eauto. + intros; eapply eqlive_reg_trans; eauto. + rewrite eqlive_reg_triv in * |-. + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + simpl; auto. +Qed. + +Lemma match_stack_equiv stk1 stk2: + list_forall2 match_stackframes stk1 stk2 -> + forall stk3, list_forall2 equiv_stackframe stk2 stk3 -> + list_forall2 match_stackframes stk1 stk3. +Proof. + Local Hint Resolve match_stackframes_equiv: core. + induction 1; intros stk3 EQ; inv EQ; econstructor; eauto. +Qed. + +Lemma match_states_equiv s1 s2 s3: match_states s1 s2 -> equiv_state s2 s3 -> match_states s1 s3. +Proof. + Local Hint Resolve match_stack_equiv: core. + destruct 1; intros EQ; inv EQ; econstructor; eauto. + intros; eapply eqlive_reg_triv_trans; eauto. +Qed. + +Lemma eqlive_match_stackframes stf1 stf2 stf3: + eqlive_stackframes stf1 stf2 -> match_stackframes stf2 stf3 -> match_stackframes stf1 stf3. +Proof. + destruct 1; intros MS; inv MS; try econstructor; eauto. + try_simplify_someHyps. intros; eapply eqlive_reg_trans; eauto. +Qed. + +Lemma eqlive_match_stack stk1 stk2: + list_forall2 eqlive_stackframes stk1 stk2 -> + forall stk3, list_forall2 match_stackframes stk2 stk3 -> + list_forall2 match_stackframes stk1 stk3. +Proof. + induction 1; intros stk3 MS; inv MS; econstructor; eauto. + eapply eqlive_match_stackframes; eauto. +Qed. + +Lemma eqlive_match_states s1 s2 s3: eqlive_states s1 s2 -> match_states s2 s3 -> match_states s1 s3. +Proof. + Local Hint Resolve eqlive_match_stack: core. + destruct 1; intros MS; inv MS; try_simplify_someHyps; econstructor; eauto. + eapply eqlive_reg_trans; eauto. +Qed. + +Lemma eqlive_stackframes_refl stf1 stf2: match_stackframes stf1 stf2 -> eqlive_stackframes stf1 stf1. +Proof. + destruct 1; econstructor; eauto. + intros; eapply eqlive_reg_refl; eauto. +Qed. + +Lemma eqlive_stacks_refl stk1 stk2: + list_forall2 match_stackframes stk1 stk2 -> list_forall2 eqlive_stackframes stk1 stk1. +Proof. + induction 1; simpl; econstructor; eauto. + eapply eqlive_stackframes_refl; eauto. +Qed. + +Lemma transf_fundef_correct f f': + transf_fundef f = OK f' -> match_fundef f f'. +Proof. + intros TRANSF; destruct f; simpl; monadInv TRANSF. + + destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. + eapply match_Internal; eauto. + + eapply match_External. +Qed. + diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml new file mode 100644 index 00000000..88f777a5 --- /dev/null +++ b/scheduling/RTLpathScheduleraux.ml @@ -0,0 +1,368 @@ +open RTLpath +open RTL +open Maps +open RTLpathLivegenaux +open Registers +open Camlcoq + +type superblock = { + instructions: P.t array; (* pointers to code instructions *) + (* each predicted Pcb has its attached liveins *) + (* This is indexed by the pc value *) + liveins: Regset.t PTree.t; + (* Union of the input_regs of the last successors *) + output_regs: Regset.t; + typing: RTLtyping.regenv +} + +let print_instructions insts code = + if (!debug_flag) then begin + dprintf "[ "; + List.iter ( + fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code)) + ) insts; dprintf "]" + end + +let print_superblock sb code = + let insts = sb.instructions in + let li = sb.liveins in + let outs = sb.output_regs in + begin + dprintf "{ instructions = "; print_instructions (Array.to_list insts) code; dprintf "\n"; + dprintf " liveins = "; print_ptree_regset li; dprintf "\n"; + dprintf " output_regs = "; print_regset outs; dprintf "}" + end + +let print_superblocks lsb code = + let rec f = function + | [] -> () + | sb :: lsb -> (print_superblock sb code; dprintf ",\n"; f lsb) + in begin + dprintf "[\n"; + f lsb; + dprintf "]" + end + +(* Adapted from backend/PrintRTL.ml: print_function *) +let print_code code = let open PrintRTL in let open Printf in + if (!debug_flag) then begin + fprintf stdout "{\n"; + let instrs = + List.sort + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) + (List.rev_map + (fun (pc, i) -> (P.to_int pc, i)) + (PTree.elements code)) in + List.iter (print_instruction stdout) instrs; + fprintf stdout "}" + end + +let print_arrayp arr = begin + dprintf "[| "; + Array.iter (fun n -> dprintf "%d, " (P.to_int n)) arr; + dprintf "|]" +end + +let get_superblocks code entry pm typing = + let visited = ref (PTree.map (fun n i -> false) code) in + let rec get_superblocks_rec pc = + let liveins = ref (PTree.empty) in + let rec follow pc n = + let inst = get_some @@ PTree.get pc code in + if (n == 0) then begin + (match (non_predicted_successors inst) with + | [pcout] -> + let live = (get_some @@ PTree.get pcout pm).input_regs in + liveins := PTree.set pc live !liveins + | _ -> ()); + ([pc], successors_inst inst) + end else + let nexts_from_exit = match (non_predicted_successors inst) with + | [pcout] -> + let live = (get_some @@ PTree.get pcout pm).input_regs in begin + liveins := PTree.set pc live !liveins; + [pcout] + end + | [] -> [] + | _ -> failwith "Having more than one non_predicted_successor is not handled" + in match (predicted_successor inst) with + | None -> failwith "Incorrect path" + | Some succ -> + let (insts, nexts) = follow succ (n-1) in (pc :: insts, nexts_from_exit @ nexts) + in if (get_some @@ PTree.get pc !visited) then [] + else begin + visited := PTree.set pc true !visited; + let pi = get_some @@ PTree.get pc pm in + let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in + let superblock = { instructions = Array.of_list insts; liveins = !liveins; + output_regs = pi.output_regs; typing = typing } in + superblock :: (List.concat @@ List.map get_superblocks_rec nexts) + end + in let lsb = get_superblocks_rec entry in begin + (* debug_flag := true; *) + dprintf "Superblocks identified:"; print_superblocks lsb code; dprintf "\n"; + (* debug_flag := false; *) + lsb +end + +(* TODO David *) +let schedule_superblock sb code = + if not !Clflags.option_fprepass + then sb.instructions + else + let old_flag = !debug_flag in + debug_flag := true; + print_endline "ORIGINAL SUPERBLOCK"; + print_superblock sb code; + debug_flag := old_flag; + let nr_instr = Array.length sb.instructions in + let trailer_length = + match PTree.get (sb.instructions.(nr_instr-1)) code with + | None -> 0 + | Some ii -> + match predicted_successor ii with + | Some _ -> 0 + | None -> 1 in + match PrepassSchedulingOracle.schedule_sequence + (Array.map (fun i -> + (match PTree.get i code with + | Some ii -> ii + | None -> failwith "RTLpathScheduleraux.schedule_superblock"), + (match PTree.get i sb.liveins with + | Some s -> s + | None -> Regset.empty)) + (Array.sub sb.instructions 0 (nr_instr-trailer_length))) with + | None -> sb.instructions + | Some order -> + let ins' = + Array.append + (Array.map (fun i -> sb.instructions.(i)) order) + (Array.sub sb.instructions (nr_instr-trailer_length) trailer_length) in + Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins'); + debug_flag := true; + print_instructions (Array.to_list ins') code; + debug_flag := old_flag; + flush stdout; + assert ((Array.length sb.instructions) = (Array.length ins')); + (*sb.instructions; *) + ins';; + + (* stub2: reverse function *) + (* + let reversed = Array.of_list @@ List.rev @@ Array.to_list (sb.instructions) in + let tmp = reversed.(0) in + let last_index = Array.length reversed - 1 in + begin + reversed.(0) <- reversed.(last_index); + reversed.(last_index) <- tmp; + reversed + end *) + (* stub: identity function *) + +(** + * Perform basic checks on the new order : + * - must have the same length as the old order + * - non basic instructions (call, tailcall, return, jumptable, non predicted CB) must not move + *) +let check_order code old_order new_order = begin + assert ((Array.length old_order) == (Array.length new_order)); + let length = Array.length new_order in + if length > 0 then + let last_inst = Array.get old_order (length - 1) in + let instr = get_some @@ PTree.get last_inst code in + match predicted_successor instr with + | None -> + if (last_inst != Array.get new_order (length - 1)) then + failwith "The last instruction of the superblock is not basic, but was moved" + | _ -> () +end + +type sinst = + (* Each middle instruction has a direct successor *) + (* A Smid can be the last instruction of a superblock, but a Send cannot be moved *) + | Smid of RTL.instruction * node + | Send of RTL.instruction + +let rinst_to_sinst inst = + match inst with + | Inop n -> Smid(inst, n) + | Iop (_,_,_,n) -> Smid(inst, n) + | Iload (_,_,_,_,_,n) -> Smid(inst, n) + | Istore (_,_,_,_,n) -> Smid(inst, n) + | Icond (_,_,n1,n2,p) -> ( + match p with + | Some true -> Smid(inst, n1) + | Some false -> Smid(inst, n2) + | None -> Send(inst) + ) + | Icall _ | Ibuiltin _ | Ijumptable _ | Itailcall _ | Ireturn _ -> Send(inst) + +let change_predicted_successor s = function + | Smid(i, n) -> Smid(i, s) + | Send _ -> failwith "Called change_predicted_successor on Send. Are you trying to move a non-basic instruction in the middle of the block?" + +(* Forwards the successor changes into an RTL instruction *) +let sinst_to_rinst = function + | Smid(inst, s) -> ( + match inst with + | Inop n -> Inop s + | Iop (a,b,c,n) -> Iop (a,b,c,s) + | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) + | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) + | Icond (a,b,n1,n2,p) -> ( + match p with + | Some true -> Icond(a, b, s, n2, p) + | Some false -> Icond(a, b, n1, s, p) + | None -> failwith "Non predicted Icond as a middle instruction!" + ) + | _ -> failwith "That instruction shouldn't be a middle instruction" + ) + | Send i -> i + +let apply_schedule code sb new_order = + let tc = ref code in + let old_order = sb.instructions in + begin + check_order code old_order new_order; + Array.iteri (fun i n' -> + let inst' = get_some @@ PTree.get n' code in + let iend = Array.length old_order - 1 in + let new_inst = + if (i == iend) then + let final_inst_node = Array.get old_order iend in + let sinst' = rinst_to_sinst inst' in + match sinst' with + (* The below assert fails if a Send is in the middle of the original superblock *) + | Send i -> (assert (final_inst_node == n'); i) + | Smid _ -> + let final_inst = get_some @@ PTree.get final_inst_node code in + match rinst_to_sinst final_inst with + | Smid (_, s') -> sinst_to_rinst @@ change_predicted_successor s' sinst' + | Send _ -> assert(false) (* should have failed earlier *) + else + sinst_to_rinst + (* this will fail if the moved instruction is a Send *) + @@ change_predicted_successor (Array.get old_order (i+1)) + @@ rinst_to_sinst inst' + in tc := PTree.set (Array.get old_order i) new_inst !tc + ) new_order; + !tc + end + + (* +let main_successors = function +| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n] +| Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> [n] +| Icond (_,_,n1,n2,p) -> ( + match p with + | Some true -> [n1; n2] + | Some false -> [n2; n1] + | None -> [n1; n2] ) +| Ijumptable _ | Itailcall _ | Ireturn _ -> [] + +let change_predicted_successor i s = match i with + | Itailcall _ | Ireturn _ -> failwith "Wrong instruction (5) - Tailcalls and returns should not be moved in the middle of a superblock" + | Ijumptable _ -> failwith "Wrong instruction (6) - Jumptables should not be moved in the middle of a superblock" + | Inop n -> Inop s + | Iop (a,b,c,n) -> Iop (a,b,c,s) + | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) + | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) + | Icall (a,b,c,d,n) -> Icall (a,b,c,d,s) + | Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s) + | Icond (a,b,n1,n2,p) -> ( + match p with + | Some true -> Icond (a,b,s,n2,p) + | Some false -> Icond (a,b,n1,s,p) + | None -> failwith "Predicted a successor for an Icond with p=None - unpredicted CB should not be moved in the middle of the superblock" + ) + +let rec change_successors i = function + | [] -> ( + match i with + | Itailcall _ | Ireturn _ -> i + | _ -> failwith "Wrong instruction (1)") + | [s] -> ( + match i with + | Inop n -> Inop s + | Iop (a,b,c,n) -> Iop (a,b,c,s) + | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) + | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) + | Icall (a,b,c,d,n) -> Icall (a,b,c,d,s) + | Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s) + | Ijumptable (a,[n]) -> Ijumptable (a,[s]) + | Icond (a,b,n1,n2,p) -> ( + match p with + | Some true -> Icond (a,b,s,n2,p) + | Some false -> Icond (a,b,n1,s,p) + | None -> failwith "Icond Wrong instruction (2) ; should not happen?" + ) + | _ -> failwith "Wrong instruction (2)") + | [s1; s2] -> ( + match i with + | Icond (a,b,n1,n2,p) -> Icond (a,b,s1,s2,p) + | Ijumptable (a, [n1; n2]) -> Ijumptable (a, [s1; s2]) + | _ -> change_successors i [s1]) + | ls -> ( + match i with + | Ijumptable (a, ln) -> begin + assert ((List.length ln) == (List.length ls)); + Ijumptable (a, ls) + end + | _ -> failwith "Wrong instruction (4)") + + +let apply_schedule code sb new_order = + let tc = ref code in + let old_order = sb.instructions in + let last_node = Array.get old_order (Array.length old_order - 1) in + let last_successors = main_successors + @@ get_some @@ PTree.get last_node code in + begin + check_order code old_order new_order; + Array.iteri (fun i n' -> + let inst' = get_some @@ PTree.get n' code in + let new_inst = + if (i == (Array.length old_order - 1)) then + change_successors inst' last_successors + else + change_predicted_successor inst' (Array.get old_order (i+1)) + in tc := PTree.set (Array.get old_order i) new_inst !tc + ) new_order; + !tc + end +*) + +let rec do_schedule code = function + | [] -> code + | sb :: lsb -> + let schedule = schedule_superblock sb code in + let new_code = apply_schedule code sb schedule in + begin + (* debug_flag := true; *) + dprintf "Old Code: "; print_code code; + dprintf "\nSchedule to apply: "; print_arrayp schedule; + dprintf "\nNew Code: "; print_code new_code; + dprintf "\n"; + (* debug_flag := false; *) + do_schedule new_code lsb + end + +let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK" + +let scheduler f = + let code = f.fn_RTL.fn_code in + let id_ptree = PTree.map (fun n i -> n) (f.fn_path) in + let entry = f.fn_RTL.fn_entrypoint in + let pm = f.fn_path in + let typing = get_ok @@ RTLtyping.type_function f.fn_RTL in + let lsb = get_superblocks code entry pm typing in + begin + (* debug_flag := true; *) + dprintf "Pathmap:\n"; dprintf "\n"; + print_path_map pm; + dprintf "Superblocks:\n"; + print_superblocks lsb code; dprintf "\n"; + (* debug_flag := false; *) + let tc = do_schedule code lsb in + (((tc, entry), pm), id_ptree) + end diff --git a/scheduling/RTLpathSchedulerproof.v b/scheduling/RTLpathSchedulerproof.v new file mode 100644 index 00000000..5c32847e --- /dev/null +++ b/scheduling/RTLpathSchedulerproof.v @@ -0,0 +1,341 @@ +Require Import AST Linking Values Maps Globalenvs Smallstep Registers. +Require Import Coqlib Maps Events Errors Op. +Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory. +Require Import RTLpathScheduler. + +Definition match_prog (p tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: program. +Variable tprog: program. + +Hypothesis TRANSL: match_prog prog tprog. + +Let pge := Genv.globalenv prog. +Let tpge := Genv.globalenv tprog. + +Hypothesis all_fundef_liveness_ok: forall b fd, Genv.find_funct_ptr pge b = Some fd -> liveness_ok_fundef fd. + +Lemma symbols_preserved s: Genv.find_symbol tpge s = Genv.find_symbol pge s. +Proof. + rewrite <- (Genv.find_symbol_match TRANSL). reflexivity. +Qed. + +Lemma senv_preserved: + Senv.equiv pge tpge. +Proof. + eapply (Genv.senv_match TRANSL). +Qed. + +Lemma functions_preserved: + forall (v: val) (f: fundef), + Genv.find_funct pge v = Some f -> + exists tf cunit, transf_fundef f = OK tf /\ Genv.find_funct tpge v = Some tf /\ linkorder cunit prog. +Proof. + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & A & B & C). + repeat eexists; intuition eauto. + + unfold incl; auto. + + eapply linkorder_refl. +Qed. + +Lemma function_ptr_preserved: + forall v f, + Genv.find_funct_ptr pge v = Some f -> + exists tf, + Genv.find_funct_ptr tpge v = Some tf /\ transf_fundef f = OK tf. +Proof. + intros. + exploit (Genv.find_funct_ptr_transf_partial TRANSL); eauto. +Qed. + +Lemma function_sig_preserved: + forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. +Proof. + intros. destruct f. + - simpl in H. monadInv H. + destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. + symmetry. + eapply match_function_preserves. + eassumption. + - simpl in H. monadInv H. reflexivity. +Qed. + +Theorem transf_initial_states: + forall s1, initial_state prog s1 -> + exists s2, initial_state tprog s2 /\ match_states s1 s2. +Proof. + intros. inv H. + exploit function_ptr_preserved; eauto. intros (tf & FIND & TRANSF). + exists (Callstate nil tf nil m0). + split. + - econstructor; eauto. + + intros; apply (Genv.init_mem_match TRANSL); assumption. + + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. + symmetry. eapply match_program_main. eauto. + + destruct f. + * monadInv TRANSF. rewrite <- H3. + destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. + symmetry; eapply match_function_preserves. eassumption. + * monadInv TRANSF. assumption. + - constructor; eauto. + + constructor. + + apply transf_fundef_correct; auto. +(* + eapply all_fundef_liveness_ok; eauto. *) +Qed. + +Theorem transf_final_states s1 s2 r: + final_state s1 r -> match_states s1 s2 -> final_state s2 r. +Proof. + unfold final_state. + intros H; inv H. + intros H; inv H; simpl in * |- *; try congruence. + inv H1. + destruct st; simpl in * |- *; try congruence. + inv STACKS. constructor. +Qed. + + +Let ge := Genv.globalenv (RTLpath.transf_program prog). +Let tge := Genv.globalenv (RTLpath.transf_program tprog). + +Lemma senv_sym x y: Senv.equiv x y -> Senv.equiv y x. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. + +Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. + +Lemma senv_preserved_RTL: + Senv.equiv ge tge. +Proof. + eapply senv_transitivity. { eapply senv_sym; eapply RTLpath.senv_preserved. } + eapply senv_transitivity. { eapply senv_preserved. } + eapply RTLpath.senv_preserved. +Qed. + +Lemma symbols_preserved_RTL s: Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + unfold tge, ge. erewrite RTLpath.symbols_preserved; eauto. + rewrite symbols_preserved. + erewrite RTLpath.symbols_preserved; eauto. +Qed. + +Program Definition mkctx sp rs0 m0 {f1: RTLpath.function} (hyp: liveness_ok_function f1) + : simu_proof_context f1 + := {| the_ge1:= ge; the_ge2 := tge; the_sp:=sp; the_rs0:=rs0; the_m0:=m0 |}. +Obligation 2. + erewrite symbols_preserved_RTL. eauto. +Qed. + +Lemma s_find_function_preserved f sp svos1 svos2 rs0 m0 fd + (LIVE: liveness_ok_function f): + (svident_simu f (mkctx sp rs0 m0 LIVE) svos1 svos2) -> + sfind_function pge ge sp svos1 rs0 m0 = Some fd -> + exists fd', sfind_function tpge tge sp svos2 rs0 m0 = Some fd' + /\ transf_fundef fd = OK fd' + /\ liveness_ok_fundef fd. +Proof. + Local Hint Resolve symbols_preserved_RTL: core. + unfold sfind_function. intros [sv1 sv2 SIMU|]; simpl in *. + + rewrite !(seval_preserved ge tge) in *; eauto. + destruct (seval_sval _ _ _ _); try congruence. + erewrite SIMU; try congruence. clear SIMU. + intros; exploit functions_preserved; eauto. + intros (fd' & cunit & (X1 & X2 & X3)). eexists. + repeat split; eauto. + eapply find_funct_liveness_ok; eauto. +(* intros. eapply all_fundef_liveness_ok; eauto. *) + + subst. rewrite symbols_preserved. destruct (Genv.find_symbol _ _); try congruence. + intros; exploit function_ptr_preserved; eauto. + intros (fd' & X). eexists. intuition eauto. +(* intros. eapply all_fundef_liveness_ok; eauto. *) +Qed. + +Lemma sistate_simu f dupmap sp st st' rs m is + (LIVE: liveness_ok_function f): + ssem_internal ge sp st rs m is -> + sistate_simu dupmap f st st' (mkctx sp rs m LIVE)-> + exists is', + ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap is is'. +Proof. + intros SEM X; eapply X; eauto. +Qed. + +Lemma ssem_final_simu dm f f' stk stk' sp st st' rs0 m0 sv sv' rs m t s + (LIVE: liveness_ok_function f): + match_function dm f f' -> + list_forall2 match_stackframes stk stk' -> + (* s_istate_simu f dupmap st st' -> *) + sfval_simu dm f st.(si_pc) st'.(si_pc) (mkctx sp rs0 m0 LIVE) sv sv' -> + ssem_final pge ge sp st.(si_pc) stk f rs0 m0 sv rs m t s -> + exists s', ssem_final tpge tge sp st'.(si_pc) stk' f' rs0 m0 sv' rs m t s' /\ match_states s s'. +Proof. + Local Hint Resolve transf_fundef_correct: core. + intros FUN STK (* SIS *) SFV. destruct SFV; intros SEM; inv SEM; simpl in *. + - (* Snone *) + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + eapply eqlive_reg_refl. + - (* Scall *) + exploit s_find_function_preserved; eauto. + intros (fd' & FIND & TRANSF & LIVE'). + erewrite <- function_sig_preserved; eauto. + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + + eapply opt_simu_Some; eauto. + + simpl. repeat (econstructor; eauto). + - (* Stailcall *) + exploit s_find_function_preserved; eauto. + intros (fd' & FIND & TRANSF & LIVE'). + erewrite <- function_sig_preserved; eauto. + eexists; split; econstructor; eauto. + + erewrite <- preserv_fnstacksize; eauto. + + eapply opt_simu_Some; eauto. + - (* Sbuiltin *) + pose senv_preserved_RTL as SRTL. + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + + eapply seval_builtin_args_preserved; eauto. + + eapply external_call_symbols_preserved; eauto. + + eapply eqlive_reg_refl. + - (* Sjumptable *) + exploit ptree_get_list_nth_rev; eauto. intros (p2 & LNZ & DM). + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + + eapply opt_simu_Some; eauto. + + eapply eqlive_reg_refl. + - (* Sreturn *) + eexists; split; econstructor; eauto. + + erewrite <- preserv_fnstacksize; eauto. + + destruct os; auto. + erewrite <- seval_preserved; eauto. +Qed. + +(* The main theorem on simulation of symbolic states ! *) +Theorem ssem_sstate_simu dm f f' stk stk' sp st st' rs m t s: + match_function dm f f' -> + liveness_ok_function f -> + list_forall2 match_stackframes stk stk' -> + ssem pge ge sp st stk f rs m t s -> + (forall ctx: simu_proof_context f, sstate_simu dm f st st' ctx) -> + exists s', ssem tpge tge sp st' stk' f' rs m t s' /\ match_states s s'. +Proof. + intros MFUNC LIVE STACKS SEM SIMU. + destruct (SIMU (mkctx sp rs m LIVE)) as (SIMU1 & SIMU2); clear SIMU. + destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl. + - (* sem_early *) + exploit sistate_simu; eauto. + unfold istate_simu; rewrite CONT. + intros (is' & SEM' & (path & PATH & (CONT' & RS' & M') & PC')). + exists (State stk' f' sp (ipc is') (irs is') (imem is')). + split. + + eapply ssem_early; auto. congruence. + + rewrite M'. econstructor; eauto. + - (* sem_normal *) + exploit sistate_simu; eauto. + unfold istate_simu; rewrite CONT. + intros (is' & SEM' & (CONT' & RS' & M')(* & DMEQ *)). + rewrite <- eqlive_reg_triv in RS'. + exploit ssem_final_simu; eauto. + clear SEM2; intros (s0 & SEM2 & MATCH0). + exploit ssem_final_equiv; eauto. + clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s1 & EQ & SEM2). + exists s1; split. + + eapply ssem_normal; eauto. + + eapply match_states_equiv; eauto. +Qed. + +Lemma exec_path_simulation dupmap path stk stk' f f' sp rs m pc pc' t s: + (fn_path f)!pc = Some path -> + path_step ge pge path.(psize) stk f sp rs m pc t s -> + list_forall2 match_stackframes stk stk' -> + dupmap ! pc' = Some pc -> + match_function dupmap f f' -> + liveness_ok_function f -> + exists path' s', (fn_path f')!pc' = Some path' /\ path_step tge tpge path'.(psize) stk' f' sp rs m pc' t s' /\ match_states s s'. +Proof. + intros PATH STEP STACKS DUPPC MATCHF LIVE. + exploit initialize_path. { eapply dupmap_path_entry2; eauto. } + intros (path' & PATH'). + exists path'. + exploit (sexec_correct f pc pge ge sp path stk rs m t s); eauto. + intros (st & SYMB & SEM); clear STEP. + exploit dupmap_correct; eauto. + clear SYMB; intros (st' & SYMB & SIMU). + exploit ssem_sstate_simu; eauto. + intros (s0 & SEM0 & MATCH). + exploit sexec_exact; eauto. + intros (s' & STEP' & EQ). + exists s'; intuition. + eapply match_states_equiv; eauto. +Qed. + +Lemma step_simulation s1 t s1' s2: + step ge pge s1 t s1' -> + match_states s1 s2 -> + exists s2', + step tge tpge s2 t s2' + /\ match_states s1' s2'. +Proof. + Local Hint Resolve eqlive_stacks_refl transf_fundef_correct: core. + destruct 1 as [path stack f sp rs m pc t s PATH STEP | | | ]; intros MS; inv MS. +(* exec_path *) + - try_simplify_someHyps. intros. + exploit path_step_eqlive; eauto. (* { intros. eapply all_fundef_liveness_ok; eauto. } *) + clear STEP EQUIV rs; intros (s2 & STEP & EQLIVE). + exploit exec_path_simulation; eauto. + clear STEP; intros (path' & s' & PATH' & STEP' & MATCH'). + exists s'; split. + + eapply exec_path; eauto. + + eapply eqlive_match_states; eauto. +(* exec_function_internal *) + - inv LIVE. + exploit initialize_path. { eapply (fn_entry_point_wf f). } + destruct 1 as (path & PATH). + inversion TRANSF as [f0 xf tf MATCHF|]; subst. eexists. split. + + eapply exec_function_internal. erewrite <- preserv_fnstacksize; eauto. + + erewrite preserv_fnparams; eauto. + econstructor; eauto. + { apply preserv_entrypoint; auto. } + { apply eqlive_reg_refl. } +(* exec_function_external *) + - inversion TRANSF as [|]; subst. eexists. split. + + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved_RTL. + + constructor. assumption. +(* exec_return *) + - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split. + + constructor. + + inv H1. econstructor; eauto. +Qed. + +Theorem transf_program_correct: + forward_simulation (semantics prog) (semantics tprog). +Proof. + eapply forward_simulation_step with match_states. + - eapply senv_preserved. + - eapply transf_initial_states. + - intros; eapply transf_final_states; eauto. + - intros; eapply step_simulation; eauto. +Qed. + +End PRESERVATION. diff --git a/scheduling/RTLpathproof.v b/scheduling/RTLpathproof.v new file mode 100644 index 00000000..20eded97 --- /dev/null +++ b/scheduling/RTLpathproof.v @@ -0,0 +1,50 @@ +Require Import Coqlib Maps. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL Linking. +Require Import RTLpath. + +Definition match_prog (p: RTLpath.program) (tp: RTL.program) := + match_program (fun ctx f tf => tf = fundef_RTL f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + + +Section PRESERVATION. + +Variable prog: RTLpath.program. +Variable tprog: RTL.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (RTLpath.semantics prog) (RTL.semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. subst. + eapply RTLpath_correct. +Qed. + +End PRESERVATION. + + -- cgit