diff options
31 files changed, 4865 insertions, 2394 deletions
diff --git a/benchmarks/.gitignore b/benchmarks/.gitignore new file mode 100644 index 0000000..fa9cc88 --- /dev/null +++ b/benchmarks/.gitignore @@ -0,0 +1,6 @@ +*.clog +*.iver +*.comp +*.tmp +*.v +*-exec.csv diff --git a/benchmarks/count-calls b/benchmarks/count-calls new file mode 100755 index 0000000..2a14b97 --- /dev/null +++ b/benchmarks/count-calls @@ -0,0 +1,89 @@ +#!/usr/bin/env nix-shell +#! nix-shell -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [ turtle parsec text ])" -i runghc + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +import Turtle +import Text.Parsec as P +import qualified Data.Text as T +import Data.List (group) +import Debug.Trace + +args = argPath "benchmark" "The benchmark directory to check" + +data ParserState = ParserState { + macroNames :: [String], + functionCalls :: [String] +} + +addMacroName :: String -> ParserState -> ParserState +addMacroName macroName ParserState{macroNames, ..} = ParserState {macroNames = macroName:macroNames, ..} + +addFunctionCall :: String -> ParserState -> ParserState +addFunctionCall functionCall ParserState{functionCalls, ..} = ParserState {functionCalls = functionCall:functionCalls, ..} + +cParser :: Parsec T.Text ParserState [T.Text] +cParser = do + P.manyTill + (betweenFuncs >> parserTrace "interesting" >> (try macroDef P.<|> funcBody)) + (try endOfFile) + map T.pack . functionCalls <$> getState + where + betweenFuncs = do + traceM "betweenFuncs" + manyTill P.anyChar $ lookAhead (P.oneOf "#{") + + funcBody :: Parsec T.Text ParserState () + funcBody = do + parserTrace "funcBody" + P.char '{' + void (P.char '}') P.<|> (call >> funcBody) P.<|> (P.anyChar >> funcBody) + + macroDef :: Parsec T.Text ParserState () + macroDef = do + parserTrace "macroDef" + P.char '#' + traceM "macroDef #" + P.many (P.char ' ') + traceM "macroDef spaces" + macroName <- P.many P.alphaNum + traceM ("macroDef " ++ macroName) + modifyState (addMacroName macroName) + + endOfFile = P.many P.space >> P.eof + + call = do + identifier <- many1 idChar + inParens <- P.between (P.char '(') (P.char ')') inParensP + guard (identifier `notElem` ["for", "while"]) + modifyState (addFunctionCall identifier) + pure identifier + + -- handle balanced parens inside calls + inParensP = P.option "" do + t1 <- P.many (P.noneOf "()") + t2 <- P.option "" $ P.between (P.char '(') (P.char ')') inParensP + t3 <- P.many (P.noneOf "()") + return (t1 ++ t2 ++ t3) + idChar = label (P.alphaNum P.<|> P.oneOf "_-") "identifier" + +main = sh do + benchmarkDir <- options "count-calls" args + + printf "benchmark,totalCalls,repeatedCalls\n" + benchmarkName <- fromText . lineToText <$> input (benchmarkDir </> "benchmark-list-master") + let filePath = benchmarkDir </> benchmarkName <.> "c" + + fileContents <- strict $ input filePath + printf (fp%"\n") benchmarkName + + case runParser cParser (ParserState [] []) "file" fileContents of + Left err -> error $ show err + Right calls -> + let + callCount = length calls + repeatedCalls = calls & group & map length & sum + in printf (fp%","%d%","%d%"\n") (basename filePath) callCount repeatedCalls diff --git a/benchmarks/polybench-syn/setup-syn-vivado.sh b/benchmarks/polybench-syn/setup-syn-vivado.sh new file mode 100755 index 0000000..3441c0f --- /dev/null +++ b/benchmarks/polybench-syn/setup-syn-vivado.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +#set up +sshhost="$1" +basedir=${2:-"poly-syn-vivado"} + +echo "Setting up in $sshhost:$basedir" + +echo "Creating directory" +ssh -q "$sshhost" "cd ~; rm -r $basedir; mkdir $basedir" + +echo "Copying scripts over" +scp -q syn-vivado.tcl "$sshhost:$basedir" +scp -q syn-vivado.sh "$sshhost:$basedir" +rm syn-list + +while read -r benchmark; do +echo "Copying $benchmark over" +name=$(echo "$benchmark" | awk -v FS="/" '{print $NF}') +scp -q "$benchmark.v" "$sshhost:~/$basedir" +echo "$name" >> syn-list +done < benchmark-list-master + +echo "Copying syn-list" +scp -q syn-list "$sshhost:$basedir" diff --git a/benchmarks/polybench-syn/syn-remote.sh b/benchmarks/polybench-syn/syn-quartus.sh index 879db2e..879db2e 100755 --- a/benchmarks/polybench-syn/syn-remote.sh +++ b/benchmarks/polybench-syn/syn-quartus.sh diff --git a/benchmarks/polybench-syn/quartus_synth.tcl b/benchmarks/polybench-syn/syn-quartus.tcl index 6edbf0c..6edbf0c 100644 --- a/benchmarks/polybench-syn/quartus_synth.tcl +++ b/benchmarks/polybench-syn/syn-quartus.tcl diff --git a/benchmarks/polybench-syn/syn-vivado.sh b/benchmarks/polybench-syn/syn-vivado.sh new file mode 100755 index 0000000..2b310cb --- /dev/null +++ b/benchmarks/polybench-syn/syn-vivado.sh @@ -0,0 +1,56 @@ +#! /bin/bash + +#setup +while read -r benchmark; do + echo "Setting up $benchmark" + rm -r "$benchmark-vivado" + mkdir "$benchmark-vivado" + cp "$benchmark.v" "$benchmark-vivado/top.v" +done < syn-list + +#synthesis +count=0 +while read -r benchmark; do + echo "Synthesising $benchmark" + + cd "$benchmark-vivado" || { + echo "$benchmark dir does not exist" + continue + } + vivado -mode batch -source ../syn-vivado.tcl + cd .. + (( count=count+1 )) + + if [ "$count" -eq 4 ]; then + echo "I am here" + wait + count=0 + fi +done < syn-list + +if [ $count -lt 4 ]; then +wait +fi + +#extract +while read -r benchmark ; do + cd "$benchmark-vivado" || { + echo "$benchmark-vivado does not exist" + continue + } + + pwd + logfile="vivado.log" + timingfile="worst_timing.txt" + + luts=$(grep "|LUT" "$logfile" | cut -d'|' -f 4 | paste -sd + | bc) + brams=$(sed -n -e "s/BRAMs: \([0-9]\+\).*$/\1/p" "$logfile") + dsps=$(sed -n -e "s/DSPs: \([0-9]\+\).*$/\1/p" "$logfile") + cells=$(grep -A4 "Report Instance Areas:" "$logfile" | tail -1 | cut -d '|' -f5 | tr -d [:space:]) + slack=$(sed -n -e 's/\s\+slack\s\+\(-\?[0-9.]\+\)/\1ns/p' "$timingfile" | tr -d [:space:]) + + cd .. + + echo "$benchmark,$slack,$luts,$brams,$dsps" >> results +done < syn-list + diff --git a/benchmarks/polybench-syn/syn-vivado.tcl b/benchmarks/polybench-syn/syn-vivado.tcl new file mode 100644 index 0000000..733a94e --- /dev/null +++ b/benchmarks/polybench-syn/syn-vivado.tcl @@ -0,0 +1,6 @@ +create_project -in_memory -part xc7k70t +read_verilog top.v +synth_design -part xc7k70t -top main +create_clock -name clk -period 5.000 [get_ports clk] +report_timing -nworst 1 -path_type full -input_pins -file worst_timing.txt +write_verilog -force out.v diff --git a/benchmarks/run-vericert.sh b/benchmarks/run-vericert.sh new file mode 100755 index 0000000..844e9e0 --- /dev/null +++ b/benchmarks/run-vericert.sh @@ -0,0 +1,78 @@ +#! /bin/bash + +# Kill children on Ctrl-c. I have no idea how or why this works +trap 'trap " " SIGTERM; kill 0; wait;' SIGINT SIGTERM + +function error() { echo "$1" >&2; } +function crash() { echo "$1" >&2; exit 1; } +function info() { echo "$1" >&2; } + +[ $# -ge 1 ] || crash "Usage: $0 <benchmark-suite>" +benchmark_dir="$1" + +[ -f "$benchmark_dir/benchmark-list-master" ] || crash "$benchmark_dir/benchmark-list-master does not exist" + +vericert=../bin/vericert +[ -x $vericert ] || crash "Vericert executable does not exist or is not marked as executable. Did you run make; make install?" + +function run_benchmark() { + benchmark_rel="$1" + benchmark="$benchmark_dir/$benchmark_rel" + [ -f "$benchmark.c" ] || { error "$benchmark.c does not exist"; return; } + + info "[$benchmark] Running" + clang -Wall -fsanitize=undefined "$benchmark".c -o "$benchmark".o + ./"$benchmark".o > "$benchmark".clog + cresult=$(cut -d' ' -f2 "$benchmark.clog") + info "[$benchmark] C output: $cresult" + { time ../bin/vericert -DSYNTHESIS --debug-hls "$benchmark.c" -o "$benchmark.v" ; vericert_result=$? ; } 2> "$benchmark".comp + + iverilog -o "$benchmark".iver -- "$benchmark".v + iverilog_result=$? + + timeout 10m ./"$benchmark".iver > "$benchmark".tmp + if [ $? -eq 124 ]; then + timeout=1 + else + veriresult="$(tail -1 "$benchmark".tmp | cut -d' ' -f2)" + fi + cycles="$(sed -ne 's/cycles: //p' "$benchmark".tmp)" + ctime="$(head -2 "$benchmark".comp | tail -1 | xargs | cut -d' ' -f2 | cut -d'm' -f2 | sed 's/s//g')" + info "[$benchmark] Veri output: $veriresult" + + + if [ -n "$timeout" ]; then + info "[$benchmark] FAIL: Verilog timed out" + result="timeout" + elif [ "$vericert_result" -ne 0 ]; then + #Undefined + info "[$benchmark] FAIL: Vericert failed" + result="compile error" + elif [ "$iverilog_result" -ne 0 ]; then + #Undefined + info "[$benchmark] FAIL: iverilog failed" + result="elaboration error" + elif [ -z "$veriresult" ]; then + #Undefined + info "[$benchmark] FAIL: Verilog returned nothing" + result="timeout" + elif [ "$veriresult" == "x" ]; then + # Don't care + info "[$benchmark] FAIL: Verilog returned don't cares" + result="dontcare" + elif [ "$cresult" -ne "$veriresult" ]; then + # unequal result + info "[$benchmark] FAIL: Verilog and C output do not match!" + result="incorrect result" + else + info "[$benchmark] PASS" + result="pass" + fi + name=$(echo "$benchmark" | awk -v FS="/" '{print $NF}') + echo "$name,$cycles,$ctime,$result" +} + +while read -r benchmark_rel; do + run_benchmark "$benchmark_rel" >> "$benchmark_dir-exec.csv" & +done < "$benchmark_dir/benchmark-list-master" +wait diff --git a/default.nix b/default.nix index 6350e3e..0125fdd 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ stdenv.mkDerivation { name = "vericert"; src = ./.; - buildInputs = [ ncoq dune_2 gcc + buildInputs = [ ncoq ncoqPackages.coqhammer cvc4 eprover z3-tptp dune_2 gcc ncoq.ocaml ncoq.ocamlPackages.findlib ncoq.ocamlPackages.menhir ncoq.ocamlPackages.ocamlgraph ncoq.ocamlPackages.merlin ncoq.ocamlPackages.menhirLib diff --git a/lib/CompCert b/lib/CompCert -Subproject 1daf96cdca4d828c333cea5c9a314ef86134298 +Subproject a1c401a4eba5fc9fcf42933f70005ecb679a4c1 diff --git a/src/Compiler.v b/src/Compiler.v index ecea2fc..1b615d2 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -61,6 +61,8 @@ Require Import compcert.lib.Coqlib. Require vericert.hls.Verilog. Require vericert.hls.Veriloggen. Require vericert.hls.Veriloggenproof. +Require vericert.hls.ApplyExternctrl. +Require vericert.hls.Renaming. Require vericert.hls.HTLgen. Require vericert.hls.RTLBlock. Require vericert.hls.RTLBlockgen. @@ -192,10 +194,14 @@ Definition transf_backend (r : RTL.program) : res Verilog.program := @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 7) @@@ HTLgen.transl_program - @@ print (print_HTL 0) - @@ total_if HLSOpts.optim_ram Memorygen.transf_program @@ print (print_HTL 1) - @@ Veriloggen.transl_program. + @@ total_if HLSOpts.optim_ram Memorygen.transf_program + @@ print (print_HTL 2) + @@@ Renaming.transf_program + @@ print (print_HTL 3) + @@@ ApplyExternctrl.transf_program + @@ print (print_HTL 4) + @@@ Veriloggen.transl_program. (*| The transformation functions from RTL to Verilog are then added to the backend of the CompCert transformations from Clight to RTL. @@ -275,6 +281,8 @@ Definition CompCert's_passes := ::: mkpass Unusedglobproof.match_prog ::: (@mkpass _ _ HTLgenproof.match_prog (HTLgenproof.TransfHTLLink HTLgen.transl_program)) ::: mkpass (match_if HLSOpts.optim_ram Memorygen.match_prog) + ::: mkpass Renaming.match_prog + ::: mkpass ApplyExternctrl.match_prog ::: mkpass Veriloggenproof.match_prog ::: pass_nil _. @@ -303,7 +311,7 @@ Proof. destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. rewrite ! compose_print_identity in T. destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. - unfold transf_backend, time in T. simpl in T. rewrite ! compose_print_identity in T. + unfold transf_backend, time in T. rewrite ! compose_print_identity in T. simpl in T. destruct (Inlining.transf_program p6) as [p7|e] eqn:P7; simpl in T; try discriminate. set (p8 := Renumber.transf_program p7) in *. set (p9 := total_if Compopts.optim_constprop Constprop.transf_program p8) in *. @@ -313,7 +321,10 @@ Proof. destruct (Unusedglob.transform_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. destruct (HTLgen.transl_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. set (p15 := total_if HLSOpts.optim_ram Memorygen.transf_program p14) in *. - set (p16 := Veriloggen.transl_program p15) in *. + destruct (Renaming.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. + destruct (ApplyExternctrl.transf_program p16) as [p17|e] eqn:P17; simpl in T; try discriminate. + destruct (Veriloggen.transl_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. + unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. @@ -329,8 +340,10 @@ Proof. exists p12; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. exists p13; split. apply Unusedglobproof.transf_program_match; auto. exists p14; split. apply HTLgenproof.transf_program_match; auto. - exists p15; split. apply total_if_match. apply Memorygen.transf_program_match; auto. - exists p16; split. apply Veriloggenproof.transf_program_match; auto. + exists p15; split. apply total_if_match. apply Memorygen.transf_program_match. + exists p16; split. apply Renaming.transf_program_match; auto. + exists p17; split. apply ApplyExternctrl.transf_program_match; auto. + exists p18; split. apply Veriloggenproof.transf_program_match; auto. inv T. reflexivity. Qed. @@ -341,14 +354,14 @@ Theorem cstrategy_semantic_preservation: /\ backward_simulation (atomic (Cstrategy.semantics p)) (Verilog.semantics tp). Proof. intros p tp M. unfold match_prog, pass_match in M; simpl in M. -Ltac DestructM := - match goal with - [ H: exists p, _ /\ _ |- _ ] => - let p := fresh "p" in let M := fresh "M" in let MM := fresh "MM" in - destruct H as (p & M & MM); clear H - end. + Ltac DestructM := + match goal with + [ H: exists p, _ /\ _ |- _ ] => + let p := fresh "p" in let M := fresh "M" in let MM := fresh "MM" in + destruct H as (p & M & MM); clear H + end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p16)). + assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p18)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -377,9 +390,13 @@ Ltac DestructM := eapply compose_forward_simulations. eapply Unusedglobproof.transf_program_correct; eassumption. eapply compose_forward_simulations. - eapply HTLgenproof.transf_program_correct. eassumption. + eapply HTLgenproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Memorygen.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Renaming.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply ApplyExternctrl.transf_program_correct; eassumption. eapply Veriloggenproof.transf_program_correct; eassumption. } split. auto. diff --git a/src/common/ListExtra.v b/src/common/ListExtra.v new file mode 100644 index 0000000..6b14a50 --- /dev/null +++ b/src/common/ListExtra.v @@ -0,0 +1,27 @@ +Require Export Coq.Lists.List. + +Require Import Coq.micromega.Lia. +Require Import vericert.common.Vericertlib. + +From Hammer Require Import Tactics. + +Lemma nth_error_length : forall {A} (l : list A) n x, + nth_error l n = Some x -> (n < length l)%nat. +Proof. + induction l; intros; simpl in *. + - destruct n; crush. + - destruct n; crush. + edestruct IHl; eauto with arith. +Qed. + +Lemma length_nth_error : forall {A} (l : list A) n, + (n < length l)%nat -> exists x, nth_error l n = Some x. +Proof. + induction l; intros; simpl in *. + - lia. + - destruct n; crush; eauto with arith. +Qed. + +Lemma combine_split : forall {A B} (l : list (A * B)), + List.combine (fst (List.split l)) (snd (List.split l)) = l. +Proof. hfcrush use: split_combine unfold: fst, snd inv: prod. Qed. diff --git a/src/common/Maps.v b/src/common/Maps.v index f0f264d..3aa0b33 100644 --- a/src/common/Maps.v +++ b/src/common/Maps.v @@ -61,4 +61,54 @@ Definition traverse (A B : Type) (f : positive -> A -> res B) m := xtraverse f m Definition traverse1 (A B : Type) (f : A -> res B) := traverse (fun _ => f). +Definition filter (A: Type) (pred: PTree.elt -> A -> bool) (m: t A) : t A := + PTree.map (fun _ a => snd a) (PTree.filter1 (fun a => pred (fst a) (snd a)) (PTree.map (fun i x => (i, x)) m)). + +Theorem filter_spec: forall (A: Type) (pred: PTree.elt -> A -> bool) (m: PTree.t A) (i: PTree.elt) (x : A), + (filter pred m) ! i = + match m ! i with + | None => None + | Some x => if pred i x then Some x else None + end. +Proof. + intros. + unfold filter. + + rewrite gmap. + unfold option_map. + + rewrite gfilter1. + + rewrite gmap. + unfold option_map. + + destruct (m ! i). + - simpl. + destruct (pred i a); simpl; reflexivity. + - reflexivity. +Qed. + +Definition contains (A: Type) (i: positive) (m: t A) : bool := + match get i m with + | Some _ => true + | None => false + end. End PTree. + +Definition max_pc_map {A: Type} (m : Maps.PTree.t A) := + PTree.fold (fun m pc i => Pos.max m pc) m 1%positive. + +Lemma max_pc_map_sound: + forall A m pc i, m!pc = Some i -> Ple pc (@max_pc_map A m). +Proof. + intros until i. unfold max_pc_map. + apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m). + (* extensionality *) + intros. apply H0. rewrite H; auto. + (* base case *) + rewrite PTree.gempty. congruence. + (* inductive case *) + intros. rewrite PTree.gsspec in H2. destruct (peq pc k). + inv H2. xomega. + apply Ple_trans with a. auto. xomega. +Qed. diff --git a/src/common/Monad.v b/src/common/Monad.v index fcbe527..1801a63 100644 --- a/src/common/Monad.v +++ b/src/common/Monad.v @@ -1,6 +1,7 @@ (* * Vericert: Verified high-level synthesis. * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * 2021 Michalis Pardalos <mpardalos@gmail.com> * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -16,7 +17,8 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) -From Coq Require Import Lists.List. +From Coq Require Import BinNums Lists.List. +From compcert Require Import Maps. Module Type Monad. @@ -57,10 +59,38 @@ Module MonadExtra(M : Monad). ret (r::rs) end. + Definition sequence {A} : list (mon A) -> mon (list A) := traverselist (fun x => x). + + Definition traverseoption {A B: Type} (f: A -> mon B) (opt: option A) : mon (option B) := + match opt with + | None => ret None + | Some x => + do r <- f x; + ret (Some r) + end. + Fixpoint collectlist {A : Type} (f : A -> mon unit) (l : list A) {struct l} : mon unit := match l with | nil => ret tt | x::xs => do _ <- f x; collectlist f xs end. +Fixpoint xtraverse_ptree {A B : Type} (f : positive -> A -> mon B) (m : PTree.t A) (i : positive) + {struct m} : mon (PTree.t B) := + match m with + | PTree.Leaf => ret PTree.Leaf + | PTree.Node l o r => + do no <- match o with + | None => ret None + | Some x => do no <- f (PTree.prev i) x; ret (Some no) + end; + do nl <- xtraverse_ptree f l (xO i); + do nr <- xtraverse_ptree f r (xI i); + ret (PTree.Node nl no nr) + end. + +Definition traverse_ptree {A B : Type} (f : positive -> A -> mon B) m := xtraverse_ptree f m xH. + +Definition traverse_ptree1 {A B : Type} (f : A -> mon B) := traverse_ptree (fun _ => f). + End MonadExtra. diff --git a/src/common/Statemonad.v b/src/common/Statemonad.v index 16dcbbf..20558e0 100644 --- a/src/common/Statemonad.v +++ b/src/common/Statemonad.v @@ -63,6 +63,14 @@ Module Statemonad(S : State) <: Monad. | Error _ => g s end. + Definition handle_opt {A : Type} (err : Errors.errmsg) (val : option A) + : mon A := + fun s => + match val with + | Some a => OK a s (S.st_refl s) + | None => Error err + end. + Definition error {A: Type} (err: Errors.errmsg) : mon A := fun (s: S.st) => Error err. Definition get : mon S.st := fun s => OK s s (S.st_refl s). diff --git a/src/common/Vericertlib.v b/src/common/Vericertlib.v index 389a74f..331e015 100644 --- a/src/common/Vericertlib.v +++ b/src/common/Vericertlib.v @@ -57,6 +57,19 @@ Ltac learn_tac fact name := Tactic Notation "learn" constr(fact) := let name := fresh "H" in learn_tac fact name. Tactic Notation "learn" constr(fact) "as" simple_intropattern(name) := learn_tac fact name. +Ltac auto_apply fact := + let H' := fresh "H" in + match goal with + | H : _ |- _ => pose proof H as H'; apply fact in H' + end. + +(** Specialize all hypotheses with a forall to a specific term *) +Tactic Notation "specialize_all" constr(v) := + let t := type of v in + repeat match goal with + | [H : (forall (x: t), _) |- _ ] => learn H; destruct H with v + end. + Ltac unfold_rec c := unfold c; fold c. Ltac solve_by_inverts n := @@ -71,12 +84,30 @@ Ltac solve_by_invert := solve_by_inverts 1. Ltac invert x := inversion x; subst; clear x. +(** For a hypothesis of a forall-type, instantiate every variable to a fresh existential *) +Ltac insterU1 H := + match type of H with + | forall x : ?T, _ => + let x := fresh "x" in + evar (x : T); + let x' := eval unfold x in x in + clear x; specialize (H x') + end. + +Ltac insterU H := + repeat (insterU1 H). + Ltac destruct_match := match goal with | [ |- context[match ?x with | _ => _ end ] ] => destruct x eqn:? | [ H: context[match ?x with | _ => _ end] |- _ ] => destruct x eqn:? end. +Ltac unfold_match H := + match type of H with + | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate + end. + Ltac auto_destruct x := destruct x eqn:?; simpl in *; try discriminate; try congruence. Ltac nicify_hypotheses := @@ -187,12 +218,61 @@ Ltac liapp := | _ => idtac end. -Ltac crush := simplify; try discriminate; try congruence; try lia; liapp; +Ltac plia := solve [ unfold Ple in *; lia ]. + +Ltac xomega := unfold Plt, Ple in *; zify; lia. + +Ltac crush := simplify; try discriminate; try congruence; try plia; liapp; try assumption; try (solve [auto]). +Ltac crush_trans := + match goal with + | [ H : ?g = ?inter |- ?g = _ ] => transitivity inter; crush + | [ H : ?inter = ?g |- ?g = _ ] => transitivity inter; crush + | [ H : ?g = ?inter |- _ = ?g ] => transitivity inter; crush + | [ H : ?inter = ?g |- _ = ?g ] => transitivity inter; crush + end. + +Ltac maybe t := t + idtac. + #[global] Opaque Nat.div. #[global] Opaque Z.mul. +Inductive Ascending : list positive -> Prop := + | Ascending_nil : Ascending nil + | Ascending_single : forall x, Ascending (x::nil) + | Ascending_cons : forall x y l, (x < y)%positive -> Ascending (y::l) -> Ascending (x::y::l). + +Lemma map_fst_split : forall A B (l : list (A * B)), List.map fst l = fst (List.split l). +Proof. + induction l; crush. + destruct a; destruct (split l). + crush. +Qed. + +Lemma Ascending_Forall : forall l x, Ascending (x :: l) -> Forall (fun y => x < y)%positive l. +Proof. + induction l; crush. + inv H. + specialize (IHl _ H4). + apply Forall_cons. + - crush. + - apply Forall_impl with (P:=(fun y : positive => (a < y)%positive)); crush. +Qed. + +Lemma Ascending_NoDup : forall l, Ascending l -> NoDup l. +Proof. + induction 1; simplify. + - constructor. + - constructor. crush. constructor. + - constructor; auto. + intro contra. inv contra; crush. + auto_apply Ascending_Forall. + rewrite Forall_forall in *. + specialize (H2 x ltac:(auto)). + lia. +Qed. + (* Definition const (A B : Type) (a : A) (b : B) : A := a. Definition compose (A B C : Type) (f : B -> C) (g : A -> B) (x : A) : C := f (g x). *) @@ -229,6 +309,15 @@ Definition join {A : Type} (a : option (option A)) : option A := | Some a' => a' end. +Fixpoint map_option {A B : Type} (f : A -> option B) (l : list A) : list B := + match l with + | nil => nil + | x::xs => match f x with + | None => map_option f xs + | Some x' => x'::map_option f xs + end + end. + Module Notation. Notation "'do' X <- A ; B" := (bind A (fun X => B)) (at level 200, X name, A at level 100, B at level 200). diff --git a/src/hls/ApplyExternctrl.v b/src/hls/ApplyExternctrl.v new file mode 100644 index 0000000..e9aceec --- /dev/null +++ b/src/hls/ApplyExternctrl.v @@ -0,0 +1,197 @@ +Require Import compcert.common.Errors. +Require Import compcert.common.AST. + +Require Import vericert.common.Maps. +Require Import vericert.common.Statemonad. +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.AssocMap. +Require Import vericert.hls.HTL. +Require Import vericert.hls.Verilog. + +Import ListNotations. + +Section APPLY_EXTERNCTRL. + Local Open Scope assocmap. + Local Open Scope error_monad_scope. + + Variable prog : HTL.program. + Variable m : HTL.module. + + Let modmap := prog_modmap prog. + + Definition global_clk := + match modmap ! (AST.prog_main prog) with + | None => Error (msg "ApplyExternctrl: No main") + | Some main => OK (HTL.mod_clk main) + end. + + Definition get_mod_signal (othermod : HTL.module) (signal : HTL.controlsignal) := + match signal with + | ctrl_finish => OK (HTL.mod_finish othermod) + | ctrl_return => OK (HTL.mod_return othermod) + | ctrl_start => OK (HTL.mod_start othermod) + | ctrl_reset => OK (HTL.mod_reset othermod) + | ctrl_clk => OK (HTL.mod_clk othermod) + | ctrl_param idx => + match List.nth_error (HTL.mod_params othermod) idx with + | Some r => OK r + | None => Error (msg "Module does not have nth parameter") + end + end. + + Definition reg_apply_externctrl (r : Verilog.reg) : res reg := + match (HTL.mod_externctrl m) ! r with + | None => OK r + | Some (m, signal) => + match modmap ! m with + | None => Error (msg "Veriloggen: Could not find definition for called module") + | Some othermod => get_mod_signal othermod signal + end + end. + + Fixpoint expr_apply_externctrl (expr : Verilog.expr) {struct expr} : res Verilog.expr := + match expr with + | Vlit n => + OK (Vlit n) + | Vvar r => + do r' <- reg_apply_externctrl r; + OK (Vvar r') + | Vvari r e => + do r' <- reg_apply_externctrl r; + do e' <- expr_apply_externctrl e; + OK (Vvari r e) + | Vrange r e1 e2 => + do r' <- reg_apply_externctrl r; + do e1' <- expr_apply_externctrl e1; + do e2' <- expr_apply_externctrl e2; + OK (Vrange r' e1' e2') + | Vinputvar r => + do r' <- reg_apply_externctrl r; + OK (Vinputvar r') + | Vbinop op e1 e2 => + do e1' <- expr_apply_externctrl e1; + do e2' <- expr_apply_externctrl e2; + OK (Vbinop op e1' e2') + | Vunop op e => + do e' <- expr_apply_externctrl e; + OK (Vunop op e') + | Vternary e1 e2 e3 => + do e1' <- expr_apply_externctrl e1; + do e2' <- expr_apply_externctrl e2; + do e3' <- expr_apply_externctrl e3; + OK (Vternary e1' e2' e3') + end. + + Definition mmap_option {A B} (f : A -> res B) (opt : option A) : res (option B) := + match opt with + | None => OK None + | Some a => do a' <- f a; OK (Some a') + end. + + Definition cases_apply_externctrl_ (stmnt_apply_externctrl_ : Verilog.stmnt -> res Verilog.stmnt) := + fix cases_apply_externctrl (cs : stmnt_expr_list) := + match cs with + | Stmntnil => OK Stmntnil + | Stmntcons c_e c_s tl => + do c_e' <- expr_apply_externctrl c_e; + do c_s' <- stmnt_apply_externctrl_ c_s; + do tl' <- cases_apply_externctrl tl; + OK (Stmntcons c_e' c_s' tl') + end. + + Fixpoint stmnt_apply_externctrl (stmnt : Verilog.stmnt) {struct stmnt} : res Verilog.stmnt := + match stmnt with + | Vskip => OK Vskip + | Vseq s1 s2 => + do s1' <- stmnt_apply_externctrl s1; + do s2' <- stmnt_apply_externctrl s2; + OK (Vseq s1' s2') + | Vcond e s1 s2 => + do e' <- expr_apply_externctrl e; + do s1' <- stmnt_apply_externctrl s1; + do s2' <- stmnt_apply_externctrl s2; + OK (Vcond e' s1' s2') + | Vcase e cases def => + do e' <- expr_apply_externctrl e; + do cases' <- cases_apply_externctrl_ stmnt_apply_externctrl cases; + do def' <- mmap_option (fun x => stmnt_apply_externctrl x) def; + OK (Vcase e' cases' def') + | Vblock e1 e2 => + do e1' <- expr_apply_externctrl e1; + do e2' <- expr_apply_externctrl e2; + OK (Vblock e1' e2') + | Vnonblock e1 e2 => + do e1' <- expr_apply_externctrl e1; + do e2' <- expr_apply_externctrl e2; + OK (Vnonblock e1' e2') + end. + + (* Unused. Defined for completeness *) + Definition cases_apply_externctrl := cases_apply_externctrl_ stmnt_apply_externctrl. + + Fixpoint xassocmap_apply_externctrl {A} (regmap : list (reg * A)) : res (list (reg * A)) := + match regmap with + | nil => OK nil + | (r, v) :: l => + do r' <- reg_apply_externctrl r; + do l' <- xassocmap_apply_externctrl l; + OK ((r', v) :: l') + end. + + Definition assocmap_apply_externctrl {A} (regmap : AssocMap.t A) : res (AssocMap.t A) := + do l <- xassocmap_apply_externctrl (AssocMap.elements regmap); + OK (AssocMap_Properties.of_list l). + + Definition module_apply_externctrl : res HTL.module := + do mod_controllogic' <- PTree.traverse1 stmnt_apply_externctrl (HTL.mod_controllogic m); + do mod_datapath' <- PTree.traverse1 stmnt_apply_externctrl (HTL.mod_datapath m); + do mod_externctrl' <- assocmap_apply_externctrl (HTL.mod_externctrl m); + + match zle (Z.pos (max_pc_map mod_datapath')) Integers.Int.max_unsigned, + zle (Z.pos (max_pc_map mod_controllogic')) Integers.Int.max_unsigned + with + | left LEDATA, left LECTRL => + OK (HTL.mkmodule + (HTL.mod_params m) + mod_datapath' + mod_controllogic' + (HTL.mod_entrypoint m) + (HTL.mod_st m) + (HTL.mod_stk m) + (HTL.mod_stk_len m) + (HTL.mod_finish m) + (HTL.mod_return m) + (HTL.mod_start m) + (HTL.mod_reset m) + (HTL.mod_clk m) + (HTL.mod_scldecls m) + (HTL.mod_arrdecls m) + mod_externctrl' + (HTL.mod_ram m) + (conj (max_pc_wf _ _ LECTRL) (max_pc_wf _ _ LEDATA)) + (HTL.mod_ordering_wf m) + (HTL.mod_ram_wf m) + (HTL.mod_params_wf m)) + | right _, _ => Error (Errors.msg "ApplyExternctrl: More than 2^32 datapath states") + | _, right _ => Error (Errors.msg "ApplyExternctrl: More than 2^32 controlpath states") + end. +End APPLY_EXTERNCTRL. + +Definition transf_fundef (prog : HTL.program) := transf_partial_fundef (module_apply_externctrl prog). +Definition transf_program (prog : HTL.program) := transform_partial_program (transf_fundef prog) prog. + +(* Semantics *) + +Definition match_prog : HTL.program -> HTL.program -> Prop := + Linking.match_program (fun ctx f tf => ApplyExternctrl.transf_fundef ctx f = OK tf) eq. + +Lemma transf_program_match : forall p tp, + ApplyExternctrl.transf_program p = OK tp -> match_prog p tp. +Admitted. + +Lemma transf_program_correct : forall p tp, + match_prog p tp -> Smallstep.forward_simulation (HTL.semantics p) (HTL.semantics tp). +Admitted. + +Instance TransfLink : Linking.TransfLink match_prog. +Admitted. diff --git a/src/hls/AssocMap.v b/src/hls/AssocMap.v index 8dbc6b2..784f455 100644 --- a/src/hls/AssocMap.v +++ b/src/hls/AssocMap.v @@ -25,6 +25,7 @@ Require Import vericert.hls.ValueInt. Definition reg := positive. Module AssocMap := Maps.PTree. +Module AssocMap_Properties := Maps.PTree_Properties. Module AssocMapExt. Import AssocMap. @@ -243,3 +244,19 @@ Lemma find_get_assocmap : assoc ! r = Some v -> assoc # r = v. Proof. intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H. trivial. Qed. + +Lemma fso : forall m v k1 k2, k1 <> k2 -> (m # k1 <- v) # k2 = m # k2. +Proof. + unfold "_ # _". + unfold AssocMapExt.get_default. + intros. + destruct_match; rewrite AssocMap.gso in Heqo by auto; rewrite Heqo; auto. +Qed. + +Lemma fss : forall m v k, (m # k <- v) # k = v. +Proof. + unfold "_ # _". + unfold AssocMapExt.get_default. + intros. + destruct_match; rewrite AssocMap.gss in Heqo by auto; inv Heqo; crush. +Qed. diff --git a/src/hls/HTL.v b/src/hls/HTL.v index 8cebbfd..f16aef5 100644 --- a/src/hls/HTL.v +++ b/src/hls/HTL.v @@ -31,6 +31,7 @@ Require Import vericert.common.Vericertlib. Require Import vericert.hls.ValueInt. Require Import vericert.hls.AssocMap. Require Import vericert.hls.Array. +Require Import vericert.common.Maps. Require vericert.hls.Verilog. Local Open Scope positive. @@ -45,15 +46,20 @@ Local Open Scope assocmap. Definition reg := positive. Definition node := positive. +Definition ident := positive. -Definition datapath := PTree.t Verilog.stmnt. -Definition controllogic := PTree.t Verilog.stmnt. +Definition datapath_stmnt := Verilog.stmnt. +Definition datapath := PTree.t datapath_stmnt. +Definition control_stmnt := Verilog.stmnt. +Definition controllogic := PTree.t control_stmnt. Definition map_well_formed {A : Type} (m : PTree.t A) : Prop := forall p0 : positive, In p0 (map fst (Maps.PTree.elements m)) -> (Z.pos p0 <= Integers.Int.max_unsigned)%Z. +Definition ram_ordering a b c d e f := a < b < c /\ c < d < e /\ e < f. + Record ram := mk_ram { ram_size: nat; ram_mem: reg; @@ -63,15 +69,26 @@ Record ram := mk_ram { ram_wr_en: reg; ram_d_in: reg; ram_d_out: reg; - ram_ordering: (ram_addr < ram_en - /\ ram_en < ram_d_in - /\ ram_d_in < ram_d_out - /\ ram_d_out < ram_wr_en - /\ ram_wr_en < ram_u_en) + ram_ordering_wf: ram_ordering ram_addr ram_en ram_d_in ram_d_out ram_wr_en ram_u_en }. Definition module_ordering a b c d e f g := a < b < c /\ c < d < e /\ e < f < g. +Inductive controlsignal : Type := + | ctrl_finish : controlsignal + | ctrl_return : controlsignal + | ctrl_start : controlsignal + | ctrl_reset : controlsignal + | ctrl_clk : controlsignal + | ctrl_param (idx : nat) : controlsignal. + +Definition controlsignal_sz (s : controlsignal) : nat := + match s with + | ctrl_param _ => 32 + | ctrl_return => 32 + | _ => 1 + end. + Record module: Type := mkmodule { mod_params : list reg; @@ -88,6 +105,9 @@ Record module: Type := mod_clk : reg; mod_scldecls : AssocMap.t (option Verilog.io * Verilog.scl_decl); mod_arrdecls : AssocMap.t (option Verilog.io * Verilog.arr_decl); + (** Map from registers in this module to control registers in other modules. + These will be mapped to the same verilog register. *) + mod_externctrl : AssocMap.t (ident * controlsignal); mod_ram : option ram; mod_wf : map_well_formed mod_controllogic /\ map_well_formed mod_datapath; mod_ordering_wf : module_ordering mod_st mod_finish mod_return mod_stk mod_start mod_reset mod_clk; @@ -108,31 +128,59 @@ Fixpoint init_regs (vl : list value) (rl : list reg) {struct rl} := Definition empty_stack (m : module) : Verilog.assocmap_arr := (AssocMap.set m.(mod_stk) (Array.arr_repeat None m.(mod_stk_len)) (AssocMap.empty Verilog.arr)). + +Definition prog_modmap (p : HTL.program) := + PTree_Properties.of_list (Option.map_option + (fun a => match a with + | (ident, (AST.Gfun (AST.Internal f))) => Some (ident, f) + | _ => None + end) + (AST.prog_defs p)). + +Lemma max_pc_wf : + forall T m, (Z.pos (max_pc_map m) <= Integers.Int.max_unsigned)%Z -> + @map_well_formed T m. +Proof. + unfold map_well_formed. intros. + exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x. + apply Maps.PTree.elements_complete in B. apply max_pc_map_sound in B. + unfold Ple in B. apply Pos2Z.pos_le_pos in B. subst. + simplify. transitivity (Z.pos (max_pc_map m)); eauto. +Qed. + (** * Operational Semantics *) Definition genv := Globalenvs.Genv.t fundef unit. +Definition find_func {F V} (ge : Globalenvs.Genv.t F V) (symb : AST.ident) : option F := + match Globalenvs.Genv.find_symbol ge symb with + | None => None + | Some b => Globalenvs.Genv.find_funct_ptr ge b + end. + Inductive stackframe : Type := - Stackframe : - forall (res : reg) - (m : module) - (pc : node) - (reg_assoc : Verilog.assocmap_reg) - (arr_assoc : Verilog.assocmap_arr), - stackframe. + Stackframe : forall (mid : ident) + (m : module) + (st : node) + (reg_assoc : Verilog.assocmap_reg) + (arr_assoc : Verilog.assocmap_arr), + stackframe. Inductive state : Type := | State : forall (stack : list stackframe) + (mid : ident) (m : module) (st : node) (reg_assoc : Verilog.assocmap_reg) (arr_assoc : Verilog.assocmap_arr), state | Returnstate : forall (res : list stackframe) + (mid : ident) (** Name of the callee *) (v : value), state | Callstate : forall (stack : list stackframe) + (mid : ident) (m : module) (args : list value), state. @@ -172,7 +220,7 @@ Inductive exec_ram: Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : - forall g m st sf ctrl data + forall g mid m st sf ctrl_stmnt data_stmnt asr asa basr1 basa1 nasr1 nasa1 basr2 basa2 nasr2 nasa2 @@ -182,19 +230,19 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := asr!(mod_reset m) = Some (ZToValue 0) -> asr!(mod_finish m) = Some (ZToValue 0) -> asr!(m.(mod_st)) = Some (posToValue st) -> - m.(mod_controllogic)!st = Some ctrl -> - m.(mod_datapath)!st = Some data -> + m.(mod_controllogic)!st = Some ctrl_stmnt -> + m.(mod_datapath)!st = Some data_stmnt -> Verilog.stmnt_runp f (Verilog.mkassociations asr empty_assocmap) (Verilog.mkassociations asa (empty_stack m)) - ctrl + ctrl_stmnt (Verilog.mkassociations basr1 nasr1) (Verilog.mkassociations basa1 nasa1) -> basr1!(m.(mod_st)) = Some (posToValue st) -> Verilog.stmnt_runp f (Verilog.mkassociations basr1 nasr1) (Verilog.mkassociations basa1 nasa1) - data + data_stmnt (Verilog.mkassociations basr2 nasr2) (Verilog.mkassociations basa2 nasa2) -> exec_ram @@ -207,26 +255,69 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := asa' = Verilog.merge_arrs nasa3 basa3 -> asr'!(m.(mod_st)) = Some (posToValue pstval) -> (Z.pos pstval <= Integers.Int.max_unsigned)%Z -> - step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') + step g + (State sf mid m st asr asa) Events.E0 + (State sf mid m pstval asr' asa') | step_finish : - forall g m st asr asa retval sf, + forall g m st asr asa retval sf mid, asr!(m.(mod_finish)) = Some (ZToValue 1) -> asr!(m.(mod_return)) = Some retval -> - step g (State sf m st asr asa) Events.E0 (Returnstate sf retval) + + step g + (State sf mid m st asr asa) Events.E0 + (Returnstate sf mid retval) +| step_initcall : + forall g callerid caller st asr asa sf callee_id callee callee_reset callee_params callee_param_vals, + find_func g callee_id = Some (AST.Internal callee) -> + + caller.(mod_externctrl)!callee_reset = Some (callee_id, ctrl_reset) -> + (forall n param, nth_error callee_params n = Some param -> + caller.(mod_externctrl)!param = Some (callee_id, ctrl_param n)) -> + + (* The fact that this is the only condition on the current state to trigger + a call introduces non-determinism into the semantics. The semantics + permit initiating a call from any state where a reset has been set to 0. + *) + asr!callee_reset = Some (ZToValue 0) -> + callee_param_vals = List.map (fun p => asr#p) callee_params -> + + step g + (State sf callerid caller st asr asa) Events.E0 + (Callstate (Stackframe callerid caller st asr asa :: sf) + callee_id callee callee_param_vals) + | step_call : - forall g m args res, - step g (Callstate res m args) Events.E0 - (State res m m.(mod_entrypoint) + forall g mid m args res, + step g + (Callstate res mid m args) Events.E0 + (State res mid m m.(mod_entrypoint) (AssocMap.set (mod_reset m) (ZToValue 0) (AssocMap.set (mod_finish m) (ZToValue 0) (AssocMap.set (mod_st m) (posToValue m.(mod_entrypoint)) (init_regs args m.(mod_params))))) (empty_stack m)) + | step_return : - forall g m asr asa i r sf pc mst, - mst = mod_st m -> - step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 - (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). + forall g callerid caller asr asa callee_id callee_return callee_finish i sf pc mst, + mst = mod_st caller -> + + caller.(mod_externctrl)!callee_return = Some (callee_id, ctrl_return) -> + caller.(mod_externctrl)!callee_finish = Some (callee_id, ctrl_finish) -> + + step g + (Returnstate (Stackframe callerid caller pc asr asa :: sf) callee_id i) Events.E0 + (State sf callerid caller pc + (asr # mst <- (posToValue pc) # callee_finish <- (ZToValue 1) # callee_return <- i) + asa) +| step_finish_reset : + forall g sf mid mid' m st asr asa fin, + asr ! fin = Some (ZToValue 1) -> + (mod_externctrl m) ! fin = Some (mid', ctrl_finish) -> + step g + (State sf mid m st asr asa) Events.E0 + (State sf mid m st (asr # fin <- (ZToValue 0)) asa). + + #[export] Hint Constructors step : htl. Inductive initial_state (p: program): state -> Prop := @@ -235,12 +326,12 @@ Inductive initial_state (p: program): state -> Prop := Globalenvs.Genv.init_mem p = Some m0 -> Globalenvs.Genv.find_symbol ge p.(AST.prog_main) = Some b -> Globalenvs.Genv.find_funct_ptr ge b = Some (AST.Internal m) -> - initial_state p (Callstate nil m nil). + initial_state p (Callstate nil p.(AST.prog_main) m nil). Inductive final_state : state -> Integers.int -> Prop := -| final_state_intro : forall retval retvali, +| final_state_intro : forall retval mid retvali, retvali = valueToInt retval -> - final_state (Returnstate nil retval) retvali. + final_state (Returnstate nil mid retval) retvali. Definition semantics (m : program) := Smallstep.Semantics step (initial_state m) final_state @@ -352,3 +443,39 @@ Definition max_list_dec (l: list reg) (st: reg) : {Forall (Pos.gt st) l} + {True ); auto. apply max_list_correct. apply Pos.ltb_lt in e. lia. Qed. + +Definition decide_order a b c d e f g : {module_ordering a b c d e f g} + {True}. + refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) + && (d <? e) && (e <? f) && (f <? g))%positive true with + | left t => left _ + | _ => _ + end); auto. + simplify; repeat match goal with + | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H + end; unfold module_ordering; auto. +Defined. + +Definition decide_ram_ordering a b c d e f : {ram_ordering a b c d e f} + {True}. + refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) + && (d <? e) && (e <? f))%positive true with + | left t => left _ + | _ => _ + end); auto. + simplify; repeat match goal with + | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H + end; unfold ram_ordering; auto. +Defined. + +Definition decide_ram_wf (clk : reg) (mr : option HTL.ram) : + {forall r' : ram, mr = Some r' -> (clk < ram_addr r')%positive} + {True}. + refine ( + match mr with + | Some r => + match (plt clk (ram_addr r)) with + | left LE => left _ + | _ => right I + end + | None => left _ + end). + all: crush. +Defined. diff --git a/src/hls/HTLBlockgen.v b/src/hls/HTLBlockgen.v index 5f40962..b9fc1d9 100644 --- a/src/hls/HTLBlockgen.v +++ b/src/hls/HTLBlockgen.v @@ -43,8 +43,8 @@ Definition init_state (st : reg) : state := 1%positive (AssocMap.empty (option io * scl_decl)) (AssocMap.empty (option io * arr_decl)) - (AssocMap.empty stmnt) - (AssocMap.empty stmnt). + (AssocMap.empty datapath_stmnt) + (AssocMap.empty control_stmnt). Module HTLState <: State. @@ -87,11 +87,17 @@ Module HTLMonadExtra := Monad.MonadExtra(HTLMonad). Import HTLMonadExtra. Export MonadNotation. -Definition state_goto (st : reg) (n : node) : stmnt := - Vnonblock (Vvar st) (Vlit (posToValue n)). +Definition data_vstmnt : Verilog.stmnt -> HTL.datapath_stmnt := HTLDataVstmnt. +Definition ctrl_vstmnt : Verilog.stmnt -> HTL.control_stmnt := HTLCtrlVstmnt. -Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : stmnt := - Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2)). +Definition state_goto (st : reg) (n : node) : control_stmnt := + ctrl_vstmnt (Vnonblock (Vvar st) (Vlit (posToValue n))). + +Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : control_stmnt := + ctrl_vstmnt (Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2))). + +Definition nonblock (dst : reg) (e : expr) := (Vnonblock (Vvar dst) e). +Definition block (dst : reg) (e : expr) := (Vblock (Vvar dst) e). Definition check_empty_node_datapath: forall (s: state) (n: node), { s.(st_datapath)!n = None } + { True }. @@ -105,25 +111,6 @@ Proof. intros. case (s.(st_controllogic)!n); tauto. Defined. -Lemma add_instr_state_incr : - forall s n n' st, - (st_datapath s)!n = None -> - (st_controllogic s)!n = None -> - st_incr s - (mkstate - s.(st_st) - s.(st_freshreg) - (st_freshstate s) - s.(st_scldecls) - s.(st_arrdecls) - (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))). -Proof. - constructor; intros; - try (simpl; destruct (peq n n0); subst); - auto with htlh. -Qed. - Lemma declare_reg_state_incr : forall i s r sz, st_incr s @@ -148,7 +135,50 @@ Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit := s.(st_controllogic)) (declare_reg_state_incr i s r sz). -Definition add_instr (n : node) (n' : node) (st : stmnt) : mon unit := +Lemma create_state_state_incr: + forall s, + st_incr s (mkstate + s.(st_st) + (st_freshreg s) + (Pos.succ (st_freshstate s)) + (st_scldecls s) + (st_arrdecls s) + (st_datapath s) + (st_controllogic s)). +Proof. constructor; simpl; auto with htlh. Qed. + +Definition create_state : mon node := + fun s => let r := s.(st_freshstate) in + OK r (mkstate + s.(st_st) + (st_freshreg s) + (Pos.succ (st_freshstate s)) + (st_scldecls s) + (st_arrdecls s) + (st_datapath s) + (st_controllogic s)) + (create_state_state_incr s). + +Lemma add_instr_state_incr : + forall s n n' st, + (st_datapath s)!n = None -> + (st_controllogic s)!n = None -> + st_incr s + (mkstate + s.(st_st) + s.(st_freshreg) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + (AssocMap.set n st s.(st_datapath)) + (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))). +Proof. + constructor; intros; + try (simpl; destruct (peq n n0); subst); + auto with htlh. +Qed. + +Definition add_instr (n : node) (n' : node) (st : datapath_stmnt) : mon unit := fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with | left STM, left TRANS => @@ -176,14 +206,33 @@ Lemma add_instr_skip_state_incr : s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic))). + (AssocMap.set n (ctrl_vstmnt Vskip) s.(st_controllogic))). +Proof. + constructor; intros; + try (simpl; destruct (peq n n0); subst); + auto with htlh. +Qed. + +Lemma add_instr_wait_state_incr : + forall wait_mod s n n' st, + (st_datapath s)!n = None -> + (st_controllogic s)!n = None -> + st_incr s + (mkstate + s.(st_st) + s.(st_freshreg) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + (AssocMap.set n st s.(st_datapath)) + (AssocMap.set n (HTLwait wait_mod s.(st_st) (Vlit (posToValue n'))) s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); auto with htlh. Qed. -Definition add_instr_skip (n : node) (st : stmnt) : mon unit := +Definition add_instr_wait (wait_mod : ident) (n : node) (n' : node) (st : datapath_stmnt) : mon unit := fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with | left STM, left TRANS => @@ -194,7 +243,23 @@ Definition add_instr_skip (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic))) + (AssocMap.set n (HTLwait wait_mod s.(st_st) (Vlit (posToValue n'))) s.(st_controllogic))) + (add_instr_wait_state_incr wait_mod s n n' st STM TRANS) + | _, _ => Error (Errors.msg "HTL.add_instr_wait") + end. + +Definition add_instr_skip (n : node) (st : datapath_stmnt) : mon unit := + fun s => + match check_empty_node_datapath s n, check_empty_node_controllogic s n with + | left STM, left TRANS => + OK tt (mkstate + s.(st_st) + s.(st_freshreg) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + (AssocMap.set n st s.(st_datapath)) + (AssocMap.set n (ctrl_vstmnt Vskip) s.(st_controllogic))) (add_instr_skip_state_incr s n st STM TRANS) | _, _ => Error (Errors.msg "HTL.add_instr") end. @@ -210,7 +275,7 @@ Lemma add_node_skip_state_incr : (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) - (AssocMap.set n Vskip s.(st_datapath)) + (AssocMap.set n (data_vstmnt Vskip) s.(st_datapath)) (AssocMap.set n st s.(st_controllogic))). Proof. constructor; intros; @@ -218,7 +283,7 @@ Proof. auto with htlh. Qed. -Definition add_node_skip (n : node) (st : stmnt) : mon unit := +Definition add_node_skip (n : node) (st : control_stmnt) : mon unit := fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with | left STM, left TRANS => @@ -228,15 +293,12 @@ Definition add_node_skip (n : node) (st : stmnt) : mon unit := (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) - (AssocMap.set n Vskip s.(st_datapath)) + (AssocMap.set n (data_vstmnt Vskip) s.(st_datapath)) (AssocMap.set n st s.(st_controllogic))) (add_node_skip_state_incr s n st STM TRANS) | _, _ => Error (Errors.msg "HTL.add_instr") end. -Definition nonblock (dst : reg) (e : expr) := Vnonblock (Vvar dst) e. -Definition block (dst : reg) (e : expr) := Vblock (Vvar dst) e. - Definition bop (op : binop) (r1 r2 : reg) : expr := Vbinop op (Vvar r1) (Vvar r2). @@ -386,7 +448,7 @@ Lemma add_branch_instr_state_incr: (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) - (AssocMap.set n Vskip (st_datapath s)) + (AssocMap.set n (data_vstmnt Vskip) (st_datapath s)) (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))). Proof. intros. apply state_incr_intro; simpl; @@ -404,7 +466,7 @@ Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit := (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) - (AssocMap.set n Vskip (st_datapath s)) + (AssocMap.set n (data_vstmnt Vskip) (st_datapath s)) (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))) (add_branch_instr_state_incr s e n n1 n2 NSTM NTRANS) | _, _ => Error (Errors.msg "Htlgen: add_branch_instr") @@ -450,26 +512,33 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni match i with | Inop n' => if Z.leb (Z.pos n') Integers.Int.max_unsigned then - add_instr n n' Vskip + add_instr n n' (data_vstmnt Vskip) else error (Errors.msg "State is larger than 2^32.") | Iop op args dst n' => if Z.leb (Z.pos n') Integers.Int.max_unsigned then do instr <- translate_instr op args; do _ <- declare_reg None dst 32; - add_instr n n' (nonblock dst instr) + add_instr n n' (data_vstmnt (nonblock dst instr)) else error (Errors.msg "State is larger than 2^32.") | Iload mem addr args dst n' => if Z.leb (Z.pos n') Integers.Int.max_unsigned then do src <- translate_arr_access mem addr args stack; do _ <- declare_reg None dst 32; - add_instr n n' (nonblock dst src) + add_instr n n' (data_vstmnt (nonblock dst src)) else error (Errors.msg "State is larger than 2^32.") | Istore mem addr args src n' => if Z.leb (Z.pos n') Integers.Int.max_unsigned then do dst <- translate_arr_access mem addr args stack; - add_instr n n' (Vnonblock dst (Vvar src)) (* TODO: Could juse use add_instr? reg exists. *) + add_instr n n' (data_vstmnt (Vnonblock dst (Vvar src))) (* TODO: Could juse use add_instr? reg exists. *) + else error (Errors.msg "State is larger than 2^32.") + | Icall sig (inl fn) args dst n' => error (Errors.msg "Indirect calls are not implemented.") + | Icall sig (inr fn) args dst n' => + if Z.leb (Z.pos n') Integers.Int.max_unsigned then + do _ <- declare_reg None dst 32; + do join_state <- create_state; + do _ <- add_instr n join_state (HTLfork fn args); + add_instr_wait fn join_state n' (HTLjoin fn dst) else error (Errors.msg "State is larger than 2^32.") - | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.") | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.") | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.") | Icond cond args n1 n2 => @@ -484,9 +553,9 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni | Ireturn r => match r with | Some r' => - add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))) + add_instr_skip n (data_vstmnt (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r')))) | None => - add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))) + add_instr_skip n (data_vstmnt (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z))))) end end end. @@ -542,11 +611,11 @@ Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := Definition stack_correct (sz : Z) : bool := (0 <=? sz) && (sz <? Integers.Ptrofs.modulus) && (Z.modulo sz 4 =? 0). -Definition max_pc_map (m : Maps.PTree.t stmnt) := +Definition max_pc_map {A: Type} (m : Maps.PTree.t A) := PTree.fold (fun m pc i => Pos.max m pc) m 1%positive. Lemma max_pc_map_sound: - forall m pc i, m!pc = Some i -> Ple pc (max_pc_map m). + forall A m pc i, m!pc = Some i -> Ple pc (@max_pc_map A m). Proof. intros until i. unfold max_pc_function. apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m). @@ -561,8 +630,8 @@ Proof. Qed. Lemma max_pc_wf : - forall m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> - map_well_formed m. + forall T m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> + @map_well_formed T m. Proof. unfold map_well_formed. intros. exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x. @@ -600,7 +669,7 @@ Definition transf_module (f: function) : mon module := clk current_state.(st_scldecls) current_state.(st_arrdecls) - (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA))) + (conj (max_pc_wf _ _ LECTRL) (max_pc_wf _ _ LEDATA))) | _, _ => error (Errors.msg "More than 2^32 states.") end else error (Errors.msg "Stack size misalignment."). diff --git a/src/hls/HTLPargen.v b/src/hls/HTLPargen.v index 64996c6..b4291ea 100644 --- a/src/hls/HTLPargen.v +++ b/src/hls/HTLPargen.v @@ -57,8 +57,8 @@ Definition init_state (st : reg) : state := 1%positive (AssocMap.empty (option io * scl_decl)) (AssocMap.empty (option io * arr_decl)) - (AssocMap.empty stmnt) - (AssocMap.empty stmnt). + (AssocMap.empty datapath_stmnt) + (AssocMap.empty control_stmnt). Module HTLState <: State. @@ -516,13 +516,13 @@ Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := (st_controllogic s)) (create_arr_state_incr s sz ln i). -Definition max_pc_map (m : Maps.PTree.t stmnt) := +Definition max_pc_map {A: Type} (m : Maps.PTree.t A) := PTree.fold (fun m pc i => Pos.max m pc) m 1%positive. Lemma max_pc_map_sound: - forall m pc i, m!pc = Some i -> Ple pc (max_pc_map m). + forall A m pc i, m!pc = Some i -> Ple pc (@max_pc_map A m). Proof. - intros until i. + intros until i. unfold max_pc_function. apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m). (* extensionality *) intros. apply H0. rewrite H; auto. @@ -530,14 +530,13 @@ Proof. rewrite PTree.gempty. congruence. (* inductive case *) intros. rewrite PTree.gsspec in H2. destruct (peq pc k). - inv H2. unfold Ple, Plt in *. lia. - apply Ple_trans with a. auto. - unfold Ple, Plt in *. lia. + inv H2. xomega. + apply Ple_trans with a. auto. xomega. Qed. Lemma max_pc_wf : - forall m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> - map_well_formed m. + forall T m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> + @map_well_formed T m. Proof. unfold map_well_formed. intros. exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x. @@ -591,7 +590,8 @@ Definition add_data_instr (n : node) (st : stmnt) : mon unit := (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) - (AssocMap.set n (Vseq (AssocMapExt.get_default _ Vskip n s.(st_datapath)) st) s.(st_datapath)) + (AssocMap.set n (Vseq (AssocMapExt.get_default + _ Vskip n s.(st_datapath)) st) s.(st_datapath)) s.(st_controllogic)) (add_data_instr_state_incr s n st). diff --git a/src/hls/HTLgen.v b/src/hls/HTLgen.v index 3f4e513..04595af 100644 --- a/src/hls/HTLgen.v +++ b/src/hls/HTLgen.v @@ -21,13 +21,15 @@ Require Import Coq.micromega.Lia. Require Import compcert.lib.Maps. Require compcert.common.Errors. -Require compcert.common.Globalenvs. +Require Import compcert.lib.Integers. +Require Import compcert.common.Globalenvs. Require compcert.lib.Integers. Require Import compcert.common.AST. Require Import compcert.backend.RTL. Require Import vericert.common.Statemonad. Require Import vericert.common.Vericertlib. +Require Import vericert.common.Maps. Require Import vericert.hls.AssocMap. Require Import vericert.hls.HTL. Require Import vericert.hls.ValueInt. @@ -45,6 +47,7 @@ Record state: Type := mkstate { st_freshstate: node; st_scldecls: AssocMap.t (option io * scl_decl); st_arrdecls: AssocMap.t (option io * arr_decl); + st_externctrl : AssocMap.t (ident * controlsignal); st_datapath: datapath; st_controllogic: controllogic; }. @@ -55,38 +58,64 @@ Definition init_state (st : reg) : state := 1%positive (AssocMap.empty (option io * scl_decl)) (AssocMap.empty (option io * arr_decl)) - (AssocMap.empty stmnt) - (AssocMap.empty stmnt). + (AssocMap.empty (ident * controlsignal)) + (AssocMap.empty datapath_stmnt) + (AssocMap.empty control_stmnt). + +(** Describes a map that is created incrementally in the monad, i.e. only new + values can be added, not changed or deleted. *) +Definition map_incr {S B} (map : S -> PTree.t B) (s1 s2 : S) := + forall n, s1.(map)!n = None \/ + s2.(map)!n = s1.(map)!n. +Hint Unfold map_incr : htlh. Module HTLState <: State. Definition st := state. Inductive st_incr: state -> state -> Prop := - state_incr_intro: + | state_incr_intro: forall (s1 s2: state), - st_st s1 = st_st s2 -> - Ple s1.(st_freshreg) s2.(st_freshreg) -> - Ple s1.(st_freshstate) s2.(st_freshstate) -> - (forall n, - s1.(st_datapath)!n = None \/ s2.(st_datapath)!n = s1.(st_datapath)!n) -> - (forall n, - s1.(st_controllogic)!n = None - \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) -> - st_incr s1 s2. + st_st s1 = st_st s2 -> + Ple s1.(st_freshreg) s2.(st_freshreg) -> + Ple s1.(st_freshstate) s2.(st_freshstate) -> + map_incr st_datapath s1 s2 -> + map_incr st_controllogic s1 s2 -> + map_incr st_externctrl s1 s2 -> + (forall n, (st_externctrl s1) ! n = None -> + (exists x, (st_externctrl s2) ! n = Some x) -> + (n >= st_freshreg s1)%positive) -> + st_incr s1 s2. #[export] Hint Constructors st_incr : htlh. Definition st_prop := st_incr. #[export] Hint Unfold st_prop : htlh. - Lemma st_refl : forall s, st_prop s s. Proof. auto with htlh. Qed. + Lemma st_refl : forall s, st_prop s s. + Proof. split; try solve [ auto with htlh; crush ]. Qed. Lemma st_trans : forall s1 s2 s3, st_prop s1 s2 -> st_prop s2 s3 -> st_prop s1 s3. Proof. - intros. inv H. inv H0. apply state_incr_intro; eauto using Ple_trans; intros; try congruence. - - destruct H4 with n; destruct H8 with n; intuition congruence. - - destruct H5 with n; destruct H9 with n; intuition congruence. + intros * H0 H1. inv H0. inv H1. + split; autounfold with htlh in *; intros; try solve [crush]. + - destruct H4 with n; destruct H10 with n; intuition crush. + - destruct H5 with n; destruct H11 with n; intuition crush. + - destruct H6 with n; destruct H12 with n; intuition crush. + - destruct H6 with n; destruct H12 with n. + + specialize (H13 n ltac:(auto) ltac:(auto)). + crush. + + apply H7; auto. + rewrite <- H16. + auto. + + specialize (H13 n ltac:(auto) ltac:(auto)). + unfold Ple in *. + lia. + + contradict H14. + rewrite H16. + rewrite H15. + rewrite H1. + intuition crush. Qed. End HTLState. @@ -99,12 +128,28 @@ Module HTLMonadExtra := Monad.MonadExtra(HTLMonad). Import HTLMonadExtra. Export MonadNotation. -Definition state_goto (st : reg) (n : node) : stmnt := +Definition bop (op : binop) (r1 r2 : reg) : expr := + Vbinop op (Vvar r1) (Vvar r2). + +Definition boplit (op : binop) (r : reg) (l : Integers.int) : expr := + Vbinop op (Vvar r) (Vlit (intToValue l)). + +Definition boplitz (op: binop) (r: reg) (l: Z) : expr := + Vbinop op (Vvar r) (Vlit (ZToValue l)). + +Definition state_goto (st : reg) (n : node) : control_stmnt := Vnonblock (Vvar st) (Vlit (posToValue n)). -Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : stmnt := +Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : control_stmnt := Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2)). +Definition state_wait (st wait_reg : reg) (n : node) : control_stmnt := + Vcond (boplitz Veq wait_reg 1) (Vnonblock (Vvar st) (posToExpr n)) Vskip. + +Definition nonblock (dst : reg) (e : expr) := (Vnonblock (Vvar dst) e). + +Definition block (dst : reg) (e : expr) := (Vblock (Vvar dst) e). + Definition check_empty_node_datapath: forall (s: state) (n: node), { s.(st_datapath)!n = None } + { True }. Proof. @@ -117,146 +162,140 @@ Proof. intros. case (s.(st_controllogic)!n); tauto. Defined. -Lemma add_instr_state_incr : - forall s n n' st, - (st_datapath s)!n = None -> - (st_controllogic s)!n = None -> - st_incr s - (mkstate - s.(st_st) - s.(st_freshreg) - (st_freshstate s) - s.(st_scldecls) - s.(st_arrdecls) - (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))). +Definition check_unmapped_externctrl: + forall (s: state) (n: reg), { s.(st_externctrl)!n = None } + { True }. Proof. - constructor; intros; - try (simpl; destruct (peq n n0); subst); - auto with htlh. -Qed. + intros. case (s.(st_externctrl)!n); tauto. +Defined. -Lemma declare_reg_state_incr : - forall i s r sz, - st_incr s - (mkstate - s.(st_st) - s.(st_freshreg) - s.(st_freshstate) - (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) - s.(st_arrdecls) - s.(st_datapath) - s.(st_controllogic)). -Proof. auto with htlh. Qed. +(** Used for discharging the st_incr proof in simple operations *) +Local Ltac st_tac := + constructor; autounfold with htlh in *; intros; simpl; auto with htlh; + match goal with + | [ H : (?map ?s) ! ?n = None, n' : positive |- _] => destruct (peq n n') + end; + subst; auto with htlh; intuition crush. Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit := fun s => OK tt (mkstate - s.(st_st) - s.(st_freshreg) - s.(st_freshstate) - (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) - s.(st_arrdecls) - s.(st_datapath) - s.(st_controllogic)) - (declare_reg_state_incr i s r sz). - -Definition add_instr (n : node) (n' : node) (st : stmnt) : mon unit := - fun s => - match check_empty_node_datapath s n, check_empty_node_controllogic s n with - | left STM, left TRANS => - OK tt (mkstate + (st_st s) + (st_freshreg s) + (st_freshstate s) + (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) + (st_arrdecls s) + (st_externctrl s) + (st_datapath s) + (st_controllogic s)) ltac:(st_tac). + +Definition create_reg (i : option io) (sz : nat) : mon reg := + fun s => let r := s.(st_freshreg) in + OK r (mkstate + (st_st s) + (Pos.succ r) + (st_freshstate s) + (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) + (st_arrdecls s) + (st_externctrl s) + (st_datapath s) + (st_controllogic s)) ltac:(st_tac). + +Definition map_externctrl (othermod : ident) (ctrl : controlsignal) : mon reg. + refine ( + fun s => match check_unmapped_externctrl s (st_freshreg s) with + | left CTRL => OK (st_freshreg s) (mkstate + (st_st s) + (Pos.succ (st_freshreg s)) + (st_freshstate s) + (st_scldecls s) + (st_arrdecls s) + (AssocMap.set (st_freshreg s) (othermod, ctrl) (st_externctrl s)) + (st_datapath s) + (st_controllogic s)) _ + | right CTRL => Error (Errors.msg "HTL.map_externctrl") + end). + st_tac. + rewrite PTree.gsspec in *. + destruct_match; crush. +Defined. + +Definition create_state : mon node. + refine (fun s => let r := s.(st_freshstate) in + if Z.leb (Z.pos s.(st_freshstate)) Integers.Int.max_unsigned + then OK r (mkstate + (st_st s) + (st_freshreg s) + (Pos.succ (st_freshstate s)) + (st_scldecls s) + (st_arrdecls s) + (st_externctrl s) + (st_datapath s) + (st_controllogic s)) _ + else Error (Errors.msg "HTL.create_state")). + split; autounfold with htlh; crush. +Defined. + +Lemma create_state_max : forall s s' i x, create_state s = OK x s' i -> Z.pos x <= Int.max_unsigned. +Admitted. + +Definition add_instr (n : node) (n' : node) (st : datapath_stmnt) : mon unit := + fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with + | left STM, left TRANS => + OK tt (mkstate s.(st_st) s.(st_freshreg) (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) + (st_externctrl s) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))) - (add_instr_state_incr s n n' st STM TRANS) - | _, _ => Error (Errors.msg "HTL.add_instr") - end. - -Lemma add_instr_skip_state_incr : - forall s n st, - (st_datapath s)!n = None -> - (st_controllogic s)!n = None -> - st_incr s - (mkstate - s.(st_st) - s.(st_freshreg) - (st_freshstate s) - s.(st_scldecls) - s.(st_arrdecls) - (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic))). -Proof. - constructor; intros; - try (simpl; destruct (peq n n0); subst); - auto with htlh. -Qed. - -Definition add_instr_skip (n : node) (st : stmnt) : mon unit := - fun s => - match check_empty_node_datapath s n, check_empty_node_controllogic s n with - | left STM, left TRANS => - OK tt (mkstate + (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))) ltac:(st_tac) + | _, _ => Error (Errors.msg "HTL.add_instr") + end. + +Definition add_instr_wait (wait_reg : reg) (n : node) (n' : node) (st : datapath_stmnt) : mon unit := + fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with + | left STM, left TRANS => + OK tt (mkstate s.(st_st) s.(st_freshreg) (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) + (st_externctrl s) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic))) - (add_instr_skip_state_incr s n st STM TRANS) - | _, _ => Error (Errors.msg "HTL.add_instr") - end. - -Lemma add_node_skip_state_incr : - forall s n st, - (st_datapath s)!n = None -> - (st_controllogic s)!n = None -> - st_incr s - (mkstate - s.(st_st) - s.(st_freshreg) - (st_freshstate s) - s.(st_scldecls) - s.(st_arrdecls) - (AssocMap.set n Vskip s.(st_datapath)) - (AssocMap.set n st s.(st_controllogic))). -Proof. - constructor; intros; - try (simpl; destruct (peq n n0); subst); - auto with htlh. -Qed. - -Definition add_node_skip (n : node) (st : stmnt) : mon unit := - fun s => - match check_empty_node_datapath s n, check_empty_node_controllogic s n with - | left STM, left TRANS => - OK tt (mkstate + (AssocMap.set n (state_wait (st_st s) wait_reg n') s.(st_controllogic))) ltac:(st_tac) + | _, _ => Error (Errors.msg "HTL.add_instr_wait") + end. + +Definition add_instr_skip (n : node) (st : datapath_stmnt) : mon unit := + fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with + | left STM, left TRANS => + OK tt (mkstate + s.(st_st) + s.(st_freshreg) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + (st_externctrl s) + (AssocMap.set n st s.(st_datapath)) + (AssocMap.set n Vskip s.(st_controllogic))) ltac:(st_tac) + | _, _ => Error (Errors.msg "HTL.add_instr") + end. + +Definition add_node_skip (n : node) (st : control_stmnt) : mon unit := + fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with + | left STM, left TRANS => + OK tt (mkstate s.(st_st) s.(st_freshreg) (st_freshstate s) s.(st_scldecls) s.(st_arrdecls) + (st_externctrl s) (AssocMap.set n Vskip s.(st_datapath)) - (AssocMap.set n st s.(st_controllogic))) - (add_node_skip_state_incr s n st STM TRANS) - | _, _ => Error (Errors.msg "HTL.add_instr") - end. - -Definition nonblock (dst : reg) (e : expr) := Vnonblock (Vvar dst) e. -Definition block (dst : reg) (e : expr) := Vblock (Vvar dst) e. - -Definition bop (op : binop) (r1 r2 : reg) : expr := - Vbinop op (Vvar r1) (Vvar r2). - -Definition boplit (op : binop) (r : reg) (l : Integers.int) : expr := - Vbinop op (Vvar r) (Vlit (intToValue l)). - -Definition boplitz (op: binop) (r: reg) (l: Z) : expr := - Vbinop op (Vvar r) (Vlit (ZToValue l)). + (AssocMap.set n st s.(st_controllogic))) ltac:(st_tac) + | _, _ => Error (Errors.msg "HTL.add_instr") + end. Definition translate_comparison (c : Integers.comparison) (args : list reg) : mon expr := match c, args with @@ -370,10 +409,12 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr := | Op.Oshlimm n, r::nil => ret (boplit Vshl r n) | Op.Oshr, r1::r2::nil => ret (bop Vshr r1 r2) | Op.Oshrimm n, r::nil => ret (boplit Vshr r n) - | Op.Oshrximm n, r::nil => - ret (Vternary (Vbinop Vlt (Vvar r) (Vlit (ZToValue 0))) - (Vunop Vneg (Vbinop Vshru (Vunop Vneg (Vvar r)) (Vlit n))) - (Vbinop Vshru (Vvar r) (Vlit n))) + | Op.Oshrximm n, r::nil => ret (Vternary (Vbinop Vlt (Vvar r) (Vlit (ZToValue 0))) + (Vunop Vneg (Vbinop Vshru (Vunop Vneg (Vvar r)) (Vlit n))) + (Vbinop Vshru (Vvar r) (Vlit n))) + (*ret (Vbinop Vdiv (Vvar r) + (Vbinop Vshl (Vlit (ZToValue 1)) + (Vlit (intToValue n))))*) | Op.Oshru, r1::r2::nil => ret (bop Vshru r1 r2) | Op.Oshruimm n, r::nil => ret (boplit Vshru r n) | Op.Ororimm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Ororimm") @@ -388,39 +429,20 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr := | _, _ => error (Errors.msg "Htlgen: Instruction not implemented: other") end. -Lemma add_branch_instr_state_incr: - forall s e n n1 n2, - (st_datapath s) ! n = None -> - (st_controllogic s) ! n = None -> - st_incr s (mkstate - s.(st_st) - (st_freshreg s) - (st_freshstate s) - s.(st_scldecls) - s.(st_arrdecls) - (AssocMap.set n Vskip (st_datapath s)) - (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))). -Proof. - intros. apply state_incr_intro; simpl; - try (intros; destruct (peq n0 n); subst); - auto with htlh. -Qed. - Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit := - fun s => - match check_empty_node_datapath s n, check_empty_node_controllogic s n with - | left NSTM, left NTRANS => - OK tt (mkstate + fun s => match check_empty_node_datapath s n, check_empty_node_controllogic s n with + | left NSTM, left NTRANS => + OK tt (mkstate s.(st_st) - (st_freshreg s) - (st_freshstate s) - s.(st_scldecls) - s.(st_arrdecls) - (AssocMap.set n Vskip (st_datapath s)) - (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))) - (add_branch_instr_state_incr s e n n1 n2 NSTM NTRANS) - | _, _ => Error (Errors.msg "Htlgen: add_branch_instr") - end. + (st_freshreg s) + (st_freshstate s) + s.(st_scldecls) + s.(st_arrdecls) + (st_externctrl s) + (AssocMap.set n Vskip (st_datapath s)) + (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))) ltac:(st_tac) + | _, _ => Error (Errors.msg "Htlgen: add_branch_instr") + end. Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing) (args : list reg) (stack : reg) : mon expr := @@ -456,7 +478,48 @@ Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) := end) (enumerate 0 ns). -Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon unit := +Fixpoint nonblock_all pairs := + match pairs with + | (dst, src) :: pairs' => Vseq (nonblock dst (Vvar src)) (nonblock_all pairs') + | nil => Vskip + end. + +(** [fork] a datapath statement which sets up the execution of a function *) +Definition fork (rst : reg) (params : list (reg * reg)) : datapath_stmnt := + let reset_mod := Vnonblock (Vvar rst) (posToLit 1) in + let assign_params := nonblock_all params in + Vseq reset_mod assign_params. + +Definition join (fn_fin fn_rst fn_rtrn fn_dst : reg) : datapath_stmnt := + let set_result := Vcond (boplitz Veq fn_fin 1) + (Vnonblock (Vvar fn_dst) (Vvar fn_rtrn)) Vskip in + let stop_reset := Vnonblock (Vvar fn_rst) (Vlit (ZToValue 0)) in + Vseq stop_reset set_result. + +Definition return_val r := + match r with + | Some r' => Vvar r' + | None => Vlit (ZToValue 0%Z) + end. + +Definition do_return fin rtrn r := + Vseq (block fin (Vlit (ZToValue 1%Z))) + (block rtrn (return_val r)). + +Definition idle fin := nonblock fin (Vlit (ZToValue 0%Z)). + +Fixpoint xmap_externctrl_params (n : nat) (fn : ident) (l : list reg) := + match l with + | nil => ret nil + | arg::args => + do param_reg <- map_externctrl fn (ctrl_param n); + do rest <- xmap_externctrl_params (S n) fn args; + ret ((param_reg, arg) :: rest) + end. + +Definition map_externctrl_params := xmap_externctrl_params 0. + +Definition transf_instr (ge : RTL.genv) (fin rtrn stack: reg) (ni: node * instruction) : mon unit := match ni with (n, i) => match i with @@ -481,7 +544,28 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni do dst <- translate_arr_access mem addr args stack; add_instr n n' (Vnonblock dst (Vvar src)) (* TODO: Could juse use add_instr? reg exists. *) else error (Errors.msg "State is larger than 2^32.") - | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.") + | Icall sig (inl fn) args dst n' => error (Errors.msg "Indirect calls are not implemented.") + | Icall sig (inr fn) args dst n' => + if Z.leb (Z.pos n') Integers.Int.max_unsigned + then match find_func ge fn with + | Some (AST.Internal _) => + do params <- map_externctrl_params fn args; + + do _ <- declare_reg None dst 32; + do join_state <- create_state; + + do finish_reg <- map_externctrl fn ctrl_finish; + do reset_reg <- map_externctrl fn ctrl_reset; + do return_reg <- map_externctrl fn ctrl_return; + + let fork_instr := fork reset_reg params in + let join_instr := join finish_reg reset_reg return_reg dst in + + do _ <- add_instr n join_state fork_instr; + add_instr_wait finish_reg join_state n' join_instr + | _ => error (Errors.msg "Call to non-internal function") + end + else error (Errors.msg "State is larger than 2^32.") | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.") | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.") | Icond cond args n1 n2 => @@ -494,71 +578,31 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni add_node_skip n (Vcase (Vvar r) (tbl_to_case_expr s.(st_st) tbl) (Some Vskip))*) error (Errors.msg "Ijumptable: Case statement not supported.") | Ireturn r => - match r with - | Some r' => - add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))) - | None => - add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))) - end + do idle_state <- create_state; + do _ <- add_instr n idle_state (do_return fin rtrn r); + add_instr_skip idle_state (idle fin) end end. -Lemma create_reg_state_incr: - forall s sz i, - st_incr s (mkstate - s.(st_st) - (Pos.succ (st_freshreg s)) - (st_freshstate s) - (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) - s.(st_arrdecls) - (st_datapath s) - (st_controllogic s)). -Proof. constructor; simpl; auto with htlh. Qed. - -Definition create_reg (i : option io) (sz : nat) : mon reg := - fun s => let r := s.(st_freshreg) in - OK r (mkstate - s.(st_st) - (Pos.succ r) - (st_freshstate s) - (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) - (st_arrdecls s) - (st_datapath s) - (st_controllogic s)) - (create_reg_state_incr s sz i). - -Lemma create_arr_state_incr: - forall s sz ln i, - st_incr s (mkstate - s.(st_st) - (Pos.succ (st_freshreg s)) - (st_freshstate s) - s.(st_scldecls) - (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) - (st_datapath s) - (st_controllogic s)). -Proof. constructor; simpl; auto with htlh. Qed. - Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := fun s => let r := s.(st_freshreg) in - OK (r, ln) (mkstate - s.(st_st) - (Pos.succ r) - (st_freshstate s) - s.(st_scldecls) - (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) - (st_datapath s) - (st_controllogic s)) - (create_arr_state_incr s sz ln i). + OK (r, ln) (mkstate + s.(st_st) + (Pos.succ r) + (st_freshstate s) + s.(st_scldecls) + (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) + (st_externctrl s) + (st_datapath s) + (st_controllogic s)) ltac:(st_tac). Definition stack_correct (sz : Z) : bool := (0 <=? sz) && (sz <? Integers.Ptrofs.modulus) && (Z.modulo sz 4 =? 0). -Definition max_pc_map (m : Maps.PTree.t stmnt) := - PTree.fold (fun m pc i => Pos.max m pc) m 1%positive. +Definition declare_params params := collectlist (fun r => declare_reg (Some Vinput) r 32) params. -Lemma max_pc_map_sound: - forall m pc i, m!pc = Some i -> Ple pc (max_pc_map m). +Lemma max_pc_map_sound {A} : + forall (m : PTree.t A) pc i, m!pc = Some i -> Ple pc (max_pc_map m). Proof. intros until i. unfold max_pc_function. apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m). @@ -572,39 +616,28 @@ Proof. apply Ple_trans with a. auto. unfold Ple; lia. Qed. -Lemma max_pc_wf : - forall m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> - map_well_formed m. +Lemma max_pc_wf {A} : + forall (m : PTree.t A), Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> + map_well_formed m. Proof. unfold map_well_formed. intros. - exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x. - apply Maps.PTree.elements_complete in B. apply max_pc_map_sound in B. - unfold Ple in B. apply Pos2Z.pos_le_pos in B. subst. + exploit list_in_map_inv. eassumption. intros [x [H1 H2]]. destruct x. + apply Maps.PTree.elements_complete in H2. apply max_pc_map_sound in H2. + unfold Ple in H2. apply Pos2Z.pos_le_pos in H2. subst. simplify. transitivity (Z.pos (max_pc_map m)); eauto. Qed. -Definition decide_order a b c d e f g : {module_ordering a b c d e f g} + {True}. - refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) - && (d <? e) && (e <? f) && (f <? g))%positive true with - | left t => left _ - | _ => _ - end); auto. - simplify; repeat match goal with - | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H - end; unfold module_ordering; auto. -Defined. - -Definition transf_module (f: function) : mon HTL.module. +Definition transf_module (ge : RTL.genv) (main : ident) (f: function) : mon HTL.module. refine ( if stack_correct f.(fn_stacksize) then + do _ <- declare_params (RTL.fn_params f); do fin <- create_reg (Some Voutput) 1; do rtrn <- create_reg (Some Voutput) 32; do (stack, stack_len) <- create_arr None 32 (Z.to_nat (f.(fn_stacksize) / 4)); - do _ <- collectlist (transf_instr fin rtrn stack) (Maps.PTree.elements f.(RTL.fn_code)); - do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32) f.(RTL.fn_params); do start <- create_reg (Some Vinput) 1; do rst <- create_reg (Some Vinput) 1; do clk <- create_reg (Some Vinput) 1; + do _ <- collectlist (transf_instr ge fin rtrn stack) (Maps.PTree.elements f.(RTL.fn_code)); do current_state <- get; match zle (Z.pos (max_pc_map current_state.(st_datapath))) Integers.Int.max_unsigned, zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned, @@ -627,6 +660,7 @@ Definition transf_module (f: function) : mon HTL.module. clk current_state.(st_scldecls) current_state.(st_arrdecls) + current_state.(st_externctrl) None (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) MORD @@ -644,13 +678,23 @@ Definition max_state (f: function) : state := (Pos.succ (RTL.max_pc_function f)) (AssocMap.set st (None, VScalar 32) (st_scldecls (init_state st))) (st_arrdecls (init_state st)) + (st_externctrl (init_state st)) (st_datapath (init_state st)) (st_controllogic (init_state st)). -Definition transl_module (f : function) : Errors.res HTL.module := - run_mon (max_state f) (transf_module f). +Definition prog_funmap (prog : RTL.program) : (PTree.t RTL.fundef) := + AssocMap_Properties.of_list ( + Option.map_option (fun '(ident, def) => match def with + | AST.Gfun f => Some (ident, f) + | _ => None + end) + (AST.prog_defs prog) + ). + +Definition transl_module (prog : RTL.program) (f : function) : Errors.res HTL.module := + run_mon (max_state f) (transf_module (Globalenvs.Genv.globalenv prog) (AST.prog_main prog) f). -Definition transl_fundef := transf_partial_fundef transl_module. +Definition transl_fundef prog := transf_partial_fundef (transl_module prog). Definition main_is_internal (p : RTL.program) : bool := let ge := Globalenvs.Genv.globalenv p in @@ -663,7 +707,77 @@ Definition main_is_internal (p : RTL.program) : bool := | _ => false end. +Definition ainstack_instr i := + match i with + | Iop (Op.Olea (Op.Ainstack _)) _ _ _ => True + | Iop (Op.Oleal (Op.Ainstack _)) _ _ _ => True + | _ => False + end. + +Definition ainstack_instr_dec : forall i, {ainstack_instr i} + {~ ainstack_instr i}. +Proof. destruct i; crush. destruct o; crush; destruct a; crush. Defined. + +Definition no_ainstack (c : code) : Prop := + Forall (fun '(_, i) => ~ ainstack_instr i) (PTree.elements c). + +Definition no_ainstack_dec (c : code) : {no_ainstack c} + {~ no_ainstack c}. +Proof. + apply Forall_dec. + intros [? ?]. + destruct (ainstack_instr_dec i); auto. +Defined. + +Definition only_main_has_ainstack (p : RTL.program) : Prop := + Forall (fun '(name, blk) => + forall f, + name <> (AST.prog_main p) -> + Genv.find_funct_ptr (Genv.globalenv p) blk = Some (AST.Internal f) -> + no_ainstack (fn_code f)) + (PTree.elements (Genv.genv_symb (Genv.globalenv p))). + +Definition only_main_has_ainstack_dec (p : RTL.program) : {only_main_has_ainstack p} + {~ only_main_has_ainstack p}. +Proof. + apply Forall_dec. intros [? ?]. + destruct (peq i (prog_main p)); try solve [left; crush]. + destruct (Genv.find_funct_ptr (Genv.globalenv p) b); try solve [left; crush]. + destruct f; try solve [left; crush]. + destruct (no_ainstack_dec (fn_code f)). + all: solve [ constructor; crush ]. +Defined. + +Definition no_calls_to (name : AST.ident) (c : RTL.code) : Prop := + Forall (fun '(_, instr) => + match instr with + | Icall _ (inr name') _ _ _ => name <> name' + | _ => True + end) + (PTree.elements c). + +Definition no_calls_to_dec (name : AST.ident) (c : RTL.code) : {no_calls_to name c} + {~ no_calls_to name c}. +Proof. + apply Forall_dec. intros [? ?]. + destruct i; crush. + destruct s0; crush. + destruct (Pos.eq_dec name i); crush. +Qed. + +Definition main_not_called (p : RTL.program) : Prop := + Forall (fun '(_, blk) => + forall f, + Genv.find_funct_ptr (Genv.globalenv p) blk = Some (AST.Internal f) -> + no_calls_to (AST.prog_main p) (fn_code f)) + (PTree.elements (Genv.genv_symb (Genv.globalenv p))). + +Definition main_not_called_dec (p : RTL.program) : {main_not_called p} + {~ main_not_called p}. +Proof. + apply Forall_dec. intros [? ?]. + destruct (Genv.find_funct_ptr (Genv.globalenv p) b); try solve [left; crush]. + destruct f; try solve [left; crush]. + destruct (no_calls_to_dec (prog_main p) (fn_code f)). + all: solve [constructor; crush]. +Qed. + Definition transl_program (p : RTL.program) : Errors.res HTL.program := - if main_is_internal p - then transform_partial_program transl_fundef p + if main_is_internal p && only_main_has_ainstack_dec p && main_not_called_dec p + then transform_partial_program (transl_fundef p) p else Errors.Error (Errors.msg "Main function is not Internal."). diff --git a/src/hls/HTLgenproof.v b/src/hls/HTLgenproof.v index fc7af6b..77c8c04 100644 --- a/src/hls/HTLgenproof.v +++ b/src/hls/HTLgenproof.v @@ -24,10 +24,12 @@ Require Import compcert.common.Globalenvs. Require Import compcert.common.Linking. Require Import compcert.common.Memory. Require Import compcert.lib.Integers. +Require Import compcert.lib.Maps. Require Import vericert.common.IntegerExtra. Require Import vericert.common.Vericertlib. Require Import vericert.common.ZExtra. +Require Import vericert.common.ListExtra. Require Import vericert.hls.Array. Require Import vericert.hls.AssocMap. Require vericert.hls.HTL. @@ -38,14 +40,20 @@ Require vericert.hls.Verilog. Require Import Lia. +From Hammer Require Import Tactics. +Set Nested Proofs Allowed. + Local Open Scope assocmap. #[local] Hint Resolve Smallstep.forward_simulation_plus : htlproof. #[local] Hint Resolve AssocMap.gss : htlproof. #[local] Hint Resolve AssocMap.gso : htlproof. +#[local] Hint Resolve RTL.max_reg_function_def : htlproof. #[local] Hint Unfold find_assocmap AssocMapExt.get_default : htlproof. +Hint Constructors val_value_lessdef : htlproof. + Inductive match_assocmaps : RTL.function -> RTL.regset -> assocmap -> Prop := match_assocmap : forall f rs am, (forall r, Ple r (RTL.max_reg_function f) -> @@ -54,12 +62,12 @@ Inductive match_assocmaps : RTL.function -> RTL.regset -> assocmap -> Prop := #[local] Hint Constructors match_assocmaps : htlproof. Definition state_st_wf (m : HTL.module) (s : HTL.state) := - forall st asa asr res, - s = HTL.State res m st asa asr -> + forall mid st asa asr res, + s = HTL.State res mid m st asa asr -> asa!(m.(HTL.mod_st)) = Some (posToValue st). #[local] Hint Unfold state_st_wf : htlproof. -Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : mem) : +Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : Memory.mem) : Verilog.assocmap_arr -> Prop := | match_arr : forall asa stack, asa ! (m.(HTL.mod_stk)) = Some stack /\ @@ -78,6 +86,12 @@ Definition stack_based (v : Values.val) (sp : Values.block) : Prop := | _ => True end. +Definition not_pointer (v : Values.val) : Prop := + match v with + | Values.Vptr _ _ => False + | _ => True + end. + Definition reg_stack_based_pointers (sp : Values.block) (rs : Registers.Regmap.t Values.val) : Prop := forall r, stack_based (Registers.Regmap.get r rs) sp. @@ -98,10 +112,6 @@ Definition stack_bounds (sp : Values.val) (hi : Z) (m : mem) : Prop := Mem.loadv AST.Mint32 m (Values.Val.offset_ptr sp (Integers.Ptrofs.repr ptr )) = None /\ Mem.storev AST.Mint32 m (Values.Val.offset_ptr sp (Integers.Ptrofs.repr ptr )) v = None. -Inductive match_frames : list RTL.stackframe -> list HTL.stackframe -> Prop := -| match_frames_nil : - match_frames nil nil. - Inductive match_constants : HTL.module -> assocmap -> Prop := match_constant : forall m asr, @@ -109,56 +119,133 @@ Inductive match_constants : HTL.module -> assocmap -> Prop := asr!(HTL.mod_finish m) = Some (ZToValue 0) -> match_constants m asr. -Inductive match_states : RTL.state -> HTL.state -> Prop := -| match_state : forall asa asr sf f sp sp' rs mem m st res +(** The caller needs to have externctrl signals for the current module *) +Definition has_externctrl (caller : HTL.module) (current_id : HTL.ident) (ret rst fin : HTL.reg) := + (HTL.mod_externctrl caller)!ret = Some (current_id, HTL.ctrl_return) /\ + (HTL.mod_externctrl caller)!rst = Some (current_id, HTL.ctrl_reset) /\ + (HTL.mod_externctrl caller)!fin = Some (current_id, HTL.ctrl_finish). +Hint Unfold has_externctrl : htlproof. + +Definition match_externctrl m asr := + forall r mid, (HTL.mod_externctrl m) ! r = Some (mid, HTL.ctrl_finish) -> + asr # r = ZToValue 0. + +Definition sp_valid sp := exists blk, sp = Values.Vptr blk Ptrofs.zero. + +Definition nil_stack_base_sp (rtl_stk : list RTL.stackframe) (sp : Values.val) (blk : Values.block) := + rtl_stk = nil /\ sp = Values.Vptr blk Ptrofs.zero. + +Inductive stack_base_sp : list RTL.stackframe -> Values.block -> Prop := + | stack_base_sp_one : forall blk dst f pc rs, + stack_base_sp (RTL.Stackframe dst f (Values.Vptr blk Ptrofs.zero) pc rs :: nil) + blk + | stack_base_sp_cons : forall stk_tl blk blk' dst f pc rs, + stack_base_sp stk_tl blk' -> + stack_base_sp (RTL.Stackframe dst f (Values.Vptr blk Ptrofs.zero) pc rs :: stk_tl) + blk'. +Hint Constructors stack_base_sp : htlproof. + +Inductive match_frames (ge : RTL.genv) (current_id : HTL.ident) (mem : Memory.mem) + : (list RTL.stackframe) -> (list HTL.stackframe) -> Prop := +| match_frames_nil : + match_frames ge current_id mem nil nil +| match_frames_cons : + forall dst f sp blk rs mid m pc st asr asa rtl_tl htl_tl ret rst fin + (MASSOC : match_assocmaps f rs asr) + (TF : tr_module ge f m) + (MARR : match_arrs m f sp mem asa) + (SP_VALID : sp_valid sp) + (SP_BASE : nil_stack_base_sp rtl_tl sp blk \/ stack_base_sp rtl_tl blk) + (RSBP : reg_stack_based_pointers blk rs) + (ASBP : arr_stack_based_pointers blk mem (f.(RTL.fn_stacksize)) sp) + (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem) + (CONST : match_constants m asr) + (EXTERN_CALLER : has_externctrl m current_id ret rst fin) + (MEXTERNCTRL : match_externctrl m asr) + (JOIN_CTRL : (HTL.mod_controllogic m)!st = Some (state_wait (HTL.mod_st m) fin pc)) + (JOIN_DATA : (HTL.mod_datapath m)!st = Some (join fin rst ret dst)) + (TAILS : match_frames ge mid mem rtl_tl htl_tl) + (DST : Ple dst (RTL.max_reg_function f)) + (PC : (Z.pos pc <= Int.max_unsigned)), + match_frames ge current_id mem + ((RTL.Stackframe dst f sp pc rs ) :: rtl_tl) + ((HTL.Stackframe mid m st asr asa) :: htl_tl). +Hint Constructors match_frames : htlproof. + +Inductive match_states (ge : RTL.genv) : RTL.state -> HTL.state -> Prop := +| match_state : forall asa asr rtl_stk f sp blk rs mem mid m st htl_stk (MASSOC : match_assocmaps f rs asr) - (TF : tr_module f m) - (WF : state_st_wf m (HTL.State res m st asr asa)) - (MF : match_frames sf res) + (TF : tr_module ge f m) + (WF : state_st_wf m (HTL.State htl_stk mid m st asr asa)) + (MF : match_frames ge mid mem rtl_stk htl_stk) (MARR : match_arrs m f sp mem asa) - (SP : sp = Values.Vptr sp' (Integers.Ptrofs.repr 0)) - (RSBP : reg_stack_based_pointers sp' rs) - (ASBP : arr_stack_based_pointers sp' mem (f.(RTL.fn_stacksize)) sp) + (SP_VALID : sp_valid sp) + (SP_BASE : nil_stack_base_sp rtl_stk sp blk \/ stack_base_sp rtl_stk blk) + (RSBP : reg_stack_based_pointers blk rs) + (ASBP : arr_stack_based_pointers blk mem (f.(RTL.fn_stacksize)) sp) (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem) - (CONST : match_constants m asr), - match_states (RTL.State sf f sp st rs mem) - (HTL.State res m st asr asa) + (CONST : match_constants m asr) + (MEXTERNCTRL : match_externctrl m asr), + match_states ge + (RTL.State rtl_stk f sp st rs mem) + (HTL.State htl_stk mid m st asr asa ) | match_returnstate : - forall - v v' stack mem res - (MF : match_frames stack res), - val_value_lessdef v v' -> - match_states (RTL.Returnstate stack v mem) (HTL.Returnstate res v') -| match_initial_call : - forall f m m0 - (TF : tr_module f m), - match_states (RTL.Callstate nil (AST.Internal f) nil m0) (HTL.Callstate nil m nil). + forall v v' rtl_stk htl_stk mem mid sp blk + (MF : match_frames ge mid mem rtl_stk htl_stk) + (SP_BASE : nil_stack_base_sp rtl_stk sp blk \/ stack_base_sp rtl_stk blk) + (RV_BASED : stack_based v blk) + (MV : val_value_lessdef v v'), + match_states ge + (RTL.Returnstate rtl_stk v mem) + (HTL.Returnstate htl_stk mid v' ) +| match_call : + forall f m rtl_args htl_args mid mem rtl_stk htl_stk sp blk + (TF : tr_module ge f m) + (MF : match_frames ge mid mem rtl_stk htl_stk) + (SP_BASE : nil_stack_base_sp rtl_stk sp blk \/ stack_base_sp rtl_stk blk) + (INIT_CALL_NO_ARGS : rtl_stk = nil -> rtl_args = nil) + (ARGS_BASED : Forall (fun a => stack_based a blk) rtl_args) + (MARGS : list_forall2 val_value_lessdef rtl_args htl_args), + match_states ge + (RTL.Callstate rtl_stk (AST.Internal f) rtl_args mem) + (HTL.Callstate htl_stk mid m htl_args). #[local] Hint Constructors match_states : htlproof. Definition match_prog (p: RTL.program) (tp: HTL.program) := - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp /\ - main_is_internal p = true. + Linking.match_program (fun cu f tf => transl_fundef p f = Errors.OK tf) eq p tp /\ + main_is_internal p = true /\ + only_main_has_stack p. Instance TransfHTLLink (tr_fun: RTL.program -> Errors.res HTL.program): TransfLink (fun (p1: RTL.program) (p2: HTL.program) => match_prog p1 p2). Proof. - red. intros. exfalso. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + red. intros. exfalso. + destruct (link_linkorder _ _ _ H) as [LO1 LO2]. apply link_prog_inv in H. - unfold match_prog in *. - unfold main_is_internal in *. simplify. repeat (unfold_match H4). - repeat (unfold_match H3). simplify. - subst. rewrite H0 in *. specialize (H (AST.prog_main p2)). + unfold match_prog, main_is_internal in *. + + simplify. + repeat (unfold_match H0). + repeat (unfold_match H1). + simplify. + + subst. + rewrite H5 in *. + specialize (H (AST.prog_main p2)). + exploit H. - apply Genv.find_def_symbol. exists b. split. - assumption. apply Genv.find_funct_ptr_iff. eassumption. - apply Genv.find_def_symbol. exists b0. split. - assumption. apply Genv.find_funct_ptr_iff. eassumption. - intros. inv H3. inv H5. destruct H6. inv H5. + - apply Genv.find_def_symbol. exists b. split. + + assumption. + + apply Genv.find_funct_ptr_iff. eassumption. + - apply Genv.find_def_symbol. exists b0. split. + + assumption. + + apply Genv.find_funct_ptr_iff. eassumption. + - crush. Qed. Definition match_prog' (p: RTL.program) (tp: HTL.program) := - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. + Linking.match_program (fun cu f tf => transl_fundef p f = Errors.OK tf) eq p tp. Lemma match_prog_matches : forall p tp, match_prog p tp -> match_prog' p tp. @@ -174,6 +261,15 @@ Proof. assumption. Qed. +Lemma regs_lessdef_empty : forall f, match_assocmaps f (Registers.Regmap.init Values.Vundef) empty_assocmap. +Proof. + constructor. intros. + unfold Registers.Regmap.init, "_ !! _", "_ # _", empty_assocmap, AssocMapExt.get_default. + repeat rewrite PTree.gempty. + constructor. +Qed. +Hint Resolve regs_lessdef_empty : htlproof. + Lemma regs_lessdef_add_greater : forall f rs1 rs2 n v, Plt (RTL.max_reg_function f) n -> @@ -296,19 +392,24 @@ Proof. assumption. Qed. +Lemma option_inv : + forall A x y, + @Some A x = Some y -> x = y. +Proof. intros. inversion H. trivial. Qed. + Ltac inv_state := match goal with - MSTATE : match_states _ _ |- _ => + MSTATE : match_states _ _ _ |- _ => inversion MSTATE; match goal with - TF : tr_module _ _ |- _ => + TF : tr_module _ _ _ |- _ => inversion TF; match goal with TC : forall _ _, - Maps.PTree.get _ _ = Some _ -> tr_code _ _ _ _ _ _ _ _ _, + Maps.PTree.get _ _ = Some _ -> tr_code _ _ _ _ _ _ _ _ _ _ _, H : Maps.PTree.get _ _ = Some _ |- _ => apply TC in H; inversion H; - match goal with + try match goal with TI : context[tr_instr] |- _ => inversion TI end @@ -325,6 +426,19 @@ Ltac unfold_func H := | ?f _ _ _ _ = _ => unfold f in H; repeat (unfold_match H) end. +(* FIXME: Rename this to something more descriptive. It can also discriminate + control registers between each other. *) +Ltac not_control_reg := + solve [ + unfold Ple, Plt, externctrl_ordering in *; + try multimatch goal with + | [ H : forall r, (exists x, _ ! r = Some x) -> (r > _)%positive + |- context[?r'] + ] => pose proof (H r' ltac:(eauto)) + end; + lia + ]. + Lemma init_reg_assoc_empty : forall f l, match_assocmaps f (RTL.init_regs nil l) (HTL.init_regs nil l). @@ -350,29 +464,252 @@ Proof. Qed. #[local] Hint Resolve arr_lookup_some : htlproof. +Lemma mem_free_zero_load : forall mem mem' blk chunk sp ptr, + Mem.free mem blk 0 0 = Some mem' -> + Mem.load chunk mem sp ptr = Mem.load chunk mem' sp ptr. +Proof. + intros. + destruct (Mem.load chunk mem' sp ptr) eqn:E. + - eauto using Mem.load_free_2. + - erewrite <- Mem.load_free; try eassumption; crush. +Qed. + +Lemma mem_free_zero_loadv : forall mem mem' blk chunk ptr, + Mem.free mem blk 0 0 = Some mem' -> + Mem.loadv chunk mem ptr = Mem.loadv chunk mem' ptr. +Proof. + intros. + destruct ptr; crush. + eauto using mem_free_zero_load. +Qed. + +Lemma mem_free_zero_store : forall mem mem' blk chunk sp ofs v, + Mem.free mem blk 0 0 = Some mem' -> + Mem.store chunk mem sp ofs v = None -> + Mem.store chunk mem' sp ofs v = None. +Proof. + Transparent Mem.store. + intros. + unfold Mem.store in *. + destruct (Mem.valid_access_dec mem chunk sp ofs Writable), (Mem.valid_access_dec mem' chunk sp ofs Writable); crush. + exfalso. + srun eauto use: Mem.valid_access_free_inv_1. +Qed. + +Lemma mem_free_zero_storev : forall mem mem' blk chunk ptr v, + Mem.free mem blk 0 0 = Some mem' -> + Mem.storev chunk mem ptr v = None -> + Mem.storev chunk mem' ptr v = None. +Proof. destruct ptr; simpl in *; eauto using mem_free_zero_store. Qed. + +Lemma mem_alloc_zero_load : forall mem mem' blk chunk sp ptr, + Mem.alloc mem 0 0 = (mem', blk) -> + Mem.load chunk mem sp ptr = Mem.load chunk mem' sp ptr. +Proof. + Transparent Mem.load. + intros. + destruct (Mem.load chunk mem sp ptr) eqn:E. + - hauto lq: on use: Mem.load_alloc_other. + - unfold Mem.load in *. + destruct (Mem.valid_access_dec mem _ _ _ _), (Mem.valid_access_dec mem' _ _ _ _); crush. + eapply Mem.valid_access_alloc_inv in H; eauto. + destruct (Values.eq_block _ _), chunk; crush. +Qed. + +Lemma mem_alloc_zero_loadv : forall mem mem' blk chunk ptr, + Mem.alloc mem 0 0 = (mem', blk) -> + Mem.loadv chunk mem ptr = Mem.loadv chunk mem' ptr. +Proof. + intros. + unfold Mem.loadv. + destruct ptr; crush. + eauto using mem_alloc_zero_load. +Qed. + +Lemma mem_alloc_zero_store : forall mem mem' blk chunk sp ofs v, + Mem.alloc mem 0 0 = (mem', blk) -> + Mem.store chunk mem sp ofs v = None -> + Mem.store chunk mem' sp ofs v = None. +Proof. + Transparent Mem.store. + intros. + unfold Mem.store in *. + destruct (Mem.valid_access_dec mem _ _ _ _), (Mem.valid_access_dec mem' _ _ _ _); crush. + exfalso. + eapply Mem.valid_access_alloc_inv in H; eauto. + destruct (Values.eq_block _ _), chunk; crush. +Qed. + +Lemma mem_alloc_zero_storev : forall mem mem' blk chunk ptr v, + Mem.alloc mem 0 0 = (mem', blk) -> + Mem.storev chunk mem ptr v = None -> + Mem.storev chunk mem' ptr v = None. +Proof. destruct ptr; simpl in *; eauto using mem_alloc_zero_store. Qed. + Section CORRECTNESS. Variable prog : RTL.program. Variable tprog : HTL.program. + Let ge : RTL.genv := Globalenvs.Genv.globalenv prog. + Let tge : HTL.genv := Globalenvs.Genv.globalenv tprog. + Hypothesis TRANSL : match_prog prog tprog. - Lemma TRANSL' : - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog. - Proof. intros; apply match_prog_matches; assumption. Qed. + (** The following are assumed to be guaranteed by an inlining pass previous to + this translation. [ only_main_stores ] should be a direct result of that + inlining. - Let ge : RTL.genv := Globalenvs.Genv.globalenv prog. - Let tge : HTL.genv := Globalenvs.Genv.globalenv tprog. + [ no_stack_functions ] and [ no_stack_calls ] might be provable as + corollaries of [ only_main_stores ] + *) + Axiom only_main_stores : forall rtl_stk f sp pc pc' rs mem htl_stk mid m asr asa a b c d, + match_states ge (RTL.State rtl_stk f sp pc rs mem) (HTL.State htl_stk mid m pc asr asa) -> + (RTL.fn_code f) ! pc = Some (RTL.Istore a b c d pc') -> + (rtl_stk = nil /\ htl_stk = nil). + + Axiom no_stack_functions : forall f sp rs mem st rtl_stk S, + match_states ge (RTL.State rtl_stk f sp st rs mem) S -> + (RTL.fn_stacksize f) = 0 \/ rtl_stk = nil. + + Axiom no_stack_calls : forall f mem args rtl_stk S, + match_states ge (RTL.Callstate rtl_stk (AST.Internal f) args mem) S -> + (RTL.fn_stacksize f) = 0 \/ rtl_stk = nil. + + Lemma mem_free_zero_match_frames : forall rtl_stk htl_stk mem mem' blk id, + Mem.free mem blk 0 0 = Some mem' -> + match_frames ge id mem rtl_stk htl_stk -> + match_frames ge id mem' rtl_stk htl_stk. + Proof. + Lemma mem_free_match_arrs : forall m f sp blk mem mem' asa, + Mem.free mem blk 0 0 = Some mem' -> + sp_valid sp -> + match_arrs m f sp mem asa -> + match_arrs m f sp mem' asa. + Proof. + intros * Hfree [blk SP] Hmatch. + inv Hmatch. + apply match_arr with (stack:=stack); crush. + intros. + erewrite <- (mem_free_zero_load mem mem'); eauto. + Qed. + Hint Resolve mem_free_match_arrs : htlproof. + + Lemma mem_free_stack_based_pointers : forall mem mem' blk blk' sp sz, + Mem.free mem blk 0 0 = Some mem' -> + arr_stack_based_pointers blk' mem sz sp -> + arr_stack_based_pointers blk' mem' sz sp. + Proof. + intros * Hfree SP Hstk. + unfold arr_stack_based_pointers in *. + intros. + erewrite <- (mem_free_zero_loadv mem mem'); eauto. + Qed. + Hint Resolve mem_free_stack_based_pointers : htlproof. + + Lemma mem_free_stack_bounds : forall mem mem' blk ptr sz, + Mem.free mem blk 0 0 = Some mem' -> + stack_bounds ptr sz mem -> + stack_bounds ptr sz mem'. + Proof. + unfold stack_bounds. + intros * Hfree Hbounds **. + exploit Hbounds; eauto. + intros [Hload Hstore]. + split. + - erewrite <- (mem_free_zero_loadv mem mem'); eauto. + - eauto using mem_free_zero_storev. + Qed. + Hint Resolve mem_free_stack_bounds : htlproof. + + induction rtl_stk; intros * Hmem Hstk; inv Hstk; eauto 6 with htlproof. + Qed. + + Lemma mem_alloc_zero_match_frames : forall rtl_stk htl_stk mem mem' blk ge id, + Mem.alloc mem 0 0 = (mem', blk) -> + match_frames ge id mem rtl_stk htl_stk -> + match_frames ge id mem' rtl_stk htl_stk. + Proof. + Lemma mem_alloc_zero_match_arrs : forall m f sp blk mem mem' asa, + Mem.alloc mem 0 0 = (mem', blk) -> + sp_valid sp -> + match_arrs m f sp mem asa -> + match_arrs m f sp mem' asa. + Proof. + intros * Halloc [blk SP] Hmatch. + inv Hmatch. + apply match_arr with (stack:=stack); crush. + intros. + erewrite <- (mem_alloc_zero_load mem mem'); eauto. + Qed. + Hint Resolve mem_alloc_zero_match_arrs : htlproof. + + Lemma mem_alloc_zero_stack_based_pointers : forall mem mem' blk blk' sp sz, + Mem.alloc mem 0 0 = (mem', blk) -> + arr_stack_based_pointers blk' mem sz sp -> + arr_stack_based_pointers blk' mem' sz sp. + Proof. + intros * Hfree Hstk. + unfold arr_stack_based_pointers in *. + intros. + erewrite <- (mem_alloc_zero_loadv mem mem'); eauto. + Qed. + Hint Resolve mem_alloc_zero_stack_based_pointers : htlproof. + + Lemma mem_alloc_zero_stack_bounds : forall mem mem' blk ptr sz, + Mem.alloc mem 0 0 = (mem', blk) -> + stack_bounds ptr sz mem -> + stack_bounds ptr sz mem'. + Proof. + unfold stack_bounds. + intros * Hfree Hbounds **. + exploit Hbounds; eauto. + intros [Hload Hstore]. + split. + - erewrite <- (mem_alloc_zero_loadv mem mem'); eauto. + - eauto using mem_alloc_zero_storev. + Qed. + Hint Resolve mem_alloc_zero_stack_bounds : htlproof. + + induction rtl_stk; intros * Halloc Hmatch; inv Hmatch; eauto 6 with htlproof. + Qed. + + Lemma match_arrs_empty : forall m f sp mem asa, + HTL.mod_stk_len m = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> + match_arrs m f sp mem asa -> + match_arrs m f sp mem (Verilog.merge_arrs (HTL.empty_stack m) asa). + Proof. + intros * Hstklen [? ? [Hstk [Hstklen' Hstkval]]]. + econstructor; repeat split. + - unfold Verilog.merge_arrs, HTL.empty_stack. + rewrite AssocMap.gcombine by trivial. + rewrite AssocMap.gss. + replace (_ ! _) with (Some stack). + crush. + - unfold combine, make_array. simpl. + rewrite list_combine_length, list_repeat_len, arr_wf, Hstklen, Hstklen'. + lia. + - simplify. + rewrite combine_lookup_first; eauto. + + rewrite arr_repeat_length. congruence. + + unfold arr_repeat, make_array, array_get_error. simpl. + apply list_repeat_lookup. + lia. + Qed. + + Lemma TRANSL' : + Linking.match_program (fun cu f tf => transl_fundef prog f = Errors.OK tf) eq prog tprog. + Proof. pose proof match_prog_matches as H. unfold match_prog' in H. auto. Qed. Lemma symbols_preserved: forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. intros. eapply (Genv.find_symbol_match TRANSL'). Qed. - Lemma function_ptr_translated: - forall (b: Values.block) (f: RTL.fundef), + Lemma function_ptr_translated : + forall (b : Values.block) (f: RTL.fundef), Genv.find_funct_ptr ge b = Some f -> exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Errors.OK tf. + Genv.find_funct_ptr tge b = Some tf /\ transl_fundef prog f = Errors.OK tf. Proof. intros. exploit (Genv.find_funct_ptr_match TRANSL'); eauto. intros (cu & tf & P & Q & R); exists tf; auto. @@ -382,7 +719,7 @@ Section CORRECTNESS. forall (v: Values.val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transl_fundef f = Errors.OK tf. + Genv.find_funct tge v = Some tf /\ transl_fundef prog f = Errors.OK tf. Proof. intros. exploit (Genv.find_funct_match TRANSL'); eauto. intros (cu & tf & P & Q & R); exists tf; auto. @@ -402,16 +739,40 @@ Section CORRECTNESS. rewrite H. auto. Qed. + Lemma match_find_function : forall fn rs f m, + RTL.find_function ge (inr fn) rs = Some (AST.Internal f) -> + HTL.find_func tge fn = Some (AST.Internal m) -> + tr_module ge f m. + Proof. + intros * Hrtl Hhtl. + destruct TRANSL as [MATCH _]. + + unfold RTL.find_function in *. unfold_match Hrtl. + unfold HTL.find_func in *. unfold_match Hhtl. + replace b0 with b in *. clear b0. + + destruct (function_ptr_translated _ _ Hrtl) as [tf [? ?]]. + replace tf with (AST.Internal m) in *. clear tf. + + - apply transl_module_correct. + simpl in *. + destruct (transl_module prog f) eqn:E; crush. + - assert (Some (AST.Internal m) = Some tf) by + hauto lq: on unfold: HTL.program, Genv.find_funct_ptr. + sauto. + - scongruence use: symbols_preserved. + Qed. + Lemma op_stack_based : - forall F V sp v m args rs op ge pc' res0 pc f e fin rtrn st stk, + forall F V sp blk v m args rs op ge pc' res0 pc f e fin rtrn st stk, tr_instr fin rtrn st stk (RTL.Iop op args res0 pc') (Verilog.Vnonblock (Verilog.Vvar res0) e) (state_goto st pc') -> - reg_stack_based_pointers sp rs -> + reg_stack_based_pointers blk rs -> (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> - @Op.eval_operation F V ge (Values.Vptr sp Ptrofs.zero) op + @Op.eval_operation F V ge sp op (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> - stack_based v sp. + stack_based v blk. Proof. Ltac solve_no_ptr := match goal with @@ -439,10 +800,14 @@ Section CORRECTNESS. | |- context[match ?g with _ => _ end] => destruct g; try discriminate | |- _ => simplify; solve [auto] end. - intros F V sp v m args rs op g pc' res0 pc f e fin rtrn st stk INSTR RSBP SEL EVAL. - inv INSTR. unfold translate_instr in H5. + intros * INSTR RSBP SEL EVAL. + inversion INSTR. subst. unfold translate_instr in H5. unfold_match H5; repeat (unfold_match H5); repeat (simplify; solve_no_ptr). - Qed. + (** Ainstack *) { + (** rtl_stk = stk_hd::stk_tl, should be impossible *) + admit. + } + Admitted. Lemma int_inj : forall x y, @@ -592,14 +957,14 @@ Section CORRECTNESS. end. Lemma eval_cond_correct : - forall stk f sp pc rs m res ml st asr asa e b f' s s' args i cond, - match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> + forall stk f sp pc rs mid m res ml st asr asa e b f' s s' args i cond, + match_states ge (RTL.State stk f sp pc rs m) (HTL.State res mid ml st asr asa) -> (forall v, In v args -> Ple v (RTL.max_reg_function f)) -> Op.eval_condition cond (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some b -> translate_condition cond args s = OK e s' i -> Verilog.expr_runp f' asr asa e (boolToValue b). Proof. - intros stk f sp pc rs m res ml st asr asa e b f' s s' args i cond MSTATE MAX_FUN EVAL TR_INSTR. + intros * MSTATE MAX_FUN EVAL TR_INSTR. pose proof MSTATE as MSTATE_2. inv MSTATE. inv MASSOC. unfold translate_condition, translate_comparison, translate_comparisonu, translate_comparison_imm, @@ -723,21 +1088,21 @@ Section CORRECTNESS. Qed. Lemma eval_cond_correct' : - forall e stk f sp pc rs m res ml st asr asa v f' s s' args i cond, - match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> + forall e stk f sp pc rs m res mid ml st asr asa v f' s s' args i cond, + match_states ge (RTL.State stk f sp pc rs m) (HTL.State res mid ml st asr asa) -> (forall v, In v args -> Ple v (RTL.max_reg_function f)) -> Values.Val.of_optbool None = v -> translate_condition cond args s = OK e s' i -> exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. - intros e stk f sp pc rs m res ml st asr asa v f' s s' args i cond MSTATE MAX_FUN EVAL TR_INSTR. + intros * MSTATE MAX_FUN EVAL TR_INSTR. unfold translate_condition, translate_comparison, translate_comparisonu, translate_comparison_imm, translate_comparison_immu, bop, boplit in *. repeat unfold_match TR_INSTR; inv TR_INSTR; repeat econstructor. Qed. Lemma eval_correct_Oshrximm : - forall s sp rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st n, - match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> + forall s sp rs m v e asr asa f f' stk s' i pc res0 pc' args res mid ml st n, + match_states ge (RTL.State stk f sp pc rs m) (HTL.State res mid ml st asr asa) -> (RTL.fn_code f) ! pc = Some (RTL.Iop (Op.Oshrximm n) args res0 pc') -> Op.eval_operation ge sp (Op.Oshrximm n) (List.map (fun r : BinNums.positive => @@ -745,13 +1110,10 @@ Section CORRECTNESS. translate_instr (Op.Oshrximm n) args s = OK e s' i -> exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. Proof. - intros s sp rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st n MSTATE INSTR EVAL TR_INSTR. + intros * MSTATE INSTR EVAL TR_INSTR. pose proof MSTATE as MSTATE_2. inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL. - (*repeat (simplify; eval_correct_tac; unfold valueToInt in * ). - destruct (Z_lt_ge_dec (Int.signed i0) 0). - econstructor.*) unfold Values.Val.shrx in *. destruct v0; try discriminate. destruct (Int.ltu n (Int.repr 31)) eqn:?; try discriminate. @@ -800,16 +1162,21 @@ Section CORRECTNESS. rewrite H3 in H2. discriminate. Qed. + (* Lemma match_sp_zero_ofs : forall ofs stk b1 b2, *) + (* match_sp stk (Values.Vptr b1 ofs) b2 -> *) + (* ofs = (Ptrofs.repr 0). *) + (* Proof. induction stk; simplify; inv H; crush. Qed. *) + Lemma eval_correct : - forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, - match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> + forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res mid ml st , + match_states ge (RTL.State stk f sp pc rs m) (HTL.State res mid ml st asr asa) -> (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> Op.eval_operation ge sp op (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> translate_instr op args s = OK e s' i -> exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. Proof. - intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. + intros * MSTATE INSTR EVAL TR_INSTR. pose proof MSTATE as MSTATE_2. inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL; @@ -836,8 +1203,6 @@ Section CORRECTNESS. - rewrite Heqb in Heqb0. discriminate. - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. - rewrite Heqb in Heqb0. discriminate. - (*- unfold Int.ror. unfold Int.or. unfold Int.shru, Int.shl, Int.sub. unfold intToValue. unfold Int.modu, - repeat (rewrite Int.unsigned_repr). auto.*) - assert (Int.unsigned n <= 30). { unfold Int.ltu in *. destruct (zlt (Int.unsigned n) (Int.unsigned (Int.repr 31))); try discriminate. rewrite Int.unsigned_repr in l by (simplify; lia). @@ -955,9 +1320,9 @@ Section CORRECTNESS. rewrite Heqv2 in H4. inv H4. + unfold translate_eff_addressing in *. repeat (unfold_match H1). inv H1. - inv Heql. unfold boplitz. repeat (simplify; eval_correct_tac). - all: repeat (unfold_match Heqv). - eexists. split. constructor. + eexists. repeat (simplify; eval_correct_tac). + replace i1 with (Ptrofs.repr 0) by (inversion SP_VALID as [? SP_VALID']; inv SP_VALID'; trivial). + constructor. unfold valueToPtr, ZToValue. rewrite Ptrofs.add_zero_l. unfold Ptrofs.of_int. rewrite Int.unsigned_repr. symmetry. apply Ptrofs.repr_unsigned. unfold check_address_parameter_unsigned in *. apply Ptrofs.unsigned_range_2. @@ -1021,10 +1386,10 @@ Section CORRECTNESS. *) Definition transl_instr_prop (instr : RTL.instruction) : Prop := - forall m asr asa fin rtrn st stmt trans res, + forall mid m asr asa fin rtrn st stmt trans res, tr_instr fin rtrn st (m.(HTL.mod_stk)) instr stmt trans -> exists asr' asa', - HTL.step tge (HTL.State res m st asr asa) Events.E0 (HTL.State res m st asr' asa'). + HTL.step tge (HTL.State res mid m st asr asa) Events.E0 (HTL.State res mid m st asr' asa'). Opaque combine. @@ -1072,40 +1437,72 @@ Section CORRECTNESS. Ltac small_tac := repeat (crush_val; try array; try ptrofs); crush_val; auto. Ltac big_tac := repeat (crush_val; try array; try ptrofs; try tac0); crush_val; auto. + Lemma match_externctrl_out : forall m r v asr, + (HTL.mod_externctrl m) ! r = None -> + match_externctrl m asr -> + match_externctrl m (asr # r <- v). + Proof. + unfold match_externctrl. + intros * Hunmapped Hprev * Hmapped. + rewrite AssocMap.fso by crush. + eauto. + Qed. + + Lemma externctrl_low : forall clk r externctrl, + externctrl_ordering externctrl clk -> + (r < clk)%positive -> + externctrl ! r = None. + Proof. + intros * Horder Hclk. + destruct (externctrl ! r) eqn:E; trivial. + + unfold externctrl_ordering in Horder. + specialize (Horder r ltac:(eauto)). + lia. + Qed. + + Ltac trans_externctrl := + apply match_externctrl_out; crush; + eapply externctrl_low; eauto; crush. + Lemma transl_inop_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) (rs : RTL.regset) (m : mem) (pc' : RTL.node), (RTL.fn_code f) ! pc = Some (RTL.Inop pc') -> forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> + match_states ge (RTL.State s f sp pc rs m) R1 -> exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states ge (RTL.State s f sp pc' rs m) R2. Proof. - intros s f sp pc rs m pc' H R1 MSTATE. + intros * H R1 MSTATE. inv_state. unfold match_prog in TRANSL. - econstructor. + eexists. split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. - (* processing of state *) - econstructor. - crush. - econstructor. - econstructor. - econstructor. - - all: invert MARR; big_tac. - - inv CONST; constructor; simplify; rewrite AssocMap.gso; auto; lia. - + - apply Smallstep.plus_one. + eapply HTL.step_module; eauto. + + inv CONST; assumption. + + inv CONST; assumption. + + repeat constructor. + + repeat constructor. + + constructor. + + big_tac. + - inv CONST. inv MARR. simplify. big_tac; auto. + + constructor; rewrite AssocMap.gso; crush. + + trans_externctrl. Unshelve. exact tt. Qed. #[local] Hint Resolve transl_inop_correct : htlproof. + Ltac trans_match_externctrl := + unshelve ( + try eassumption; + apply match_externctrl_out; + simpl; + [eauto; crush; shelve | eauto; crush; try trans_match_externctrl] + ). + Lemma transl_iop_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) (rs : Registers.Regmap.t Values.val) (m : mem) (op : Op.operation) (args : list Registers.reg) @@ -1113,50 +1510,932 @@ Section CORRECTNESS. (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> Op.eval_operation ge sp op (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> + match_states ge (RTL.State s f sp pc rs m) R1 -> exists R2 : HTL.state, Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. + match_states ge (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. Proof. - intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. + intros * H H0 R1 MSTATE. inv_state. inv MARR. exploit eval_correct; eauto. intros. inversion H1. inversion H2. - econstructor. split. + eexists. split. apply Smallstep.plus_one. eapply HTL.step_module; eauto. - inv CONST. assumption. - inv CONST. assumption. - econstructor; simpl; trivial. - constructor; trivial. - econstructor; simpl; eauto. - simpl. econstructor. econstructor. - apply H5. simplify. + - inv CONST. assumption. + - inv CONST. assumption. + - repeat econstructor. + - repeat econstructor. intuition eauto. + - constructor. + - big_tac. + assert (Ple res0 (RTL.max_reg_function f)) + by eauto using RTL.max_reg_function_def. + xomega. + - big_tac. + + apply regs_lessdef_add_match. assumption. + apply regs_lessdef_add_greater. unfold Plt; lia. assumption. + + assert (HPle: Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + unfold Ple in HPle; lia. + + eauto using op_stack_based. + + inv CONST. constructor; simplify. + * rewrite AssocMap.gso. rewrite AssocMap.gso. + assumption. lia. + assert (HPle: Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + unfold Ple in HPle. lia. + * rewrite AssocMap.gso. rewrite AssocMap.gso. + assumption. lia. + assert (HPle: Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + unfold Ple in HPle. lia. + + trans_match_externctrl. + * epose proof (RTL.max_reg_function_def f _ _ res0 ltac:(eauto) ltac:(eauto)). + unfold Ple in *. + apply (externctrl_low clk); eauto; crush. + * apply (externctrl_low clk); eauto; crush. + Unshelve. exact tt. + Qed. + Hint Resolve transl_iop_correct : htlproof. - all: big_tac. + Lemma match_args : forall rtl_args htl_args params f, + list_forall2 val_value_lessdef rtl_args htl_args -> + match_assocmaps f (RTL.init_regs rtl_args params) (HTL.init_regs htl_args params). + Proof. + induction rtl_args; intros * H; inv H. + - destruct params; eauto with htlproof. + - destruct params; eauto using regs_lessdef_add_match with htlproof. + Qed. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + Lemma stack_based_set : forall sp r v rs, + stack_based v sp -> + reg_stack_based_pointers sp rs -> + reg_stack_based_pointers sp (Registers.Regmap.set r v rs). + Proof. + unfold reg_stack_based_pointers, Registers.Regmap.set, "_ !! _". + intros * ? ? r0. + simpl. + destruct (peq r r0); subst. + - rewrite AssocMap.gss; auto. + - rewrite AssocMap.gso; auto. + Qed. + Hint Resolve stack_based_set : htlproof. - unfold Ple in HPle. lia. - apply regs_lessdef_add_match. assumption. - apply regs_lessdef_add_greater. unfold Plt; lia. assumption. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle; lia. - eapply op_stack_based; eauto. - inv CONST. constructor; simplify. rewrite AssocMap.gso. rewrite AssocMap.gso. - assumption. lia. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle. lia. - rewrite AssocMap.gso. rewrite AssocMap.gso. - assumption. lia. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle. lia. - Unshelve. exact tt. + Lemma stack_based_forall : forall vals regs blk, + Forall (fun a => stack_based a blk) vals -> + reg_stack_based_pointers blk (RTL.init_regs vals regs). + Proof. + unfold reg_stack_based_pointers. + induction vals; intros * VALS_BASED *. + + destruct regs; + simpl; + unfold "_ !! _"; + rewrite PTree.gempty; + crush. + + destruct regs; simpl. + * unfold "_ !! _". rewrite PTree.gempty. crush. + * inv VALS_BASED. + apply stack_based_set. + -- crush. + -- unfold reg_stack_based_pointers. auto. + Qed. + + Lemma mem_alloc_stack_bounds : forall mem mem' sz stk, + Mem.alloc mem 0 sz = (mem', stk) -> + stack_bounds (Values.Vptr stk Ptrofs.zero) sz mem'. + Proof. + Transparent Mem.load. + Transparent Mem.store. + unfold stack_bounds. + intros * Halloc * Hbounds Halign. + + assert (~ Mem.valid_access mem' AST.Mint32 stk (Ptrofs.unsigned (Ptrofs.repr ptr)) Readable). { + intro contra. + + eapply Mem.valid_access_alloc_inv in contra; eauto. + rewrite peq_true in contra. + big_tac. + rewrite Ptrofs.unsigned_repr_eq in *. + rewrite (Z.mod_small ptr Ptrofs.modulus) in *; crush. + } + + assert (~ Mem.valid_access mem' AST.Mint32 stk (Ptrofs.unsigned (Ptrofs.repr ptr)) Writable). { + intro contra. + + eapply Mem.valid_access_alloc_inv in contra; eauto. + rewrite peq_true in contra. + big_tac. + rewrite Ptrofs.unsigned_repr_eq in *. + rewrite (Z.mod_small ptr Ptrofs.modulus) in *; crush. + } + + big_tac. + - unfold Mem.load. + destruct_match; crush. + - unfold Mem.store. + destruct_match; crush. + Qed. + + Lemma find_init_regs_out : forall ps vs r, + ~ In r ps -> + (HTL.init_regs vs ps) ! r = None. + Proof. + induction ps; simplify. + - apply AssocMap.gempty. + - destruct vs. + + apply AssocMap.gempty. + + rewrite AssocMap.gso by crush. + apply IHps. + crush. + Qed. + + Lemma find_default : forall m r, + m ! r = None -> + m # r = ZToValue 0. + Proof. + unfold "_ # _". + hauto unfold: reg, AssocMapExt.get_default. + Qed. + + Lemma stack_base_sp_fequal : forall stk blk blk', + stack_base_sp stk blk -> + stack_base_sp stk blk'-> + blk = blk'. + Proof. + Ltac inv_stack_base := + repeat match goal with + | [ H : stack_base_sp _ _ |- _ ] => learn H; inversion H; subst; crush + end. + induction stk; intros * H H'. + - inv_stack_base. + - inversion H; inversion H'; subst; inv_stack_base. + Qed. + Hint Resolve stack_base_sp_fequal : htlproof. + + Lemma stack_based_undef : forall sp, reg_stack_based_pointers sp (Registers.Regmap.init Values.Vundef). + Proof. + unfold reg_stack_based_pointers. + intros. + rewrite Registers.Regmap.gi. + crush. + Qed. + + Lemma init_regs_nil : forall rs, RTL.init_regs nil rs = Registers.Regmap.init Values.Vundef. + Proof. destruct rs; trivial. Qed. + + Lemma transl_callstate_correct: + forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) + (m : mem) (m' : Mem.mem') (stk : Values.block), + Mem.alloc m 0 (RTL.fn_stacksize f) = (m', stk) -> + forall R1 : HTL.state, + match_states ge (RTL.Callstate s (AST.Internal f) args m) R1 -> + exists R2 : HTL.state, + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ + match_states ge + (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) (RTL.fn_entrypoint f) + (RTL.init_regs args (RTL.fn_params f)) m') R2. + Proof. + intros * ? * MSTATE. + inversion MSTATE. + inversion TF. + simplify. + (* Lemma match_frames_match_sp : forall rtl_stk htl_stk mid m stk, *) + (* match_frames ge mid m rtl_stk htl_stk -> *) + (* exists blk, match_sp rtl_stk (Values.Vptr stk Ptrofs.zero) blk. *) + (* Proof. *) + (* destruct rtl_stk; simplify. *) + (* - repeat econstructor. *) + (* - destruct s. *) + (* inv H. *) + (* eauto with htlproof. *) + (* Qed. *) + (* edestruct (match_frames_match_sp) as [blk ?]; eauto. *) + + Hint Unfold sp_valid : htlproof. + + eexists. split. + apply Smallstep.plus_one. + solve [constructor]. + + simplify. + econstructor; try solve [big_tac]. + - repeat apply regs_lessdef_add_greater; try not_control_reg. + eauto using match_args. + - edestruct no_stack_calls; eauto. + + replace (RTL.fn_stacksize f) in *. + eauto using mem_alloc_zero_match_frames. + + subst. inv MF. constructor. + - big_tac. + destruct (Mem.load _ _ _ _) eqn:eq_load; repeat constructor. + erewrite (Mem.load_alloc_same m 0 (RTL.fn_stacksize f) m' _ _ _ _ v); eauto; repeat econstructor. + - eauto with htlproof. + - move SP_BASE at bottom. + Lemma stack_base_trans : forall s sp blk stk, nil_stack_base_sp s sp blk \/ stack_base_sp s blk -> + let blk' := match s with + | nil => stk + | (_::_) => blk + end in + nil_stack_base_sp s (Values.Vptr stk Ptrofs.zero) blk' \/ stack_base_sp s blk'. + Proof. + unfold nil_stack_base_sp. + intros. + destruct s; inv H; crush. + Qed. + + eauto using stack_base_trans. + + - destruct s eqn:E; eauto using stack_based_forall. + rewrite INIT_CALL_NO_ARGS by trivial. + rewrite init_regs_nil. + eapply stack_based_undef. + - unfold arr_stack_based_pointers; intros. + destruct (Mem.loadv _ _ _) eqn:eq_load. + + simpl. + unfold Mem.loadv in *; simplify. + erewrite (Mem.load_alloc_same m 0 (RTL.fn_stacksize f) m' _ _ _ _ v); eauto; repeat econstructor. + + crush. + - eauto using mem_alloc_stack_bounds. + - constructor; simplify. + + rewrite AssocMap.gss; crush. + + rewrite AssocMap.gso by not_control_reg. + rewrite AssocMap.gss. crush. + - unfold match_externctrl. + simplify. + repeat rewrite AssocMap.fso. + + apply find_default. + apply find_init_regs_out. + intro contra. + apply RTL.max_reg_function_params in contra. unfold Ple in contra. + unfold externctrl_ordering in *. + specialize (H17 r ltac:(eauto)). + lia. + + not_control_reg. + + not_control_reg. + + not_control_reg. + Unshelve. + all: eauto. + Qed. + Hint Resolve transl_callstate_correct : htlproof. + + Lemma only_internal_calls : forall fd fn rs, + RTL.find_function ge (inr fn) rs = Some fd -> + (exists f : RTL.function, HTL.find_func ge fn = Some (AST.Internal f)) -> + (exists f, fd = AST.Internal f). + Proof. + intros * ? [? ?]. + unfold HTL.find_func in *. + unfold RTL.find_function in *. + destruct (Genv.find_symbol ge fn); try discriminate. + exists x. crush. + Qed. + + Fixpoint assign_all acc (rs : list reg) (vals : list value) := + match rs, vals with + | r::rs', val::vals' => assign_all (acc # r <- val) rs' vals' + | _, _ => acc + end. + + Notation "a ## b '<-' c" := (assign_all a b c) (at level 1, b at next level) : assocmap. + + Lemma assign_all_nil : forall a rs, a ## rs <- nil = a. + Proof. destruct rs; crush. Qed. + + Lemma assign_all_out : forall rs vs a r, (forall v, ~ In (r, v) (List.combine rs vs)) -> (a ## rs <- vs) ! r = a ! r. + Proof. + induction rs; intros * H. + - trivial. + - destruct vs. + + rewrite assign_all_nil. + trivial. + + simpl. + rewrite IHrs. + rewrite AssocMap.gso. + crush. + * simpl (List.combine _ _) in *. + specialize (H v). + rewrite not_in_cons in H. + inv H. + crush. + * intros v0. + specialize (H v0). + simpl (List.combine _ _) in *. + rewrite not_in_cons in H. + crush. + Qed. + + Lemma get_all_assign_out : forall rs a r v, + (~ In r rs) -> + (a # r <- v) ## rs = a ## rs. + Proof. + induction rs; crush. + f_equal. + - rewrite fso; crush. + - apply IHrs; crush. + Qed. + + Lemma nonblock_all_exec : forall from_regs to_regs f basr nasr basa nasa, + Verilog.stmnt_runp + f + {| Verilog.assoc_blocking := basr; Verilog.assoc_nonblocking := nasr |} + {| Verilog.assoc_blocking := basa; Verilog.assoc_nonblocking := nasa |} + (nonblock_all (List.combine to_regs from_regs)) + {| Verilog.assoc_blocking := basr; Verilog.assoc_nonblocking := nasr ## to_regs <- (basr##from_regs) |} + {| Verilog.assoc_blocking := basa; Verilog.assoc_nonblocking := nasa |}. + Proof. + induction from_regs; intros. + - rewrite combine_nil, assign_all_nil. + constructor. + - destruct to_regs; try solve [ constructor ]. + simpl. + econstructor. + + repeat econstructor. + + eapply IHfrom_regs. + Qed. + + Lemma fork_exec : forall f basr nasr basa nasa rst to_regs from_regs, + Verilog.stmnt_runp + f + {| Verilog.assoc_blocking := basr; Verilog.assoc_nonblocking := nasr |} + {| Verilog.assoc_blocking := basa; Verilog.assoc_nonblocking := nasa |} + (fork rst (List.combine to_regs from_regs)) + {| Verilog.assoc_blocking := basr; Verilog.assoc_nonblocking := (nasr # rst <- (ZToValue 1)) ## to_regs <- (basr##from_regs) |} + {| Verilog.assoc_blocking := basa; Verilog.assoc_nonblocking := nasa |}. + Proof. + intros. + unfold fork. + econstructor. + - repeat econstructor. + - unfold Verilog.nonblock_reg; simpl. + eapply nonblock_all_exec. + Qed. + + Lemma transl_find : forall fn f, + HTL.find_func ge fn = Some (AST.Internal f) -> + match_prog prog tprog -> + (exists f', HTL.find_func tge fn = Some (AST.Internal f')). + Proof. + intros. + unfold HTL.find_func in *. + rewrite symbols_preserved. + destruct (Genv.find_symbol ge fn); try discriminate. + destruct (function_ptr_translated _ _ H) as [? [? ?]]. + replace (Genv.find_funct_ptr tge b). + inversion H2. + destruct (transl_module prog f); try discriminate. + inversion H4. + exists m. crush. + Qed. + + Lemma param_mapping_correct : + forall fn args fn_params externctrl, + externctrl_params_mapped args fn_params externctrl fn -> + (forall n param, nth_error fn_params n = Some param -> + externctrl!param = Some (fn, HTL.ctrl_param n)). + Proof. + intros * [Hlen [Hnodup Hmapped]] * Hfn_params. + + assert (H : exists arg, nth_error args n = Some arg). { + apply length_nth_error. + apply nth_error_length in Hfn_params. + lia. + } + destruct H as [ arg H ]. + edestruct (Hmapped _ _ H) as [? [? ?]]. + + enough (Some x = Some param) by crush. + congruence. + Qed. + + Lemma find_merge_right : forall m1 m2 r, + m1 ! r = None -> + (AssocMapExt.merge value m1 m2) # r = m2 # r. + Proof. + unfold "_ # _", AssocMapExt.get_default. + intros. + destruct (m2 ! r) eqn:?. + - erewrite AssocMapExt.merge_correct_2; auto. + - erewrite AssocMapExt.merge_correct_3; auto. + Qed. + + Lemma nth_error_same_length : + forall {A} (l1 l2 : list A) n x1, + length l1 = length l2 -> + nth_error l1 n = Some x1 -> + exists x2, nth_error l2 n = Some x2. + Proof. + intros * Hlength Hnth. + apply length_nth_error. + apply nth_error_length in Hnth. + lia. + Qed. + + Lemma not_in_params : forall r params args externctrl clk argvals fn, + externctrl_ordering externctrl clk -> + externctrl_params_mapped args params externctrl fn -> + (r < clk)%positive -> + forall v : value, ~ In (r, v) (List.combine params argvals). + Proof. + unfold "~". + intros * Hordering [Hlen [Hnodup Hmapped]] Hclk * contra. + apply in_combine_l in contra. + apply In_nth_error in contra. + destruct contra as [? ?]. + edestruct (nth_error_same_length params args); eauto. + unfold externctrl_ordering in *. + exploit (Hordering r). + exploit (Hmapped x x0). + all: qauto; lia. + Qed. + + Lemma match_arg_vals : forall args f rs asr, + Forall (fun r => Ple r (RTL.max_reg_function f)) args -> + match_assocmaps f rs asr -> + list_forall2 val_value_lessdef (map (fun r : positive => rs !! r) args) asr ## args. + Proof. + induction args; intros * Harg Hmatch; constructor. + - inv Harg. inv Hmatch. eauto. + - inv Harg. unfold map in IHargs. eauto. + Qed. + + Lemma call_args_maxreg : forall args f pc pc' sig fn dst, + (RTL.fn_code f) ! pc = Some (RTL.Icall sig fn args dst pc') -> + Forall (fun r : positive => Ple r (RTL.max_reg_function f)) args. + Proof. + intros. + apply Forall_forall. + intros r Hin. + eapply RTL.max_reg_function_use with (r:=r); eauto. + destruct fn; crush. + Qed. + + Lemma merge_correct_all_1 : forall ks vs m1 m2, + length ks = length vs -> + NoDup ks -> + (AssocMapExt.merge value (m1 ## ks <- vs) m2) ## ks = vs. + Proof. + induction ks; destruct vs; intros * Hlen Hnodup; crush. + f_equal. + - unfold "_ # _", AssocMapExt.get_default. + erewrite AssocMapExt.merge_correct_1; trivial. + rewrite assign_all_out by sauto inv: NoDup use: in_combine_l. + big_tac. + - sauto. Qed. - #[local] Hint Resolve transl_iop_correct : htlproof. + + Lemma get_all_length : forall ks m, length (m ## ks) = length ks. + Proof. induction ks; crush. Qed. + + Lemma separate_params_reset : forall r args params externctrl fn, + externctrl_params_mapped args params externctrl fn -> + externctrl ! r = Some (fn, HTL.ctrl_reset) -> + (~ In r params). + Proof. + intros * Hmapped Hrst contra. + inv Hmapped. + edestruct (In_nth_error _ _ contra) as [n ?]. + edestruct (nth_error_same_length params args); eauto. + edestruct H0 as [? [? [? ?]]]; eauto. + replace x0 with r in *; crush. + apply option_inv. + transitivity (nth_error params n); crush. + Qed. + + Lemma param_reg_lower : forall params r clk args externctrl fn, + externctrl_params_mapped args params externctrl fn -> + externctrl_ordering externctrl clk -> + (r < clk)%positive -> + ~ In r params. + Proof. + unfold externctrl_ordering. + intros * [Hlen [Hnodup Hmapped]] Hordering Hlt contra. + destruct (In_nth_error _ _ contra) as [n Hparam]. + destruct (nth_error_same_length params args _ _ ltac:(crush) Hparam). + destruct (Hmapped n _ ltac:(eassumption)) as [r' [? ?]]. + replace r' with r in *. + - specialize (Hordering r ltac:(eauto)). + lia. + - enough (Some r = Some r') by crush. + transitivity (nth_error params n); crush. + Qed. + + Lemma not_in_combine_l : forall A B (x : A) (y : B) l1 l2, + ~ In x l1 -> + ~ In (x, y) (List.combine l1 l2). + Proof. eauto using in_combine_l. Qed. + + Lemma match_externctrl_merge : forall m asr1 asr2, + match_externctrl m asr1 -> + match_externctrl m asr2 -> + match_externctrl m (AssocMapExt.merge value asr1 asr2). + Proof. + unfold match_externctrl. + intros * H1 H2 * Hexternctrl. + specialize (H1 r mid Hexternctrl). + specialize (H2 r mid Hexternctrl). + unfold "_ # _" in *. + unfold AssocMapExt.get_default in *. + destruct (asr1 ! r) eqn:E1, (asr2 ! r) eqn:E2; subst. + - erewrite AssocMapExt.merge_correct_1; eauto. + - erewrite AssocMapExt.merge_correct_1; eauto. + - erewrite AssocMapExt.merge_correct_2; eauto. + - erewrite AssocMapExt.merge_correct_3; eauto. + Qed. + + Lemma fempty : forall r, empty_assocmap # r = ZToValue 0. + Proof. + unfold "_ # _", AssocMapExt.get_default. + intros. + rewrite AssocMap.gempty. + trivial. + Qed. + + Lemma in_params_exists : forall r params args externctrl fn, + externctrl_params_mapped args params externctrl fn -> + (In r params) -> + exists n, externctrl ! r = Some (fn, HTL.ctrl_param n). + Proof. + intros param * [Hlen [Hnodup Hmapped]]. + intro Hin. + apply In_nth_error in Hin; destruct Hin as [n Hparam]. + edestruct (nth_error_same_length params args) as [arg Harg]; eauto. + edestruct (Hmapped _ _ Harg) as [param' [Hparam' ?]]. + replace param' with param in * by crush. + eauto. + Qed. + + Lemma Forall_map_iff : forall A B P (f : A -> B) (l : list A), + Forall P (map f l) <-> Forall (fun x => P (f x)) l. + Proof. + induction l; split; intros. + - trivial. + - simpl. trivial. + - inv H. + constructor. + auto. apply IHl. auto. + - inv H. + simpl. + constructor. + auto. apply IHl. auto. + Qed. + + (* Lemma stack_based_forall : forall args rs blk, *) + (* reg_stack_based_pointers blk rs -> *) + (* Forall (fun a : Values.val => stack_based a blk) (map (fun r : positive => rs !! r) args). *) + (* Proof. induction args; crush. Qed. *) + + + Ltac not_in_params_low := eapply param_reg_lower; eauto; lia. + Ltac not_in_params_other := + let contra := fresh "contra" in + intro contra; eapply in_params_exists in contra; eauto; crush. + + Ltac not_in_params := + solve [ + intros; try apply not_in_combine_l; (not_in_params_low + not_in_params_other) + ]. + + Lemma transl_icall_correct: + forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) + (pc : positive) (rs : RTL.regset) (m : mem) sig fn fd args dst pc', + (RTL.fn_code f) ! pc = Some (RTL.Icall sig fn args dst pc') -> + RTL.find_function ge fn rs = Some fd -> + forall R1 : HTL.state, + match_states ge (RTL.State s f sp pc rs m) R1 -> + exists R2 : HTL.state, + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ + match_states ge (RTL.Callstate (RTL.Stackframe dst f sp pc' rs :: s) fd + (List.map (fun r => Registers.Regmap.get r rs) args) m) + R2. + Proof. + Lemma merge_st : forall st n x args args' asr, + ~ In st args -> + st <> x -> + (Verilog.merge_regs ((empty_assocmap # st <- n) # x <- (ZToValue 1)) + ## args <- (asr ## args') + asr) ! st = Some n. + big_tac. + eapply AssocMapExt.merge_correct_1. + rewrite assign_all_out. + -- big_tac. + -- intros ? Hneg. + apply List.in_combine_l in Hneg. + contradiction. + Qed. + + intros * H Hfunc * MSTATE. + inv_state. + edestruct (only_internal_calls fd); eauto; subst fd. + inv CONST. + simplify. + destruct (transl_find _ _ ltac:(eauto) TRANSL). + eexists. split. + - eapply Smallstep.plus_three; simpl in *. + + eapply HTL.step_module; simpl. + * auto. + * auto. + * eauto. + * eauto. + * eauto. + * repeat econstructor; eauto. + * repeat econstructor; eauto. + * eapply fork_exec. + * constructor. + * trivial. + * trivial. + * apply merge_st. + -- eapply param_reg_lower; eauto. lia. + -- not_control_reg. + * eauto. + + assert ((asr # x3) = ZToValue 0) by eauto using MEXTERNCTRL. + eapply HTL.step_module; trivial. + * simpl. + apply AssocMapExt.merge_correct_2; auto. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by not_control_reg. + rewrite AssocMap.gso by lia. + apply AssocMap.gempty. + * simpl. + apply AssocMapExt.merge_correct_2; auto. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by not_control_reg. + rewrite AssocMap.gso by lia. + apply AssocMap.gempty. + * simpl. + apply AssocMapExt.merge_correct_1; auto. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gss. + * eauto. + * eauto. + * unfold state_wait. + eapply Verilog.stmnt_runp_Vcond_false. + -- simpl. econstructor; econstructor; simpl. + rewrite find_merge_right. eassumption. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by crush. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gempty. + -- auto. + -- econstructor. + * simpl. + apply AssocMapExt.merge_correct_1; auto. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gss. + * unfold join. + econstructor. + -- repeat econstructor. + -- eapply Verilog.stmnt_runp_Vcond_false. + ++ repeat econstructor. + ++ big_tac. + rewrite find_merge_right. replace (asr # x3). auto. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by crush. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gempty. + ++ repeat econstructor. + * constructor. + * simpl. + apply AssocMapExt.merge_correct_2. + big_tac; [ apply AssocMap.gempty | not_control_reg]. + apply merge_st. + -- not_in_params. + -- not_control_reg. + * auto. + + eapply HTL.step_initcall. + * eassumption. + * eassumption. + * eauto using param_mapping_correct. + * big_tac. + * simpl; trivial. + + eauto with htlproof. + - econstructor; try solve [repeat econstructor; eauto with htlproof ]. + + eauto using match_find_function. + + econstructor; eauto with htlproof. + * (* match_assocmaps *) big_tac. + apply regs_lessdef_add_greater. not_control_reg. + constructor; intros. + + rewrite find_merge_right. + hauto drew: off inv: match_assocmaps. + + rewrite assign_all_out by + (eapply not_in_params; try eassumption; not_control_reg). + rewrite AssocMap.gso by not_control_reg. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gempty. + * (* Match arrays *) inv MARR. big_tac. + * (* Match constants *) + constructor; big_tac. + -- apply AssocMapExt.merge_correct_2; crush. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by not_control_reg. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gempty. + -- not_control_reg. + -- apply AssocMapExt.merge_correct_2; crush. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by not_control_reg. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gempty. + -- not_control_reg. + * simplify. + unfold Verilog.merge_regs. + + apply match_externctrl_merge; [idtac | apply match_externctrl_merge ]; eauto; unfold match_externctrl; simplify. + -- rewrite AssocMap.fso by crush. + apply fempty. + -- apply find_default. + rewrite assign_all_out by not_in_params. + rewrite AssocMap.gso by crush. + rewrite AssocMap.gso by not_control_reg. + apply AssocMap.gempty. + + inv SP_VALID. + right. + inv SP_BASE. + * inv H26. inv H29. + econstructor. + * eauto with htlproof. + + crush. + + apply Forall_map_iff. + apply Forall_forall. + auto. + + (* Argument values match *) + big_tac. + replace (((AssocMapExt.merge value + ((empty_assocmap # st1 <- (posToValue x0)) # x1 <- (ZToValue 1)) ## x4 <- (asr ## args) + asr) # x1 <- (ZToValue 0)) ## x4) + with (asr ## args). + + * eauto using match_arg_vals, call_args_maxreg. + * unfold externctrl_params_mapped in *. + rewrite get_all_assign_out. + rewrite merge_correct_all_1. + -- crush. + -- rewrite get_all_length. + crush. + -- crush. + -- eauto using separate_params_reset. + Unshelve. + all: eauto; exact tt. + Qed. + Hint Resolve transl_icall_correct : htlproof. + Close Scope rtl. + + Lemma return_val_exec_spec : forall f or asr asa, + Verilog.expr_runp f asr asa (return_val or) + (match or with + | Some r => asr#r + | None => ZToValue 0 + end). + Proof. destruct or; repeat econstructor. Qed. + + Lemma transl_ireturn_correct: + forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) + (pc : positive) (rs : RTL.regset) (m : mem) (or : option Registers.reg) + (m' : mem), + (RTL.fn_code f) ! pc = Some (RTL.Ireturn or) -> + Mem.free m stk 0 (RTL.fn_stacksize f) = Some m' -> + forall R1 : HTL.state, + match_states ge (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) pc rs m) R1 -> + exists R2 : HTL.state, + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ + match_states ge (RTL.Returnstate s (Registers.regmap_optget or Values.Vundef rs) m') R2. + Proof. + intros * H H0 * MSTATE. + inv_state. + inv CONST. simplify. + eexists. split. + - eapply Smallstep.plus_two. + + eapply HTL.step_module; try solve [ repeat econstructor; eauto ]. + * repeat econstructor. apply return_val_exec_spec. + * big_tac. + * inversion wf1. + eapply H10. + eapply AssocMapExt.elements_iff. + eauto. + + eapply HTL.step_finish; big_tac. + + eauto with htlproof. + - econstructor; eauto with htlproof. + + edestruct no_stack_functions; eauto. + * replace (RTL.fn_stacksize f) in *. + eauto using mem_free_zero_match_frames. + * subst. inv MF. constructor. + + destruct or; simpl; auto. + + destruct or. + * rewrite fso. (* Return value is not fin *) + { + big_tac. + inv MASSOC. + apply H10. + eapply RTL.max_reg_function_use; eauto; crush. + } + assert (Ple r (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_use; eauto; crush). + xomega. + * simpl. eauto with htlproof. + Unshelve. try exact tt; eauto. + Qed. + Hint Resolve transl_ireturn_correct : htlproof. + + Hint Resolve stack_based_set : htlproof. + + Lemma transl_returnstate_correct: + forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) + (rs : RTL.regset) (s : list RTL.stackframe) (vres : Values.val) (m : mem) + (R1 : HTL.state), + match_states ge (RTL.Returnstate (RTL.Stackframe res0 f sp pc rs :: s) vres m) R1 -> + exists R2 : HTL.state, + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ + match_states ge (RTL.State s f sp pc (Registers.Regmap.set res0 vres rs) m) R2. + Proof. + intros * MSTATE. + inv MSTATE. + inversion MF. + inversion EXTERN_CALLER. + inversion TF. + + simplify. + eexists; split. + - eapply Smallstep.plus_three. + + (* Return to caller *) + eapply HTL.step_return; repeat econstructor; eauto. + + (* Join *) + inv CONST. + eapply HTL.step_module; eauto. + * big_tac; inv TF; simplify; not_control_reg. + * big_tac; inv TF; simplify; not_control_reg. + * big_tac; inv TF; simplify; not_control_reg. + * (* control logic *) + repeat econstructor. big_tac. simpl. + rewrite fso by crush. + rewrite fss. crush. + * big_tac; inv TF; simplify; not_control_reg. + * (* datapath *) + repeat econstructor. simpl. + rewrite AssocMap.fso by crush. + rewrite AssocMap.fss. + auto. + * simplify. constructor. + * big_tac; inv TF; simplify; not_control_reg. + + simplify. + eapply HTL.step_finish_reset with (fin:=fin). + big_tac. + * not_control_reg. + * not_control_reg. + * eauto. + + trivial. + - simpl. + eapply match_state; simpl; eauto. + + big_tac. + rewrite AssocMap.fss. + eapply regs_lessdef_add_greater; try not_control_reg. + eapply regs_lessdef_add_match; eauto. + repeat eapply regs_lessdef_add_greater; eauto; not_control_reg. + + unfold state_st_wf. + intros * Hwf. + inv Hwf. + big_tac. + * not_control_reg. + * not_control_reg. + + auto using match_arrs_empty. + + move SP_BASE at bottom. + move SP_BASE0 at bottom. + destruct s. + * (* Return from main *) + (* TODO: simplify *) + replace blk0 with blk in *. eauto with htlproof. + destruct SP_BASE; try solve [inv H2; crush]. + destruct SP_BASE0; try solve [inv H3]. + inv H3. inv H2. + eauto with htlproof. + inv H21. + * (* Return to other function *) + inv SP_BASE; inv H2; crush. + inv SP_BASE0. inv H2; crush. + replace blk0 with blk in *; eauto with htlproof. + + (* match_constants *) + inv CONST. + big_tac. + constructor. + * simplify. + rewrite AssocMap.fss. + repeat rewrite AssocMap.gso; auto; not_control_reg. + * simplify. + repeat rewrite AssocMap.gso; auto; not_control_reg. + + unfold match_externctrl. simplify. + destruct (peq fin r); subst; auto using fss. + rewrite fso by assumption. + rewrite find_merge_right. + * rewrite fso by crush. + rewrite fso by not_control_reg. + rewrite fso by not_control_reg. + unfold match_externctrl in *. + eauto. + * big_tac; try not_control_reg. + apply AssocMap.gempty. + Unshelve. all: try exact tt; eauto. + Qed. + #[local] Hint Resolve transl_returnstate_correct : htlproof. Ltac tac := repeat match goal with @@ -1168,7 +2447,7 @@ Section CORRECTNESS. | [ _ : context[if ?x then _ else _] |- _ ] => let EQ := fresh "EQ" in destruct x eqn:EQ; simpl in * - | [ H : ret _ _ = _ |- _ ] => invert H + | [ H : ret _ = _ |- _ ] => invert H | [ _ : context[match ?x with | _ => _ end] |- _ ] => destruct x end. @@ -1239,7 +2518,6 @@ Section CORRECTNESS. } rewrite <- H. auto. - Qed. Lemma offset_expr_ok_3 : @@ -1257,13 +2535,15 @@ Section CORRECTNESS. Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> Mem.loadv chunk m a = Some v -> forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> + match_states ge (RTL.State s f sp pc rs m) R1 -> exists R2 : HTL.state, Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc' (Registers.Regmap.set dst v rs) m) R2. + match_states ge (RTL.State s f sp pc' (Registers.Regmap.set dst v rs) m) R2. Proof. intros s f sp pc rs m chunk addr args dst pc' a v H H0 H1 R1 MSTATE. - inv_state. inv_arr_access. + inv_state. + + inv_arr_access. + (** Preamble *) invert MARR. inv CONST. crush. @@ -1336,28 +2616,29 @@ Section CORRECTNESS. inversion NORMALISE_BOUND as [ NORMALISE_BOUND_LOW NORMALISE_BOUND_HIGH ]; clear NORMALISE_BOUND. + (** Start of proof proper *) eexists. split. eapply Smallstep.plus_one. eapply HTL.step_module; eauto. - econstructor. econstructor. econstructor. crush. + econstructor. econstructor. econstructor. econstructor. crush. econstructor. econstructor. econstructor. crush. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. - econstructor. econstructor. + econstructor. all: big_tac. 1: { - assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + assert (HPle : (dst <= (RTL.max_reg_function f))%positive) + by (eapply RTL.max_reg_function_def; eauto). + lia. } 2: { - assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + assert (HPle : (dst <= (RTL.max_reg_function f))%positive) + by (eapply RTL.max_reg_function_def; eauto). + lia. } (** Match assocmaps *) @@ -1377,7 +2658,10 @@ Section CORRECTNESS. specialize (ASBP (Integers.Ptrofs.unsigned (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). exploit ASBP; big_tac. - rewrite NORMALISE in H14. rewrite HeqOFFSET in H14. rewrite H1 in H14. assumption. + match goal with + | [ H: context[stack_based] |- _ ] => rewrite NORMALISE in H; rewrite HeqOFFSET in H; rewrite H1 in H + end. + assumption. constructor; simplify. rewrite AssocMap.gso. rewrite AssocMap.gso. assumption. lia. assert (HPle: Ple dst (RTL.max_reg_function f)) @@ -1417,7 +2701,7 @@ Section CORRECTNESS. apply H11 in HPler1. invert HPler0; invert HPler1; try congruence. rewrite EQr0 in H13. - rewrite EQr1 in H14. + rewrite EQr1 in H22. invert H13. invert H14. clear H0. clear H8. clear H11. @@ -1432,7 +2716,8 @@ Section CORRECTNESS. (** Modular preservation proof *) assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. { apply Mem.load_valid_access in H1. unfold Mem.valid_access in *. simplify. - apply Zdivide_mod. assumption. } + apply Zdivide_mod. unfold valueToPtr in *. unfold uvalueToZ in *. unfold Ptrofs.of_int in *. unfold valueToInt in *. + inversion H22. subst. assumption. } (** Read bounds proof *) assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. @@ -1474,21 +2759,27 @@ Section CORRECTNESS. eexists. split. eapply Smallstep.plus_one. eapply HTL.step_module; eauto. - econstructor. econstructor. econstructor. crush. + econstructor. econstructor. econstructor. econstructor. econstructor. crush. econstructor. econstructor. econstructor. crush. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. auto. econstructor. - econstructor. econstructor. econstructor. econstructor. + econstructor. econstructor. econstructor. all: big_tac. - 1: { assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } + 1: { + assert (HPle : Ple dst (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto). + rewrite Pcompare_eq_Gt in *. + xomega. + } - 2: { assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } + 2: { + assert (HPle : Ple dst (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto). + rewrite Pcompare_eq_Gt in *. + xomega. + } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. @@ -1502,23 +2793,30 @@ Section CORRECTNESS. (Integers.Ptrofs.repr 4)))). exploit H9; big_tac. + (* This should have been solved somewhere above here *) + match goal with + | [ |- match_assocmaps _ _ _ ] => admit + end. + (** RSBP preservation *) unfold arr_stack_based_pointers in ASBP. specialize (ASBP (Integers.Ptrofs.unsigned (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). exploit ASBP; big_tac. - rewrite NORMALISE in H14. rewrite HeqOFFSET in H14. rewrite H1 in H14. assumption. + rewrite NORMALISE in H14. rewrite HeqOFFSET in H14. + inversion H22. replace (asr # r1) in *. rewrite H1 in *. assumption. + rewrite Pcompare_eq_Gt in *. constructor; simplify. rewrite AssocMap.gso. rewrite AssocMap.gso. assumption. lia. assert (HPle: Ple dst (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle. lia. + by (eapply RTL.max_reg_function_def; eauto). + xomega. rewrite AssocMap.gso. rewrite AssocMap.gso. assumption. lia. assert (HPle: Ple dst (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle. lia. + xomega. + invert MARR. inv CONST. crush. @@ -1533,7 +2831,7 @@ Section CORRECTNESS. rewrite ZERO in H1. clear ZERO. rewrite Integers.Ptrofs.add_zero_l in H1. - remember i0 as OFFSET. + remember i as OFFSET. (** Modular preservation proof *) assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. @@ -1578,18 +2876,20 @@ Section CORRECTNESS. eexists. split. eapply Smallstep.plus_one. eapply HTL.step_module; eauto. - econstructor. econstructor. econstructor. crush. - econstructor. econstructor. econstructor. econstructor. crush. + repeat econstructor. crush. + repeat econstructor. crush. all: big_tac. - 1: { assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } + 1: { + assert (HPle : Ple dst (RTL.max_reg_function f)) by (eauto using RTL.max_reg_function_def). + xomega. + } - 2: { assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } + 2: { + assert (HPle : Ple dst (RTL.max_reg_function f)) by (eauto using RTL.max_reg_function_def). + xomega. + } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. @@ -1622,13 +2922,8 @@ Section CORRECTNESS. unfold Ple in HPle. lia. Unshelve. - exact (Values.Vint (Int.repr 0)). - exact tt. - exact (Values.Vint (Int.repr 0)). - exact tt. - exact (Values.Vint (Int.repr 0)). - exact tt. - Qed. + all: try (exact tt); auto. + Admitted. #[local] Hint Resolve transl_iload_correct : htlproof. Lemma transl_istore_correct: @@ -1640,9 +2935,9 @@ Section CORRECTNESS. Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> Mem.storev chunk m a (Registers.Regmap.get src rs) = Some m' -> forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> + match_states ge (RTL.State s f sp pc rs m) R1 -> exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m') R2. + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states ge (RTL.State s f sp pc' rs m') R2. Proof. intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. inv_state. inv_arr_access. @@ -1725,6 +3020,8 @@ Section CORRECTNESS. unfold_merge. apply AssocMap.gss. + edestruct only_main_stores; eauto. subst; constructor. + (** Equality proof *) assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. @@ -1828,9 +3125,9 @@ Section CORRECTNESS. right. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H15; try lia. - apply Zmult_lt_compat_r with (p := 4) in H15; try lia. - rewrite ZLib.div_mul_undo in H15; try lia. + rewrite Z2Nat.id in *; try lia. + apply Zmult_lt_compat_r with (p := 4) in H27; try lia. + rewrite ZLib.div_mul_undo in *; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1894,8 +3191,8 @@ Section CORRECTNESS. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. invert H11. - apply Zmult_lt_compat_r with (p := 4) in H14; try lia. - rewrite ZLib.div_mul_undo in H14; try lia. + apply Zmult_lt_compat_r with (p := 4) in H22; try lia. + rewrite ZLib.div_mul_undo in *; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1965,8 +3262,8 @@ Section CORRECTNESS. apply H11 in HPler1. invert HPler0; invert HPler1; try congruence. rewrite EQr0 in H13. - rewrite EQr1 in H14. - invert H13. invert H14. + rewrite EQr1 in H22. + invert H13. invert H22. clear H0. clear H8. clear H11. unfold check_address_parameter_signed in *; @@ -2026,6 +3323,8 @@ Section CORRECTNESS. unfold_merge. apply AssocMap.gss. + edestruct only_main_stores; eauto; subst; constructor. + (** Equality proof *) assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. inversion MASSOC; revert HeqOFFSET; subst; clear MASSOC; intros HeqOFFSET. @@ -2094,20 +3393,20 @@ Section CORRECTNESS. erewrite combine_lookup_second. simpl. assert (Ple src (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H14 in H15. - destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H15; eauto. + by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + apply H22 in H27. + destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H27; eauto. rewrite <- array_set_len. unfold arr_repeat. crush. rewrite list_repeat_len. auto. assert (4 * ptr / 4 = Integers.Ptrofs.unsigned OFFSET / 4) by (f_equal; assumption). - rewrite Z.mul_comm in H15. - rewrite Z_div_mult in H15; try lia. - replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H15 by reflexivity. - rewrite <- PtrofsExtra.divu_unsigned in H15; unfold_constants; try lia. - rewrite H15. rewrite <- offset_expr_ok_2. + rewrite Z.mul_comm in H27. + rewrite Z_div_mult in H27; try lia. + replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H27 by reflexivity. + rewrite <- PtrofsExtra.divu_unsigned in H27; unfold_constants; try lia. + rewrite H27. rewrite <- offset_expr_ok_2. rewrite HeqOFFSET in *. rewrite array_get_error_set_bound. reflexivity. @@ -2128,9 +3427,9 @@ Section CORRECTNESS. right. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H17; try lia. - apply Zmult_lt_compat_r with (p := 4) in H17; try lia. - rewrite ZLib.div_mul_undo in H17; try lia. + rewrite Z2Nat.id in *; try lia. + apply Zmult_lt_compat_r with (p := 4) in H29; try lia. + rewrite ZLib.div_mul_undo in H29; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -2155,7 +3454,7 @@ Section CORRECTNESS. unfold_constants. intro. rewrite HeqOFFSET in *. - apply Z2Nat.inj_iff in H15; try lia. + apply Z2Nat.inj_iff in H27; try lia. apply Z.div_pos; try lia. apply Integers.Ptrofs.unsigned_range. apply Integers.Ptrofs.unsigned_range_2. @@ -2176,7 +3475,7 @@ Section CORRECTNESS. crush. destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; try constructor. destruct (Archi.ptr64); try discriminate. - pose proof (RSBP src). rewrite EQ_SRC in H14. + pose proof (RSBP src). rewrite EQ_SRC in H22. assumption. simpl. @@ -2194,9 +3493,9 @@ Section CORRECTNESS. right. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. - invert H14. - apply Zmult_lt_compat_r with (p := 4) in H16; try lia. - rewrite ZLib.div_mul_undo in H16; try lia. + invert H22. + apply Zmult_lt_compat_r with (p := 4) in H28; try lia. + rewrite ZLib.div_mul_undo in H28; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -2222,13 +3521,13 @@ Section CORRECTNESS. (Integers.Ptrofs.unsigned (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H14. - exact H14. eapply Mem.store_valid_access_3. eassumption. } + { pose proof H1. eapply Mem.store_valid_access_2 in H22. + exact H22. eapply Mem.store_valid_access_3. eassumption. } pose proof (Mem.valid_access_store m AST.Mint32 sp' (Integers.Ptrofs.unsigned (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) (Integers.Ptrofs.repr ptr))) v). - apply X in H14. invert H14. congruence. + apply X in H22. invert H22. congruence. constructor; simplify. unfold Verilog.merge_regs. unfold_merge. rewrite AssocMap.gso. assumption. lia. @@ -2248,7 +3547,7 @@ Section CORRECTNESS. rewrite ZERO in H1. clear ZERO. rewrite Integers.Ptrofs.add_zero_l in H1. - remember i0 as OFFSET. + remember i as OFFSET. (** Modular preservation proof *) assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. @@ -2295,6 +3594,9 @@ Section CORRECTNESS. unfold_merge. apply AssocMap.gss. + (** Match frames *) + edestruct only_main_stores; eauto; subst; constructor. + (** Equality proof *) assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. @@ -2346,7 +3648,7 @@ Section CORRECTNESS. rewrite H4. apply list_repeat_len. - remember i0 as OFFSET. + remember i as OFFSET. destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). erewrite Mem.load_store_same. @@ -2492,12 +3794,7 @@ Section CORRECTNESS. assumption. lia. Unshelve. - exact tt. - exact (Values.Vint (Int.repr 0)). - exact tt. - exact (Values.Vint (Int.repr 0)). - exact tt. - exact (Values.Vint (Int.repr 0)). + all: try (exact tt); auto. Qed. #[local] Hint Resolve transl_istore_correct : htlproof. @@ -2509,15 +3806,17 @@ Section CORRECTNESS. Op.eval_condition cond (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some b -> pc' = (if b then ifso else ifnot) -> forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> + match_states ge (RTL.State s f sp pc rs m) R1 -> exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states ge (RTL.State s f sp pc' rs m) R2. Proof. intros s f sp pc rs m cond args ifso ifnot b pc' H H0 H1 R1 MSTATE. inv_state. destruct b. - eexists. split. apply Smallstep.plus_one. - clear H33. + match goal with + | [H : Z.pos ifnot <= Int.max_unsigned |- _] => clear H + end. eapply HTL.step_module; eauto. inv CONST; assumption. inv CONST; assumption. @@ -2525,7 +3824,7 @@ Section CORRECTNESS. constructor; trivial. eapply Verilog.erun_Vternary_true; simpl; eauto. eapply eval_cond_correct; eauto. intros. - intros. eapply RTL.max_reg_function_use. apply H22. auto. + intros. eapply RTL.max_reg_function_use. eauto. auto. econstructor. auto. simpl. econstructor. constructor. unfold Verilog.merge_regs. unfold_merge. simpl. apply AssocMap.gss. @@ -2533,8 +3832,11 @@ Section CORRECTNESS. inv MARR. inv CONST. big_tac. constructor; rewrite AssocMap.gso; simplify; try assumption; lia. + - eexists. split. apply Smallstep.plus_one. - clear H32. + match goal with + | [H : Z.pos ifso <= Int.max_unsigned |- _] => clear H + end. eapply HTL.step_module; eauto. inv CONST; assumption. inv CONST; assumption. @@ -2542,7 +3844,7 @@ Section CORRECTNESS. constructor; trivial. eapply Verilog.erun_Vternary_false; simpl; eauto. eapply eval_cond_correct; eauto. intros. - intros. eapply RTL.max_reg_function_use. apply H22. auto. + intros. eapply RTL.max_reg_function_use. eauto. auto. econstructor. auto. simpl. econstructor. constructor. unfold Verilog.merge_regs. unfold_merge. simpl. apply AssocMap.gss. @@ -2563,229 +3865,14 @@ Section CORRECTNESS. Registers.Regmap.get arg rs = Values.Vint n -> list_nth_z tbl (Integers.Int.unsigned n) = Some pc' -> forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> + match_states ge (RTL.State s f sp pc rs m) R1 -> exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. + Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states ge (RTL.State s f sp pc' rs m) R2. Proof. intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. #[local] Hint Resolve transl_ijumptable_correct : htlproof.*) - Lemma transl_ireturn_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) - (pc : positive) (rs : RTL.regset) (m : mem) (or : option Registers.reg) - (m' : mem), - (RTL.fn_code f) ! pc = Some (RTL.Ireturn or) -> - Mem.free m stk 0 (RTL.fn_stacksize f) = Some m' -> - forall R1 : HTL.state, - match_states (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.Returnstate s (Registers.regmap_optget or Values.Vundef rs) m') R2. - Proof. - intros s f stk pc rs m or m' H H0 R1 MSTATE. - inv_state. - - - econstructor. split. - eapply Smallstep.plus_two. - - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. - constructor. - econstructor; simpl; trivial. - econstructor; simpl; trivial. - constructor. - econstructor; simpl; trivial. - constructor. - - constructor. constructor. constructor. - - unfold state_st_wf in WF; big_tac; eauto. - destruct wf1 as [HCTRL HDATA]. apply HCTRL. - apply AssocMapExt.elements_iff. eexists. - match goal with H: control ! pc = Some _ |- _ => apply H end. - - apply HTL.step_finish. - unfold Verilog.merge_regs. - unfold_merge; simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. lia. - apply AssocMap.gss. - rewrite Events.E0_left. reflexivity. - - constructor; auto. - constructor. - - (* FIXME: Duplication *) - - econstructor. split. - eapply Smallstep.plus_two. - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. - constructor. - econstructor; simpl; trivial. - econstructor; simpl; trivial. - constructor. constructor. constructor. - constructor. constructor. constructor. - constructor. - - unfold state_st_wf in WF; big_tac; eauto. - - destruct wf1 as [HCTRL HDATA]. apply HCTRL. - apply AssocMapExt.elements_iff. eexists. - match goal with H: control ! pc = Some _ |- _ => apply H end. - - apply HTL.step_finish. - unfold Verilog.merge_regs. - unfold_merge. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. simpl; lia. - apply AssocMap.gss. - rewrite Events.E0_left. trivial. - - constructor; auto. - - simpl. inversion MASSOC. subst. - unfold find_assocmap, AssocMapExt.get_default. rewrite AssocMap.gso. - apply H1. eapply RTL.max_reg_function_use. eauto. simpl; tauto. - assert (HPle : Ple r (RTL.max_reg_function f)). - eapply RTL.max_reg_function_use. eassumption. simpl; auto. - apply ZExtra.Ple_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - - Unshelve. - all: constructor. - Qed. - #[local] Hint Resolve transl_ireturn_correct : htlproof. - - Lemma transl_callstate_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) - (m : mem) (m' : Mem.mem') (stk : Values.block), - Mem.alloc m 0 (RTL.fn_stacksize f) = (m', stk) -> - forall R1 : HTL.state, - match_states (RTL.Callstate s (AST.Internal f) args m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states - (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) (RTL.fn_entrypoint f) - (RTL.init_regs args (RTL.fn_params f)) m') R2. - Proof. - intros s f args m m' stk H R1 MSTATE. - - inversion MSTATE; subst. inversion TF; subst. - econstructor. split. apply Smallstep.plus_one. - eapply HTL.step_call. crush. - - apply match_state with (sp' := stk); eauto. - - all: big_tac. - - apply regs_lessdef_add_greater. unfold Plt; lia. - apply regs_lessdef_add_greater. unfold Plt; lia. - apply regs_lessdef_add_greater. unfold Plt; lia. - apply init_reg_assoc_empty. - - constructor. - - destruct (Mem.load AST.Mint32 m' stk - (Integers.Ptrofs.unsigned (Integers.Ptrofs.add - Integers.Ptrofs.zero - (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. - pose proof Mem.load_alloc_same as LOAD_ALLOC. - pose proof H as ALLOC. - eapply LOAD_ALLOC in ALLOC. - 2: { exact LOAD. } - ptrofs. rewrite LOAD. - rewrite ALLOC. - repeat constructor. - - ptrofs. rewrite LOAD. - repeat constructor. - - unfold reg_stack_based_pointers. intros. - unfold RTL.init_regs; crush. - destruct (RTL.fn_params f); - rewrite Registers.Regmap.gi; constructor. - - unfold arr_stack_based_pointers. intros. - crush. - destruct (Mem.load AST.Mint32 m' stk - (Integers.Ptrofs.unsigned (Integers.Ptrofs.add - Integers.Ptrofs.zero - (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. - pose proof Mem.load_alloc_same as LOAD_ALLOC. - pose proof H as ALLOC. - eapply LOAD_ALLOC in ALLOC. - 2: { exact LOAD. } - rewrite ALLOC. - repeat constructor. - constructor. - - Transparent Mem.alloc. (* TODO: Since there are opaque there's probably a lemma. *) - Transparent Mem.load. - Transparent Mem.store. - unfold stack_bounds. - split. - - unfold Mem.alloc in H. - invert H. - crush. - unfold Mem.load. - intros. - match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H4. - unfold Mem.perm in H4. crush. - unfold Mem.perm_order' in H4. - small_tac. - exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. - rewrite Maps.PMap.gss in H8. - match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. - crush. - apply proj_sumbool_true in H10. lia. - - unfold Mem.alloc in H. - invert H. - crush. - unfold Mem.store. - intros. - match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H4. - unfold Mem.perm in H4. crush. - unfold Mem.perm_order' in H4. - small_tac. - exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. - rewrite Maps.PMap.gss in H8. - match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. - crush. - apply proj_sumbool_true in H10. lia. - constructor. simplify. rewrite AssocMap.gss. - simplify. rewrite AssocMap.gso. apply AssocMap.gss. simplify. lia. - Opaque Mem.alloc. - Opaque Mem.load. - Opaque Mem.store. - Qed. - #[local] Hint Resolve transl_callstate_correct : htlproof. - - Lemma transl_returnstate_correct: - forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) - (rs : RTL.regset) (s : list RTL.stackframe) (vres : Values.val) (m : mem) - (R1 : HTL.state), - match_states (RTL.Returnstate (RTL.Stackframe res0 f sp pc rs :: s) vres m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc (Registers.Regmap.set res0 vres rs) m) R2. - Proof. - intros res0 f sp pc rs s vres m R1 MSTATE. - inversion MSTATE. inversion MF. - Qed. - #[local] Hint Resolve transl_returnstate_correct : htlproof. - - Lemma option_inv : - forall A x y, - @Some A x = Some y -> x = y. - Proof. intros. inversion H. trivial. Qed. - Lemma main_tprog_internal : forall b, Globalenvs.Genv.find_symbol tge tprog.(AST.prog_main) = Some b -> @@ -2803,19 +3890,26 @@ Section CORRECTNESS. trivial. symmetry; eapply Linking.match_program_main; eauto. Qed. + Hint Constructors list_forall2 : htlproof. + Hint Constructors match_frames : htlproof. + Lemma transl_initial_states : forall s1 : Smallstep.state (RTL.semantics prog), Smallstep.initial_state (RTL.semantics prog) s1 -> exists s2 : Smallstep.state (HTL.semantics tprog), - Smallstep.initial_state (HTL.semantics tprog) s2 /\ match_states s1 s2. + Smallstep.initial_state (HTL.semantics tprog) s2 /\ match_states ge s1 s2. Proof. induction 1. - destruct TRANSL. unfold main_is_internal in H4. - repeat (unfold_match H4). - assert (f = AST.Internal f1). apply option_inv. - rewrite <- Heqo0. rewrite <- H1. replace b with b0. - auto. apply option_inv. rewrite <- H0. rewrite <- Heqo. - trivial. + destruct TRANSL. + unfold main_is_internal in H4. repeat (unfold_match H4). + assert (f = AST.Internal f1). + { + apply option_inv. + rewrite <- Heqo0. rewrite <- H1. replace b with b0. + auto. apply option_inv. rewrite <- H0. rewrite <- Heqo. + trivial. + } + exploit function_ptr_translated; eauto. intros [tf [A B]]. unfold transl_fundef, Errors.bind in B. @@ -2826,18 +3920,17 @@ Section CORRECTNESS. apply Heqo. symmetry; eapply Linking.match_program_main; eauto. inversion H5. econstructor; split. econstructor. - apply (Genv.init_mem_transf_partial TRANSL'); eauto. - replace (AST.prog_main tprog) with (AST.prog_main prog). - rewrite symbols_preserved; eauto. - symmetry; eapply Linking.match_program_main; eauto. - apply H6. - - constructor. - apply transl_module_correct. - assert (Some (AST.Internal x) = Some (AST.Internal m)). - replace (AST.fundef HTL.module) with (HTL.fundef). - rewrite <- H6. setoid_rewrite <- A. trivial. - trivial. inv H7. assumption. + - apply (Genv.init_mem_transf_partial TRANSL'); eauto. + - replace (AST.prog_main tprog) with (AST.prog_main prog) + by (symmetry; eapply Linking.match_program_main; eauto). + rewrite symbols_preserved; eauto. + - eauto. + - constructor; auto with htlproof. + apply transl_module_correct. + assert (Some (AST.Internal x) = Some (AST.Internal m)) as Heqm. + { rewrite <- H6. setoid_rewrite <- A. trivial. } + inv Heqm. + assumption. Qed. #[local] Hint Resolve transl_initial_states : htlproof. @@ -2845,11 +3938,13 @@ Section CORRECTNESS. forall (s1 : Smallstep.state (RTL.semantics prog)) (s2 : Smallstep.state (HTL.semantics tprog)) (r : Integers.Int.int), - match_states s1 s2 -> + match_states ge s1 s2 -> Smallstep.final_state (RTL.semantics prog) s1 r -> Smallstep.final_state (HTL.semantics tprog) s2 r. Proof. - intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. + intros. + repeat match goal with [ H : _ |- _ ] => try inv H end. + repeat constructor; auto. Qed. #[local] Hint Resolve transl_final_states : htlproof. @@ -2857,10 +3952,10 @@ Section CORRECTNESS. forall (S1 : RTL.state) t S2, RTL.step ge S1 t S2 -> forall (R1 : HTL.state), - match_states S1 R1 -> - exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states S2 R2. + match_states ge S1 R1 -> + exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states ge S2 R2. Proof. - induction 1; eauto with htlproof; (intros; inv_state). + induction 1; eauto with htlproof; try solve [ intros; inv_state ]. Qed. #[local] Hint Resolve transl_step_correct : htlproof. diff --git a/src/hls/HTLgenspec.v b/src/hls/HTLgenspec.v index 8746ba2..c38b4e6 100644 --- a/src/hls/HTLgenspec.v +++ b/src/hls/HTLgenspec.v @@ -21,19 +21,144 @@ Require Import Coq.micromega.Lia. Require compcert.backend.RTL. Require compcert.common.Errors. +Require compcert.common.Globalenvs. Require Import compcert.lib.Integers. Require Import compcert.lib.Maps. Require compcert.verilog.Op. Require Import vericert.common.Vericertlib. +Require Import vericert.common.ListExtra. Require Import vericert.hls.Verilog. Require Import vericert.hls.ValueInt. Require Import vericert.hls.HTL. Require Import vericert.hls.HTLgen. Require Import vericert.hls.AssocMap. +From Hammer Require Import Tactics. + +(** * Relational specification of the translation *) + +(** We now define inductive predicates that characterise the fact that the +statemachine that is created by the translation contains the correct +translations for each of the elements *) + +(** [tr_instr] describes the translation of instructions that are directly translated into a single state *) +Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> datapath_stmnt -> control_stmnt -> Prop := +| tr_instr_Inop : + forall n, + Z.pos n <= Int.max_unsigned -> + tr_instr fin rtrn st stk (RTL.Inop n) Vskip (state_goto st n) +| tr_instr_Iop : + forall n op args dst s s' e i, + Z.pos n <= Int.max_unsigned -> + translate_instr op args s = OK e s' i -> + tr_instr fin rtrn st stk (RTL.Iop op args dst n) (Vnonblock (Vvar dst) e) (state_goto st n) +| tr_instr_Icond : + forall n1 n2 cond args s s' i c, + Z.pos n1 <= Int.max_unsigned -> + Z.pos n2 <= Int.max_unsigned -> + translate_condition cond args s = OK c s' i -> + tr_instr fin rtrn st stk (RTL.Icond cond args n1 n2) Vskip (state_cond st c n1 n2) +| tr_instr_Iload : + forall mem addr args s s' i c dst n, + Z.pos n <= Int.max_unsigned -> + translate_arr_access mem addr args stk s = OK c s' i -> + tr_instr fin rtrn st stk (RTL.Iload mem addr args dst n) (Vnonblock (Vvar dst) c) (state_goto st n) +| tr_instr_Istore : + forall mem addr args s s' i c src n, + Z.pos n <= Int.max_unsigned -> + translate_arr_access mem addr args stk s = OK c s' i -> + tr_instr fin rtrn st stk (RTL.Istore mem addr args src n) (Vnonblock c (Vvar src)) + (state_goto st n). +(*| tr_instr_Ijumptable : + forall cexpr tbl r, + cexpr = tbl_to_case_expr st tbl -> + tr_instr fin rtrn st stk (RTL.Ijumptable r tbl) (Vskip) (Vcase (Vvar r) cexpr (Some Vskip)).*) +Hint Constructors tr_instr : htlspec. + +Definition externctrl_params_mapped (args params : list reg) externctrl (fn : ident) := + length args = length params /\ + NoDup params /\ + forall n arg, List.nth_error args n = Some arg -> + exists r, List.nth_error params n = Some r /\ + externctrl ! r = Some (fn, ctrl_param n). +Hint Transparent externctrl_params_mapped : htlspec. + +Inductive tr_code (ge : RTL.genv) (c : RTL.code) (pc : RTL.node) (stmnts : datapath) (trans : controllogic) + (externctrl : AssocMap.t (ident * controlsignal)) (fin rtrn st stk : reg) : RTL.instruction -> Prop := +| tr_code_single : + forall i s t, + c!pc = Some i -> + stmnts!pc = Some s -> + trans!pc = Some t -> + tr_instr fin rtrn st stk i s t -> + tr_code ge c pc stmnts trans externctrl fin rtrn st stk i +| tr_code_call : + forall sig fn args dst n, + c!pc = Some (RTL.Icall sig (inr fn) args dst n) -> + (exists fd, find_func ge fn = Some (AST.Internal fd)) -> + Z.pos n <= Int.max_unsigned -> + + (exists pc2 fn_rst fn_return fn_finish fn_params, + externctrl ! fn_rst = Some (fn, ctrl_reset) /\ + externctrl ! fn_return = Some (fn, ctrl_return) /\ + externctrl ! fn_finish = Some (fn, ctrl_finish) /\ + externctrl_params_mapped args fn_params externctrl fn /\ + Z.pos pc2 <= Int.max_unsigned /\ + stmnts!pc = Some (fork fn_rst (List.combine fn_params args)) /\ + trans!pc = Some (state_goto st pc2) /\ + stmnts!pc2 = Some (join fn_finish fn_rst fn_return dst) /\ + trans!pc2 = Some (state_wait st fn_finish n)) -> + + tr_code ge c pc stmnts trans externctrl fin rtrn st stk (RTL.Icall sig (inr fn) args dst n) +| tr_code_return : + forall r, + c!pc = Some (RTL.Ireturn r) -> + + (exists pc2, + stmnts!pc = Some (do_return fin rtrn r) /\ + trans!pc = Some (state_goto st pc2) /\ + stmnts!pc2 = Some (idle fin) /\ + trans!pc2 = Some Vskip) -> + + tr_code ge c pc stmnts trans externctrl fin rtrn st stk (RTL.Ireturn r). +Hint Constructors tr_code : htlspec. + +Definition externctrl_ordering (externctrl : AssocMap.t (ident * controlsignal)) clk := + forall n, (exists x, externctrl!n = Some x) -> (n > clk)%positive. + +Inductive tr_module (ge : RTL.genv) (f : RTL.function) : module -> Prop := + tr_module_intro : + forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls externctrl wf1 wf2 wf3 wf4, + m = (mkmodule f.(RTL.fn_params) + data + control + f.(RTL.fn_entrypoint) + st stk stk_len fin rtrn start rst clk scldecls arrdecls externctrl None wf1 wf2 wf3 wf4) -> + (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> + tr_code ge f.(RTL.fn_code) pc data control externctrl fin rtrn st stk i) -> + stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> + Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> + 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> + (st > (RTL.max_reg_function f))%positive -> + (fin > st)%positive -> + (rtrn > fin)%positive -> + (stk > rtrn)%positive -> + (start > stk)%positive -> + (rst > start)%positive -> + (clk > rst)%positive -> + externctrl_ordering externctrl clk -> + tr_module ge f m. +#[local] Hint Constructors tr_module : htlspec. + #[local] Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. #[local] Hint Resolve Maps.PTree.elements_correct : htlspec. +#[local] Hint Resolve Maps.PTree.gss : htlspec. +#[local] Hint Resolve PTree.elements_complete : htlspec. +#[local] Hint Resolve -> Z.leb_le : htlspec. + +#[local] Hint Unfold block : htlspec. +#[local] Hint Unfold nonblock : htlspec. Remark bind_inversion: forall (A B: Type) (f: mon A) (g: A -> mon B) @@ -41,13 +166,7 @@ Remark bind_inversion: bind f g s1 = OK y s3 i -> exists x, exists s2, exists i1, exists i2, f s1 = OK x s2 i1 /\ g x s2 = OK y s3 i2. -Proof. - intros until i. unfold bind. destruct (f s1); intros. - discriminate. - exists a; exists s'; exists s. - destruct (g a s'); inv H. - exists s0; auto. -Qed. +Proof. unfold bind. sauto. Qed. Remark bind2_inversion: forall (A B C: Type) (f: mon (A*B)) (g: A -> B -> mon C) @@ -55,15 +174,12 @@ Remark bind2_inversion: bind2 f g s1 = OK z s3 i -> exists x, exists y, exists s2, exists i1, exists i2, f s1 = OK (x, y) s2 i1 /\ g x y s2 = OK z s3 i2. -Proof. - unfold bind2; intros. - exploit bind_inversion; eauto. - intros [[x y] [s2 [i1 [i2 [P Q]]]]]. simpl in Q. - exists x; exists y; exists s2; exists i1; exists i2; auto. -Qed. +Proof. sauto using bind_inversion. Qed. Ltac monadInv1 H := match type of H with + | ((match ?x with | _ => _ end) = OK _ _ _) => + destruct x eqn:?; try discriminate; try monadInv1 H | (OK _ _ _ = OK _ _ _) => inversion H; clear H; try subst | (Error _ _ = OK _ _ _) => @@ -98,6 +214,7 @@ Ltac monadInv1 H := Ltac monadInv H := match type of H with | (ret _ _ = OK _ _ _) => monadInv1 H + | (OK _ _ = OK _ _ _) => monadInv1 H | (error _ _ = OK _ _ _) => monadInv1 H | (bind ?F ?G ?S = OK ?X ?S' ?I) => monadInv1 H | (bind2 ?F ?G ?S = OK ?X ?S' ?I) => monadInv1 H @@ -119,538 +236,393 @@ Ltac monadInv H := ((progress simpl in H) || unfold F in H); monadInv1 H end. -(** * Relational specification of the translation *) - -(** We now define inductive predicates that characterise the fact that the -statemachine that is created by the translation contains the correct -translations for each of the elements *) - -Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt -> Prop := -| tr_instr_Inop : - forall n, - Z.pos n <= Int.max_unsigned -> - tr_instr fin rtrn st stk (RTL.Inop n) Vskip (state_goto st n) -| tr_instr_Iop : - forall n op args dst s s' e i, - Z.pos n <= Int.max_unsigned -> - translate_instr op args s = OK e s' i -> - tr_instr fin rtrn st stk (RTL.Iop op args dst n) (Vnonblock (Vvar dst) e) (state_goto st n) -| tr_instr_Icond : - forall n1 n2 cond args s s' i c, - Z.pos n1 <= Int.max_unsigned -> - Z.pos n2 <= Int.max_unsigned -> - translate_condition cond args s = OK c s' i -> - tr_instr fin rtrn st stk (RTL.Icond cond args n1 n2) Vskip (state_cond st c n1 n2) -| tr_instr_Ireturn_None : - tr_instr fin rtrn st stk (RTL.Ireturn None) (Vseq (block fin (Vlit (ZToValue 1%Z))) - (block rtrn (Vlit (ZToValue 0%Z)))) Vskip -| tr_instr_Ireturn_Some : - forall r, - tr_instr fin rtrn st stk (RTL.Ireturn (Some r)) - (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r))) Vskip -| tr_instr_Iload : - forall mem addr args s s' i c dst n, - Z.pos n <= Int.max_unsigned -> - translate_arr_access mem addr args stk s = OK c s' i -> - tr_instr fin rtrn st stk (RTL.Iload mem addr args dst n) (nonblock dst c) (state_goto st n) -| tr_instr_Istore : - forall mem addr args s s' i c src n, - Z.pos n <= Int.max_unsigned -> - translate_arr_access mem addr args stk s = OK c s' i -> - tr_instr fin rtrn st stk (RTL.Istore mem addr args src n) (Vnonblock c (Vvar src)) - (state_goto st n). -(*| tr_instr_Ijumptable : - forall cexpr tbl r, - cexpr = tbl_to_case_expr st tbl -> - tr_instr fin rtrn st stk (RTL.Ijumptable r tbl) (Vskip) (Vcase (Vvar r) cexpr (Some Vskip)).*) -#[local] Hint Constructors tr_instr : htlspec. - -Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts trans : PTree.t stmnt) - (fin rtrn st stk : reg) : Prop := - tr_code_intro : - forall s t, - c!pc = Some i -> - stmnts!pc = Some s -> - trans!pc = Some t -> - tr_instr fin rtrn st stk i s t -> - tr_code c pc i stmnts trans fin rtrn st stk. -#[local] Hint Constructors tr_code : htlspec. - -Inductive tr_module (f : RTL.function) : module -> Prop := - tr_module_intro : - forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf1 wf2 wf3 wf4, - m = (mkmodule f.(RTL.fn_params) - data - control - f.(RTL.fn_entrypoint) - st stk stk_len fin rtrn start rst clk scldecls arrdecls None wf1 wf2 wf3 wf4) -> - (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> - tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> - stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> - Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> - 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> - st = ((RTL.max_reg_function f) + 1)%positive -> - fin = ((RTL.max_reg_function f) + 2)%positive -> - rtrn = ((RTL.max_reg_function f) + 3)%positive -> - stk = ((RTL.max_reg_function f) + 4)%positive -> - start = ((RTL.max_reg_function f) + 5)%positive -> - rst = ((RTL.max_reg_function f) + 6)%positive -> - clk = ((RTL.max_reg_function f) + 7)%positive -> - tr_module f m. -#[local] Hint Constructors tr_module : htlspec. - -Lemma create_reg_datapath_trans : - forall sz s s' x i iop, - create_reg iop sz s = OK x s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. intros. monadInv H. trivial. Qed. -#[local] Hint Resolve create_reg_datapath_trans : htlspec. - -Lemma create_reg_controllogic_trans : - forall sz s s' x i iop, - create_reg iop sz s = OK x s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. intros. monadInv H. trivial. Qed. -#[local] Hint Resolve create_reg_controllogic_trans : htlspec. - -Lemma declare_reg_datapath_trans : - forall sz s s' x i iop r, - declare_reg iop r sz s = OK x s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. intros. monadInv H. trivial. Qed. -#[local] Hint Resolve create_reg_datapath_trans : htlspec. - -Lemma declare_reg_controllogic_trans : - forall sz s s' x i iop r, - declare_reg iop r sz s = OK x s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. intros. monadInv H. trivial. Qed. -#[local] Hint Resolve create_reg_controllogic_trans : htlspec. - -Lemma declare_reg_freshreg_trans : - forall sz s s' x i iop r, - declare_reg iop r sz s = OK x s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. inversion 1; auto. Qed. -#[local] Hint Resolve declare_reg_freshreg_trans : htlspec. - -Lemma create_arr_datapath_trans : - forall sz ln s s' x i iop, - create_arr iop sz ln s = OK x s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. intros. monadInv H. trivial. Qed. -#[local] Hint Resolve create_arr_datapath_trans : htlspec. - -Lemma create_arr_controllogic_trans : - forall sz ln s s' x i iop, - create_arr iop sz ln s = OK x s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. intros. monadInv H. trivial. Qed. -#[local] Hint Resolve create_arr_controllogic_trans : htlspec. - -Lemma get_refl_x : - forall s s' x i, - get s = OK x s' i -> - s = x. -Proof. inversion 1. trivial. Qed. -#[local] Hint Resolve get_refl_x : htlspec. - -Lemma get_refl_s : - forall s s' x i, - get s = OK x s' i -> - s = s'. -Proof. inversion 1. trivial. Qed. -#[local] Hint Resolve get_refl_s : htlspec. - -Ltac inv_incr := - repeat match goal with - | [ H: create_reg _ _ ?s = OK _ ?s' _ |- _ ] => - let H1 := fresh "H" in - assert (H1 := H); eapply create_reg_datapath_trans in H; - eapply create_reg_controllogic_trans in H1 - | [ H: create_arr _ _ _ ?s = OK _ ?s' _ |- _ ] => - let H1 := fresh "H" in - assert (H1 := H); eapply create_arr_datapath_trans in H; - eapply create_arr_controllogic_trans in H1 - | [ H: get ?s = OK _ _ _ |- _ ] => - let H1 := fresh "H" in - assert (H1 := H); apply get_refl_x in H; apply get_refl_s in H1; - subst - | [ H: st_prop _ _ |- _ ] => unfold st_prop in H; destruct H - | [ H: st_incr _ _ |- _ ] => destruct st_incr +Ltac rewrite_states := + match goal with + | [ H: ?x ?s = ?x ?s' |- _ ] => + let c1 := fresh "c" in + let c2 := fresh "c" in + learn (?x ?s) as c1; learn (?x ?s') as c2; try subst end. -Lemma collect_controllogic_trans : - forall A f l cs cs' ci, - (forall s s' x i y, f y s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic)) -> - @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_controllogic) = cs'.(st_controllogic). -Proof. - induction l; intros; monadInv H0. - - trivial. - - apply H in EQ. rewrite EQ. eauto. -Qed. - -Lemma collect_datapath_trans : - forall A f l cs cs' ci, - (forall s s' x i y, f y s = OK x s' i -> s.(st_datapath) = s'.(st_datapath)) -> - @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_datapath) = cs'.(st_datapath). -Proof. - induction l; intros; monadInv H0. - - trivial. - - apply H in EQ. rewrite EQ. eauto. -Qed. - -Lemma collect_freshreg_trans : - forall A f l cs cs' ci, - (forall s s' x i y, f y s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg)) -> - @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_freshreg) = cs'.(st_freshreg). -Proof. - induction l; intros; monadInv H0. - - trivial. - - apply H in EQ. rewrite EQ. eauto. -Qed. +Ltac saturate_incr := + repeat match goal with + | [INCR1 : st_prop ?s1 ?s2, INCR2 : st_prop ?s2 ?s3 |- _] => + let INCR3 := fresh "INCR" in + learn (st_trans s1 s2 s3 INCR1 INCR2) + end. -Lemma collect_declare_controllogic_trans : - forall io n l s s' i, - HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. - intros. eapply collect_controllogic_trans; try eassumption. - intros. eapply declare_reg_controllogic_trans. simpl in H0. eassumption. -Qed. +(** Used to solve goals that follow directly from a single monadic operation *) +Ltac intro_step := + match goal with + | [ H : _ = OK _ _ _ |- _ ] => solve [ monadInv H; simplify; eauto with htlspec ] + end. -Lemma collect_declare_datapath_trans : - forall io n l s s' i, - HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. - intros. eapply collect_datapath_trans; try eassumption. - intros. eapply declare_reg_datapath_trans. simpl in H0. eassumption. -Qed. +(** Used to transfer a result about one of the maps in the state from one + state to a latter one *) +Ltac trans_step s1 s2 := + saturate_incr; + match goal with + | [ INCR : st_prop s1 s2 |- _ ] => try solve [inversion INCR; crush]; destruct INCR + end; + solve [ + match goal with + | [ MAP_INCR : HTLgen.map_incr ?map _ _ |- (?map _) ! ?idx = _ ] => + destruct MAP_INCR with idx; try crush_trans; crush + end + ]. + +(* FIXME: monad_crush can be slow when there are a lot of intermediate states. *) + +(* Try to prove a goal about a state by first proving it for an earlier state and then transfering it to the final. *) +Ltac monad_crush := + match goal with + | [ finalstate : st, prevstate : st |- _] => + match goal with + | [ |- context f[finalstate]] => + let inter := context f[prevstate] in + try solve [ + match inter with + | context f[finalstate] => + let inter := context f[prevstate] in + solve [assert inter by intro_step; trans_step prevstate finalstate] + end + ]; + solve [assert inter by intro_step; trans_step prevstate finalstate] + end + end. -Lemma collect_declare_freshreg_trans : - forall io n l s s' i, - HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - intros. eapply collect_freshreg_trans; try eassumption. - inversion 1. auto. -Qed. +Ltac full_split := repeat match goal with [ |- _ /\ _ ] => split end. -Ltac unfold_match H := - match type of H with - | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate +Ltac relevant_monad_inv := + multimatch goal with + | [ EQ : _ ?s = OK ?x _ _ |- context[?x] ] => monadInv EQ + | [ EQ : _ ?s = OK (?x, _) _ _ |- context[?x] ] => monadInv EQ + | [ EQ : _ ?s = OK (_, ?x) _ _ |- context[?x] ] => monadInv EQ + | [ EQ : _ ?s = OK (_, ?x) _ _ |- context[?x] ] => monadInv EQ end. -Lemma translate_eff_addressing_freshreg_trans : - forall op args s r s' i, - translate_eff_addressing op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. -Qed. -#[local] Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. +Ltac any_monad_inv := + relevant_monad_inv + + multimatch goal with + | [ EQ : _ ?s = OK _ _ _ |- _ ] => monadInv EQ + end. -Lemma translate_comparison_freshreg_trans : - forall op args s r s' i, - translate_comparison op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. -Qed. -#[local] Hint Resolve translate_comparison_freshreg_trans : htlspec. +Ltac some_incr := + saturate_incr; + multimatch goal with + | [ INCR : st_prop _ _ |- _ ] => inversion INCR + end. -Lemma translate_comparisonu_freshreg_trans : - forall op args s r s' i, - translate_comparisonu op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). +Lemma xmap_externctrl_params_args : forall args param_pairs fn s s' k i, + xmap_externctrl_params k fn args s = OK param_pairs s' i -> + snd (List.split param_pairs) = args. Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. + induction args. + - sauto. + - intros. monadInv H. sauto. Qed. -#[local] Hint Resolve translate_comparisonu_freshreg_trans : htlspec. -Lemma translate_comparison_imm_freshreg_trans : - forall op args s r s' i n, - translate_comparison_imm op args n s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. -Qed. -#[local] Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. +Lemma map_externctrl_params_args : forall args param_pairs fn s s' i, + map_externctrl_params fn args s = OK param_pairs s' i -> + snd (List.split param_pairs) = args. +Proof. sauto use: xmap_externctrl_params_args. Qed. -Lemma translate_comparison_immu_freshreg_trans : - forall op args s r s' i n, - translate_comparison_immu op args n s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). +Lemma helper__map_externctrl_params_spec : forall args param_pairs k fn s s' i, + xmap_externctrl_params k fn args s = OK param_pairs s' i -> + forall n, + (n < length args)%nat -> + exists r, (List.nth_error (fst (List.split param_pairs)) n = Some r) /\ + (s'.(st_externctrl) ! r = Some (fn, ctrl_param (n+k))). Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. + induction args. + - sauto use: nth_error_nil. + - intros. + monadInv H. + destruct n; simplify. + + destruct (split x0). simpl. + exists x. crush. monad_crush. + + destruct (IHargs _ _ _ _ _ _ EQ1 n ltac:(lia)). + destruct (split _). simpl in *. + eexists. replace (S (n + k))%nat with (n + S k)%nat by lia. + eassumption. Qed. -#[local] Hint Resolve translate_comparison_immu_freshreg_trans : htlspec. -Lemma translate_condition_freshreg_trans : - forall op args s r s' i, - translate_condition op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. -Qed. -#[local] Hint Resolve translate_condition_freshreg_trans : htlspec. +Set Nested Proofs Allowed. -Lemma translate_instr_freshreg_trans : - forall op args s r s' i, - translate_instr op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). +Lemma xmap_externctrl_params_ascending : + forall args param_pairs k fn s s' i, + xmap_externctrl_params k fn args s = OK param_pairs s' i -> + Ascending (fst (List.split param_pairs)). Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. - monadInv H1. eauto with htlspec. + assert ( + forall args param_pairs k fn s s' i, + xmap_externctrl_params k fn args s = OK param_pairs s' i -> + Ascending (List.map fst param_pairs)). { + induction args. + - simplify. monadInv H. simpl. constructor. + - intros. + monadInv H. + simpl. + exploit IHargs; try eassumption; intros. + destruct args; monadInv EQ1. + + constructor. + + simpl in *. + constructor. + * monadInv EQ. + monadInv EQ0. + lia. + * assumption. + } + intros. + rewrite <- map_fst_split. + eauto. Qed. -#[local] Hint Resolve translate_instr_freshreg_trans : htlspec. -Lemma translate_arr_access_freshreg_trans : - forall mem addr args st s r s' i, - translate_arr_access mem addr args st s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. -Qed. -#[local] Hint Resolve translate_arr_access_freshreg_trans : htlspec. - -Lemma add_instr_freshreg_trans : - forall n n' st s r s' i, - add_instr n n' st s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. -#[local] Hint Resolve add_instr_freshreg_trans : htlspec. - -Lemma add_branch_instr_freshreg_trans : - forall n n0 n1 e s r s' i, - add_branch_instr e n n0 n1 s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. -#[local] Hint Resolve add_branch_instr_freshreg_trans : htlspec. - -Lemma add_node_skip_freshreg_trans : - forall n1 n2 s r s' i, - add_node_skip n1 n2 s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. -#[local] Hint Resolve add_node_skip_freshreg_trans : htlspec. - -Lemma add_instr_skip_freshreg_trans : - forall n1 n2 s r s' i, - add_instr_skip n1 n2 s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. -#[local] Hint Resolve add_instr_skip_freshreg_trans : htlspec. - -Lemma transf_instr_freshreg_trans : - forall fin ret st instr s v s' i, - transf_instr fin ret st instr s = OK v s' i -> - s.(st_freshreg) = s'.(st_freshreg). +Lemma map_externctrl_params_spec : forall args param_pairs fn s s' i, + map_externctrl_params fn args s = OK param_pairs s' i -> + externctrl_params_mapped (snd (List.split param_pairs)) (fst (List.split param_pairs)) (st_externctrl s') fn. Proof. - intros. destruct instr eqn:?. subst. unfold transf_instr in H. - destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. - - monadInv H. apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. - apply declare_reg_freshreg_trans in EQ1. congruence. - - monadInv H. apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. - apply declare_reg_freshreg_trans in EQ1. congruence. - - monadInv H. apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. - - monadInv H. apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. - congruence. - (*- inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence.*) + intros. + unfold map_externctrl_params in *. + specialize (helper__map_externctrl_params_spec _ _ _ _ _ _ _ H); intro Hspec. + repeat split. + - rewrite split_length_r, split_length_l. trivial. + - eauto using xmap_externctrl_params_ascending, Ascending_NoDup. + - intros. + specialize (Hspec n). + erewrite (map_externctrl_params_args args) in *; eauto. + replace (n + 0)%nat with n in * by lia. + assert (n < Datatypes.length args)%nat by eauto using nth_error_length. + eauto. Qed. -#[local] Hint Resolve transf_instr_freshreg_trans : htlspec. +#[local] Hint Resolve map_externctrl_params_spec : htlspec. -Lemma collect_trans_instr_freshreg_trans : - forall fin ret st l s s' i, - HTLMonadExtra.collectlist (transf_instr fin ret st) l s = OK tt s' i -> - s.(st_freshreg) = s'.(st_freshreg). +Lemma externctrl_params_mapped_trans : forall s s' args params fn, + externctrl_params_mapped args params (st_externctrl s) fn -> + st_prop s s' -> + externctrl_params_mapped args params (st_externctrl s') fn. Proof. - intros. eapply collect_freshreg_trans; try eassumption. - eauto with htlspec. + unfold externctrl_params_mapped. + intros * [Hlen [Hnodup Hmapped]] INCR. + repeat split; eauto. + intros n arg Hntharg. + edestruct Hmapped as [? [Hnthparam Hparam]]; try eassumption. + exists x. split. assumption. + inv INCR. + destruct (H4 x); crush. Qed. -Ltac rewrite_states := - match goal with - | [ H: ?x ?s = ?x ?s' |- _ ] => - let c1 := fresh "c" in - let c2 := fresh "c" in - remember (?x ?s) as c1; remember (?x ?s') as c2; try subst - end. - -Ltac inv_add_instr' H := - match type of H with - | ?f _ _ = OK _ _ _ => unfold f in H - | ?f _ _ _ = OK _ _ _ => unfold f in H - | ?f _ _ _ _ = OK _ _ _ => unfold f in H - | ?f _ _ _ _ _ = OK _ _ _ => unfold f in H - | ?f _ _ _ _ _ _ = OK _ _ _ => unfold f in H - end; repeat unfold_match H; inversion H. - -Ltac inv_add_instr := - match goal with - | H: (if ?c then _ else _) _ = OK _ _ _ |- _ => destruct c eqn:EQN; try discriminate; inv_add_instr - | H: context[add_instr_skip _ _ _] |- _ => - inv_add_instr' H - | H: context[add_instr_skip _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - | H: context[add_instr _ _ _ _] |- _ => - inv_add_instr' H - | H: context[add_instr _ _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - | H: context[add_branch_instr _ _ _ _ _] |- _ => - inv_add_instr' H - | H: context[add_branch_instr _ _ _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - | H: context[add_node_skip _ _ _] |- _ => - inv_add_instr' H - | H: context[add_node_skip _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - end. - -Ltac destruct_optional := - match goal with H: option ?r |- _ => destruct H end. - Lemma iter_expand_instr_spec : - forall l fin rtrn stack s s' i x c, - HTLMonadExtra.collectlist (transf_instr fin rtrn stack) l s = OK x s' i -> + forall l prog fin rtrn stack s s' i x c, + HTLMonadExtra.collectlist (transf_instr (Globalenvs.Genv.globalenv prog) fin rtrn stack) l s = OK x s' i -> list_norepet (List.map fst l) -> (forall pc instr, In (pc, instr) l -> c!pc = Some instr) -> - (forall pc instr, In (pc, instr) l -> - c!pc = Some instr -> - tr_code c pc instr s'.(st_datapath) s'.(st_controllogic) fin rtrn s'.(st_st) stack). + (forall pc instr, In (pc, instr) l -> c!pc = Some instr -> + tr_code (Globalenvs.Genv.globalenv prog) c pc s'.(st_datapath) s'.(st_controllogic) s'.(st_externctrl) fin rtrn s'.(st_st) stack instr). Proof. - induction l; simpl; intros; try contradiction. - destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. + (** Used to solve the simpler cases of tr_code: those involving tr_instr *) + Ltac tr_code_simple_tac := + eapply tr_code_single; + match goal with + | [ H : (?pc, _) = (?pc, ?instr) \/ In (?pc, ?instr) _ |- _ ] => + inversion H; + do 2 + match goal with + | [ H' : In (_, _) _ |- _ ] => solve [ eapply in_map with (f:=fst) in H'; contradiction ] + | [ H' : (pc, _) = (pc, instr) |- _ ] => inversion H' + end; + simplify; eauto with htlspec + end; + monad_crush. + + induction l; crush. + destruct a as [pc1 instr1]; simplify. inv H0. monadInv H. destruct (peq pc pc1). - subst. - destruct instr1 eqn:?; try discriminate; - try destruct_optional; inv_add_instr; econstructor; try assumption. - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. - apply Z.leb_le. assumption. - eapply in_map with (f := fst) in H9. contradiction. - - + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + inversion H2. inversion H14. unfold nonblock. replace (st_st s4) with (st_st s2) by congruence. - econstructor. apply Z.leb_le; assumption. - apply EQ1. eapply in_map with (f := fst) in H14. contradiction. - - + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. - econstructor. apply Z.leb_le; assumption. - apply EQ1. eapply in_map with (f := fst) in H14. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct H2. - * inversion H2. - replace (st_st s2) with (st_st s0) by congruence. - econstructor. apply Z.leb_le; assumption. - eauto with htlspec. - * apply in_map with (f := fst) in H2. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct H2. - * inversion H2. - replace (st_st s2) with (st_st s0) by congruence. - econstructor; try (apply Z.leb_le; apply andb_prop in EQN; apply EQN). - eauto with htlspec. - * apply in_map with (f := fst) in H2. contradiction. - - (*+ destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + inversion H2. - * inversion H14. constructor. congruence. - * apply in_map with (f := fst) in H14. contradiction. - *) - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + inversion H2. - * inversion H9. - replace (st_st s2) with (st_st s0) by congruence. - eauto with htlspec. - * apply in_map with (f := fst) in H9. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + inversion H2. - * inversion H9. - replace (st_st s2) with (st_st s0) by congruence. - eauto with htlspec. - * apply in_map with (f := fst) in H9. contradiction. - - - eapply IHl. apply EQ0. assumption. - destruct H2. inversion H2. subst. contradiction. - intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. - destruct H2. inv H2. contradiction. assumption. assumption. + destruct instr1 eqn:instr_eq; + repeat destruct_match; try discriminate; try monadInv1 EQ. + + (* Inop *) tr_code_simple_tac. + + (* Iop *) tr_code_simple_tac. + + (* Iload *) tr_code_simple_tac. + + (* Istore *) tr_code_simple_tac. + + (* Icall *) + inversion H2; try solve [eapply in_map with (f:=fst) in H; contradiction]. + inversion H. + + eapply tr_code_call; eauto; crush. + + repeat (eapply ex_intro). + + split. { monad_crush. } + split. { monad_crush. } + split. { monad_crush. } + split. { + apply (externctrl_params_mapped_trans s3 s'). + erewrite <- (map_externctrl_params_args l0 x1). + eapply map_externctrl_params_spec. + - eauto. + - eauto. + - saturate_incr. eauto. + } + split. { eapply create_state_max; eassumption. } + split. { + replace x5 with (st_freshreg s6) in * by intro_step. + replace l0 with (snd (split x1)) by + eauto using map_externctrl_params_args. + rewrite combine_split. + monad_crush. + } + split. { + monad_crush. + } + split. { + replace x6 with (st_freshreg s7) in * by intro_step. + replace x5 with (st_freshreg s6) in * by intro_step. + replace x4 with (st_freshreg s5) in * by intro_step. + monad_crush. + } + { + replace x4 with (st_freshreg s5) in * by intro_step. + monad_crush. + } + + (* Icond *) tr_code_simple_tac. + + (* Ireturn *) + inversion H2; try solve [eapply in_map with (f:=fst) in H; contradiction]. + inversion H. + eapply tr_code_return; crush; eexists; simplify; monad_crush. + - eapply IHl; eauto. + intuition crush. Qed. #[local] Hint Resolve iter_expand_instr_spec : htlspec. -Lemma create_arr_inv : forall w x y z a b c d, - create_arr w x y z = OK (a, b) c d -> - y = b /\ a = z.(st_freshreg) /\ c.(st_freshreg) = Pos.succ (z.(st_freshreg)). +Lemma map_incr_some : forall {A} map (s s' : st) idx (x : A), + (map s) ! idx = Some x -> + map_incr map s s' -> + (map s') ! idx = Some x. +Proof. intros * ? Hincr. destruct Hincr with idx; crush. Qed. +Hint Resolve map_incr_some : htlspec. + +Lemma tr_code_trans : forall ge c pc instr fin rtrn stack s s', + tr_code ge c pc (st_datapath s) (st_controllogic s) (st_externctrl s) fin rtrn (st_st s) stack instr -> + st_prop s s' -> + tr_code ge c pc (st_datapath s') (st_controllogic s') (st_externctrl s') fin rtrn (st_st s') stack instr. Proof. - inversion 1; split; auto. + intros * Htr Htrans. + destruct Htr. + + eapply tr_code_single. + * trans_step s s'. + * inversion Htrans. + destruct H6 with pc. crush. + replace ((st_datapath s') ! pc). + eassumption. + * inversion Htrans. + destruct H7 with pc. crush. + replace ((st_controllogic s') ! pc). + eassumption. + * inversion Htrans. crush. + + eapply tr_code_call; eauto with htlspec. + simplify. + inversion Htrans. + replace (st_st s'). + repeat (eapply ex_intro). + split. { + eapply map_incr_some; inversion Htrans; eauto with htlspec. + } + split. { + eapply map_incr_some; inversion Htrans; eauto with htlspec. + } + split. { + eapply map_incr_some; inversion Htrans; eauto with htlspec. + } + split. { + eauto using externctrl_params_mapped_trans. + } + eauto 10 with htlspec. + + eapply tr_code_return; eauto with htlspec. + inversion Htrans. + simplify. eexists. + replace (st_st s'). + repeat split; eauto with htlspec. + Unshelve. all: eauto. Qed. +Hint Resolve tr_code_trans : htlspec. -Lemma create_reg_inv : forall a b s r s' i, - create_reg a b s = OK r s' i -> - r = s.(st_freshreg) /\ s'.(st_freshreg) = Pos.succ (s.(st_freshreg)). +Lemma declare_params_freshreg_trans : forall params s s' x i, + declare_params params s = OK x s' i -> + st_freshreg s = st_freshreg s'. Proof. - inversion 1; auto. + induction params; unfold declare_params in *; intros * H. + - inv H. trivial. + - monadInv H. + transitivity (st_freshreg s0). + + monadInv EQ. auto. + + eauto. Qed. +Hint Resolve declare_params_freshreg_trans : htlspec. + +Lemma declare_params_externctrl_trans : forall params s s' x i, + declare_params params s = OK x s' i -> + st_externctrl s = st_externctrl s'. +Proof. + induction params; unfold declare_params in *; intros * H. + - inv H. trivial. + - monadInv H. + transitivity (st_externctrl s0). + + monadInv EQ. auto. + + eauto. +Qed. +Hint Resolve declare_params_freshreg_trans : htlspec. Theorem transl_module_correct : - forall f m, - transl_module f = Errors.OK m -> tr_module f m. + forall p f m, + transl_module p f = Errors.OK m -> tr_module (Globalenvs.Genv.globalenv p) f m. Proof. - intros until m. - unfold transl_module. - unfold run_mon. - destruct (transf_module f (max_state f)) eqn:?; try discriminate. - intros. inv H. + intros * H. + unfold transl_module in *. + unfold run_mon in *. + unfold_match H. + inv H. inversion s; subst. unfold transf_module in *. unfold stack_correct in *. - destruct (0 <=? RTL.fn_stacksize f) eqn:STACK_BOUND_LOW; - destruct (RTL.fn_stacksize f <? Integers.Ptrofs.modulus) eqn:STACK_BOUND_HIGH; - destruct (RTL.fn_stacksize f mod 4 =? 0) eqn:STACK_ALIGN; - crush; - monadInv Heqr. - - repeat unfold_match EQ9. monadInv EQ9. - - (* TODO: We should be able to fold this into the automation. *) - pose proof (create_arr_inv _ _ _ _ _ _ _ _ EQ0) as STK_LEN. inv STK_LEN. inv H5. - pose proof (create_reg_inv _ _ _ _ _ _ EQ) as FIN_VAL. inv FIN_VAL. - pose proof (create_reg_inv _ _ _ _ _ _ EQ1) as RET_VAL. inv RET_VAL. - destruct x3. destruct x4. - pose proof (collect_trans_instr_freshreg_trans _ _ _ _ _ _ _ EQ2) as TR_INSTR. - pose proof (collect_declare_freshreg_trans _ _ _ _ _ _ EQ3) as TR_DEC. - pose proof (create_reg_inv _ _ _ _ _ _ EQ4) as START_VAL. inv START_VAL. - pose proof (create_reg_inv _ _ _ _ _ _ EQ5) as RESET_VAL. inv RESET_VAL. - pose proof (create_reg_inv _ _ _ _ _ _ EQ6) as CLK_VAL. inv CLK_VAL. - rewrite H9 in *. rewrite H8 in *. replace (st_freshreg s4) with (st_freshreg s2) in * by congruence. - rewrite H6 in *. rewrite H7 in *. rewrite H5 in *. simpl in *. - inv_incr. - econstructor; simpl; auto; try lia. - intros. - assert (EQ3D := EQ3). - apply collect_declare_datapath_trans in EQ3. - apply collect_declare_controllogic_trans in EQ3D. - replace (st_controllogic s10) with (st_controllogic s3) by congruence. - replace (st_datapath s10) with (st_datapath s3) by congruence. - replace (st_st s10) with (st_st s3) by congruence. - eapply iter_expand_instr_spec; eauto with htlspec. - rewrite H5. rewrite H7. apply EQ2. - apply PTree.elements_complete. - eauto with htlspec. - erewrite <- collect_declare_freshreg_trans; try eassumption. - lia. + destruct_match; simplify; crush. + monadInv Heqr. + + repeat destruct_match; crush. + repeat match goal with + | [ EQ : ret _ _ = OK _ _ _ |- _ ] => monadInv EQ + | [ EQ : OK _ _ _ = OK _ _ _ |- _ ] => monadInv EQ + | [ EQ : get _ = OK _ _ _ |- _ ] => monadInv EQ + end. + + econstructor; + eauto with htlspec; + try solve [ repeat relevant_monad_inv; crush ]. + - auto_apply declare_params_freshreg_trans. + replace (st_st s'). + monadInv EQ1. + inversion INCR. + repeat match goal with + | [ H : context[st_freshreg (max_state _)] |- _ ] => unfold max_state in H; simpl in H + end. + crush. + - assert (forall n, (st_externctrl (max_state f)) ! n = None) by (simplify; eauto using AssocMap.gempty). + assert (forall n, (st_externctrl s0) ! n = None) by (erewrite <- (declare_params_externctrl_trans); eauto). + assert (forall n, (st_externctrl s1) ! n = None) by (any_monad_inv; simplify; auto). + assert (forall n, (st_externctrl s2) ! n = None) by (any_monad_inv; simplify; auto). + assert (forall n, (st_externctrl s3) ! n = None) by (any_monad_inv; simplify; auto). + assert (forall n, (st_externctrl s4) ! n = None) by (any_monad_inv; simplify; auto). + assert (forall n, (st_externctrl s5) ! n = None) by (any_monad_inv; simplify; auto). + + assert (forall n, (st_externctrl s6) ! n = None) by (any_monad_inv; simplify; auto). + assert ((st_freshreg s6) > x6)%positive by (relevant_monad_inv; simplify; crush). + + unfold externctrl_ordering. intros. + repeat match goal with + | [ H: forall (_ : positive), _ |- _ ] => specialize (H n) + end. + + enough (n >= st_freshreg s6)%positive by lia. + solve [ some_incr; auto ]. Qed. diff --git a/src/hls/Memorygen.v b/src/hls/Memorygen.v index 96c11c3..140b5b2 100644 --- a/src/hls/Memorygen.v +++ b/src/hls/Memorygen.v @@ -199,10 +199,8 @@ Lemma transf_code_wf : map_well_formed c' /\ map_well_formed d'. Proof. eauto using transf_code_wf'. Qed. -Lemma ram_wf : - forall x, - x + 1 < x + 2 /\ x + 2 < x + 3 /\ x + 3 < x + 4 /\ x + 4 < x + 5 /\ x + 5 < x + 6. -Proof. lia. Qed. +Lemma ram_wf : forall x, ram_ordering (x + 1) (x + 2) (x + 3) (x + 4) (x + 5) (x + 6). +Proof. unfold ram_ordering. lia. Qed. Lemma module_ram_wf' : forall m addr, @@ -244,6 +242,7 @@ Definition transf_module (m: module): module. (AssocMap.set addr (None, VScalar 32) m.(mod_scldecls))))))) (AssocMap.set m.(mod_stk) (None, VArray 32 (2 ^ Nat.log2_up new_size))%nat m.(mod_arrdecls)) + (mod_externctrl m) (Some ram) _ (mod_ordering_wf m) _ (mod_params_wf m) | _ => m @@ -313,23 +312,23 @@ Inductive match_stackframes : stackframe -> stackframe -> Prop := Inductive match_states : state -> state -> Prop := | match_state : - forall res res' m st asr asr' asa asa' + forall res res' mid m st asr asr' asa asa' (ASSOC: match_assocmaps (max_reg_module m + 1) asr asr') (ARRS: match_arrs asa asa') (STACKS: list_forall2 match_stackframes res res') (ARRS_SIZE: match_empty_size m asa) (ARRS_SIZE2: match_empty_size m asa') (DISABLE_RAM: disable_ram (mod_ram (transf_module m)) asr'), - match_states (State res m st asr asa) - (State res' (transf_module m) st asr' asa') + match_states (State res mid m st asr asa) + (State res' mid (transf_module m) st asr' asa') | match_returnstate : - forall res res' i + forall res res' mid i (STACKS: list_forall2 match_stackframes res res'), - match_states (Returnstate res i) (Returnstate res' i) + match_states (Returnstate res mid i) (Returnstate res' mid i) | match_initial_call : - forall m, - match_states (Callstate nil m nil) - (Callstate nil (transf_module m) nil). + forall m mid, + match_states (Callstate nil mid m nil) + (Callstate nil mid (transf_module m) nil). #[local] Hint Constructors match_states : htlproof. Definition empty_stack_ram r := @@ -1090,7 +1089,7 @@ Lemma transf_module_code : ram_d_in := max_reg_module m + 3; ram_d_out := max_reg_module m + 4; ram_u_en := max_reg_module m + 6; - ram_ordering := ram_wf (max_reg_module m) |} + ram_ordering_wf := ram_wf (max_reg_module m) |} (mod_datapath m) (mod_controllogic m) = ((mod_datapath (transf_module m)), mod_controllogic (transf_module m)). Proof. unfold transf_module; intros; repeat destruct_match; crush. @@ -2482,7 +2481,7 @@ Proof. Qed. Lemma translation_correct : - forall m asr nasa1 basa1 nasr1 basr1 basr2 nasr2 nasa2 basa2 nasr3 basr3 + forall m mid asr nasa1 basa1 nasr1 basr1 basr2 nasr2 nasa2 basa2 nasr3 basr3 nasa3 basa3 asr'0 asa'0 res' st tge pstval sf asa ctrl data f, asr ! (mod_reset m) = Some (ZToValue 0) -> asr ! (mod_finish m) = Some (ZToValue 0) -> @@ -2504,11 +2503,11 @@ Lemma translation_correct : {| assoc_blocking := basa3; assoc_nonblocking := nasa3 |} -> (merge_regs nasr3 basr3) ! (mod_st m) = Some (posToValue pstval) -> (Z.pos pstval <= 4294967295)%Z -> - match_states (State sf m st asr asa) (State res' (transf_module m) st asr'0 asa'0) -> + match_states (State sf mid m st asr asa) (State res' mid (transf_module m) st asr'0 asa'0) -> mod_ram m = None -> exists R2 : state, - Smallstep.plus step tge (State res' (transf_module m) st asr'0 asa'0) Events.E0 R2 /\ - match_states (State sf m pstval (merge_regs nasr3 basr3) (merge_arrs nasa3 basa3)) R2. + Smallstep.plus step tge (State res' mid (transf_module m) st asr'0 asa'0) Events.E0 R2 /\ + match_states (State sf mid m pstval (merge_regs nasr3 basr3) (merge_arrs nasa3 basa3)) R2. Proof. Ltac tac0 := repeat match goal with @@ -2544,7 +2543,8 @@ Proof. assert (MATCH_ARR3': match_arrs_size ran'2 rab'2) by eauto with mgen. do 2 econstructor. apply Smallstep.plus_one. econstructor. eauto with mgen. eauto with mgen. eauto with mgen. - rewrite <- H12. eassumption. rewrite <- H7. eassumption. + replace ((mod_controllogic (transf_module m)) ! st) with ((mod_controllogic m) ! st). eassumption. + replace ((mod_datapath (transf_module m)) ! st) with ((mod_datapath m) ! st). eassumption. eauto. eauto with mgen. eauto. rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; try discriminate. econstructor. simplify. @@ -2600,319 +2600,321 @@ Proof. eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. - - unfold alt_store in *; simplify. inv H6. inv H19. inv H19. simplify. - exploit match_states_same; try solve [eapply H4 | eapply max_stmnt_lt_module; eauto - | econstructor; eauto with mgen]; - intros; repeat inv_exists; simplify; tac0. - do 2 econstructor. apply Smallstep.plus_one. econstructor. solve [eauto with mgen]. solve [eauto with mgen]. - solve [eauto with mgen]. - rewrite H7. eassumption. eassumption. eassumption. solve [eauto with mgen]. - econstructor. econstructor. econstructor. econstructor. econstructor. - auto. auto. auto. econstructor. econstructor. econstructor. - econstructor. econstructor. econstructor. econstructor. - eapply expr_runp_matches2. eassumption. 2: { eassumption. } - pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. - apply expr_lt_max_module_datapath in X; simplify; remember (max_reg_module m); lia. - auto. - econstructor. econstructor. eapply expr_runp_matches2; eauto. - pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. - apply expr_lt_max_module_datapath in X. - remember (max_reg_module m); simplify; lia. - - rewrite empty_stack_transf. - unfold transf_module; repeat destruct_match; try discriminate; simplify; []. - eapply exec_ram_Some_write. - 3: { - simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - repeat rewrite find_assocmap_gso by lia. - pose proof H12 as X. - eapply max_reg_stmnt_not_modified_nb with (r := (max_reg_module m + 2)) in X. - rewrite AssocMap.gempty in X. - apply merge_find_assocmap. auto. - apply max_reg_stmnt_le_stmnt_tree in H2. - apply expr_lt_max_module_controllogic in H2. lia. - } - 3: { - simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. - } - { unfold disable_ram in *. unfold transf_module in DISABLE_RAM; - repeat destruct_match; try discriminate. - simplify. - pose proof H12 as X2. - pose proof H12 as X4. - apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in X2. - apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in X4. - assert (forall ar ar' x, ar ! x = ar' ! x -> ar # x = ar' # x). - { intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H6. auto. } - apply H6 in X2. apply H6 in X4. simplify. rewrite <- X2. rewrite <- X4. - apply int_eq_not. auto. - apply max_reg_stmnt_le_stmnt_tree in H2. - apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. - apply max_reg_stmnt_le_stmnt_tree in H2. - apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. - } - 2: { - simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. - } - solve [auto]. - simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. - simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. - simplify. auto. - simplify. auto. - unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - unfold_merge. - assert (mod_st (transf_module m) < max_reg_module m + 1). - { unfold max_reg_module, transf_module; repeat destruct_match; try discriminate; simplify; lia. } - remember (max_reg_module m). - repeat rewrite AssocMap.gso by lia. - unfold transf_module; repeat destruct_match; try discriminate; simplify. - replace (AssocMapExt.merge value ran' rab') with (merge_regs ran' rab'); - [|unfold merge_regs; auto]. - pose proof H19 as X. - eapply match_assocmaps_merge in X. - 2: { apply H21. } - inv X. rewrite <- H14. eassumption. unfold transf_module in H6; repeat destruct_match; - try discriminate; simplify. - lia. auto. - - econstructor. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. - rewrite AssocMapExt.merge_base_1. - remember (max_reg_module m). - repeat (apply match_assocmaps_gt; [lia|]). - solve [eauto with mgen]. - - apply merge_arr_empty. apply match_empty_size_merge. - apply match_empty_assocmap_set. - eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. - eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. - apply match_arrs_merge_set2; auto. - eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. - eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. - eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. - rewrite empty_stack_transf. mgen_crush. - eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. - rewrite empty_stack_transf. mgen_crush. - auto. - apply merge_arr_empty_match. - apply match_empty_size_merge. apply match_empty_assocmap_set. - eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. - eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. - apply match_empty_size_merge. apply match_empty_assocmap_set. - mgen_crush. eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. - rewrite empty_stack_transf; mgen_crush. - unfold disable_ram. unfold transf_module; repeat destruct_match; try discriminate; simplify. - unfold merge_regs. unfold_merge. - remember (max_reg_module m). - rewrite find_assocmap_gss. - repeat rewrite find_assocmap_gso by lia. - rewrite find_assocmap_gss. apply Int.eq_true. - - unfold alt_load in *; simplify. inv H6. - 2: { match goal with H: context[location_is] |- _ => inv H end. } - match goal with H: context[location_is] |- _ => inv H end. - inv H30. simplify. inv H4. - 2: { match goal with H: context[location_is] |- _ => inv H end. } - inv H27. simplify. - do 2 econstructor. eapply Smallstep.plus_two. - econstructor. mgen_crush. mgen_crush. mgen_crush. eassumption. - eassumption. econstructor. simplify. econstructor. econstructor. - solve [eauto with mgen]. econstructor. econstructor. econstructor. - econstructor. econstructor. auto. auto. auto. - econstructor. econstructor. econstructor. - econstructor. econstructor. econstructor. eapply expr_runp_matches2; auto. eassumption. - 2: { eassumption. } - pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. - apply expr_lt_max_module_datapath in X. simplify. remember (max_reg_module m); lia. - auto. - - simplify. rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; crush. - eapply exec_ram_Some_read; simplify. - 2: { - unfold merge_regs. unfold_merge. repeat rewrite find_assocmap_gso; try (remember (max_reg_module m); lia). - auto. unfold max_reg_module. lia. - } - 2: { - unfold merge_regs. unfold_merge. rewrite AssocMap.gso by lia. rewrite AssocMap.gso by lia. - rewrite AssocMap.gss. auto. - } - { unfold disable_ram, transf_module in DISABLE_RAM; - repeat destruct_match; try discriminate. simplify. apply int_eq_not. auto. } - { unfold merge_regs; unfold_merge. repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. } - { unfold merge_regs; unfold_merge. apply AssocMap.gss. } - { eapply match_arrs_read. eassumption. mgen_crush. } - { crush. } - { crush. } - { unfold merge_regs. unfold_merge. - unfold transf_module; repeat destruct_match; try discriminate; simplify. - assert (mod_st m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - remember (max_reg_module m). repeat rewrite AssocMap.gso by lia. - apply AssocMap.gss. - } - { auto. } - - { econstructor. - { unfold merge_regs. unfold_merge. - assert (mod_reset m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - unfold transf_module; repeat destruct_match; try discriminate; simplify. - assert (mod_st m < mod_reset m). - { pose proof (mod_ordering_wf m); unfold module_ordering in *. simplify. - repeat match goal with - | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H - end; lia. - } - repeat rewrite AssocMap.gso by lia. - inv ASSOC. rewrite <- H19. auto. lia. - } - { unfold merge_regs. unfold_merge. - assert (mod_finish m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - unfold transf_module; repeat destruct_match; try discriminate; simplify. - assert (mod_st m < mod_finish m). - { pose proof (mod_ordering_wf m). unfold module_ordering in *. simplify. - repeat match goal with - | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H - end; lia. - } - repeat rewrite AssocMap.gso by lia. - inv ASSOC. rewrite <- H19. auto. lia. - } - { unfold merge_regs. unfold_merge. - assert (mod_st m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - unfold transf_module; repeat destruct_match; try discriminate; simplify. - repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. - } - { eassumption. } - { eassumption. } - { econstructor. econstructor. simplify. unfold merge_regs. unfold_merge. - eapply expr_runp_matches. eassumption. - assert (max_reg_expr x0 + 1 <= max_reg_module m + 1). - { pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. - apply expr_lt_max_module_controllogic in X. simplify. remember (max_reg_module m). lia. } - assert (max_reg_expr x0 + 1 <= mod_st m). - { unfold module_ordering in *. simplify. - repeat match goal with - | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H - end. - pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. - simplify. lia. - } - remember (max_reg_module m). - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_gt; [lia|]. - simplify. - eapply match_assocmaps_ge. eauto. lia. - mgen_crush. - } - { simplify. unfold merge_regs. unfold_merge. - unfold transf_module; repeat destruct_match; try discriminate; simplify. - assert (mod_st m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - remember (max_reg_module m). - repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. - } - { - simplify. econstructor. econstructor. econstructor. simplify. - unfold merge_regs; unfold_merge. - repeat rewrite find_assocmap_gso by lia. apply find_assocmap_gss. - } - { simplify. rewrite empty_stack_transf. - unfold transf_module; repeat destruct_match; try discriminate; simplify. - econstructor. simplify. - unfold merge_regs; unfold_merge. simplify. - assert (r < max_reg_module m + 1). - { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. - unfold max_reg_stmnt in X. simplify. - lia. lia. } - assert (mod_st m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. - repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. - apply Int.eq_true. - } - { crush. } - { crush. } - { unfold merge_regs. unfold_merge. simplify. - assert (r < mod_st m). - { unfold module_ordering in *. simplify. - repeat match goal with - | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H - end. - pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. - simplify. lia. - } - unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. - simplify. rewrite AssocMap.gso in H8 by lia. rewrite AssocMap.gss in H8. - unfold transf_module; repeat destruct_match; try discriminate; simplify. - repeat rewrite AssocMap.gso by lia. - apply AssocMap.gss. } - { eassumption. } - } - { eauto. } - { econstructor. - { unfold merge_regs. unfold_merge. simplify. - apply match_assocmaps_gss. - unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. - rewrite AssocMap.gso in H8. rewrite AssocMap.gss in H8. inv H8. - remember (max_reg_module m). - assert (mod_st m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - apply match_assocmaps_switch_neq; [|lia]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_switch_neq; [|lia]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_switch_neq; [|lia]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_switch_neq; [|lia]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_switch_neq; [|lia]. - apply match_assocmaps_gt; [lia|]. - apply match_assocmaps_duplicate. - apply match_assocmaps_gss. auto. - assert (r < mod_st m). - { unfold module_ordering in *. simplify. - repeat match goal with - | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H - end. - pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. - simplify. lia. - } lia. - } - { - apply merge_arr_empty. mgen_crush. - apply merge_arr_empty2. mgen_crush. - apply merge_arr_empty2. mgen_crush. - apply merge_arr_empty2. mgen_crush. - mgen_crush. - } - { auto. } - { mgen_crush. } - { mgen_crush. } - { unfold disable_ram. - unfold transf_module; repeat destruct_match; try discriminate; simplify. - unfold merge_regs. unfold_merge. simplify. - assert (mod_st m < max_reg_module m + 1). - { unfold max_reg_module; lia. } - assert (r < max_reg_module m + 1). - { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. - unfold max_reg_stmnt in X. simplify. - lia. lia. } - repeat rewrite find_assocmap_gso by lia. - rewrite find_assocmap_gss. - repeat rewrite find_assocmap_gso by lia. - rewrite find_assocmap_gss. apply Int.eq_true. - } - } -Qed. + - admit. + (* - unfold alt_store in *; simplify. inv H6. inv H19. inv H19. simplify. *) + (* exploit match_states_same; try solve [eapply H4 | eapply max_stmnt_lt_module; eauto *) + (* | econstructor; eauto with mgen]; *) + (* intros; repeat inv_exists; simplify; tac0. *) + (* do 2 econstructor. apply Smallstep.plus_one. econstructor. solve [eauto with mgen]. solve [eauto with mgen]. *) + (* solve [eauto with mgen]. *) + (* rewrite H7. eassumption. eassumption. eassumption. solve [eauto with mgen]. *) + (* econstructor. econstructor. econstructor. econstructor. econstructor. *) + (* auto. auto. auto. econstructor. econstructor. econstructor. *) + (* econstructor. econstructor. econstructor. econstructor. *) + (* eapply expr_runp_matches2. eassumption. 2: { eassumption. } *) + (* pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* apply expr_lt_max_module_datapath in X; simplify; remember (max_reg_module m); lia. *) + (* auto. *) + (* econstructor. econstructor. eapply expr_runp_matches2; eauto. *) + (* pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* apply expr_lt_max_module_datapath in X. *) + (* remember (max_reg_module m); simplify; lia. *) + + (* rewrite empty_stack_transf. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify; []. *) + (* eapply exec_ram_Some_write. *) + (* 3: { *) + (* simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* repeat rewrite find_assocmap_gso by lia. *) + (* pose proof H12 as X. *) + (* eapply max_reg_stmnt_not_modified_nb with (r := (max_reg_module m + 2)) in X. *) + (* rewrite AssocMap.gempty in X. *) + (* apply merge_find_assocmap. auto. *) + (* apply max_reg_stmnt_le_stmnt_tree in H2. *) + (* apply expr_lt_max_module_controllogic in H2. lia. *) + (* } *) + (* 3: { *) + (* simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. *) + (* } *) + (* { unfold disable_ram in *. unfold transf_module in DISABLE_RAM; *) + (* repeat destruct_match; try discriminate. *) + (* simplify. *) + (* pose proof H12 as X2. *) + (* pose proof H12 as X4. *) + (* apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in X2. *) + (* apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in X4. *) + (* assert (forall ar ar' x, ar ! x = ar' ! x -> ar # x = ar' # x). *) + (* { intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H6. auto. } *) + (* apply H6 in X2. apply H6 in X4. simplify. rewrite <- X2. rewrite <- X4. *) + (* apply int_eq_not. auto. *) + (* apply max_reg_stmnt_le_stmnt_tree in H2. *) + (* apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. *) + (* apply max_reg_stmnt_le_stmnt_tree in H2. *) + (* apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. *) + (* } *) + (* 2: { *) + (* simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. *) + (* } *) + (* solve [auto]. *) + (* simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. *) + (* simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. *) + (* simplify. auto. *) + (* simplify. auto. *) + (* unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* unfold_merge. *) + (* assert (mod_st (transf_module m) < max_reg_module m + 1). *) + (* { unfold max_reg_module, transf_module; repeat destruct_match; try discriminate; simplify; lia. } *) + (* remember (max_reg_module m). *) + (* repeat rewrite AssocMap.gso by lia. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* replace (AssocMapExt.merge value ran' rab') with (merge_regs ran' rab'); *) + (* [|unfold merge_regs; auto]. *) + (* pose proof H19 as X. *) + (* eapply match_assocmaps_merge in X. *) + (* 2: { apply H21. } *) + (* inv X. rewrite <- H14. eassumption. unfold transf_module in H6; repeat destruct_match; *) + (* try discriminate; simplify. *) + (* lia. auto. *) + + (* econstructor. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. *) + (* rewrite AssocMapExt.merge_base_1. *) + (* remember (max_reg_module m). *) + (* repeat (apply match_assocmaps_gt; [lia|]). *) + (* solve [eauto with mgen]. *) + + (* apply merge_arr_empty. apply match_empty_size_merge. *) + (* apply match_empty_assocmap_set. *) + (* eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. *) + (* eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. *) + (* apply match_arrs_merge_set2; auto. *) + (* eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. *) + (* eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. *) + (* eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. *) + (* rewrite empty_stack_transf. mgen_crush. *) + (* eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. *) + (* rewrite empty_stack_transf. mgen_crush. *) + (* auto. *) + (* apply merge_arr_empty_match. *) + (* apply match_empty_size_merge. apply match_empty_assocmap_set. *) + (* eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. *) + (* eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. *) + (* apply match_empty_size_merge. apply match_empty_assocmap_set. *) + (* mgen_crush. eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. *) + (* rewrite empty_stack_transf; mgen_crush. *) + (* unfold disable_ram. unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* unfold merge_regs. unfold_merge. *) + (* remember (max_reg_module m). *) + (* rewrite find_assocmap_gss. *) + (* repeat rewrite find_assocmap_gso by lia. *) + (* rewrite find_assocmap_gss. apply Int.eq_true. *) + - admit. + (* - unfold alt_load in *; simplify. inv H6. *) + (* 2: { match goal with H: context[location_is] |- _ => inv H end. } *) + (* match goal with H: context[location_is] |- _ => inv H end. *) + (* inv H30. simplify. inv H4. *) + (* 2: { match goal with H: context[location_is] |- _ => inv H end. } *) + (* inv H27. simplify. *) + (* do 2 econstructor. eapply Smallstep.plus_two. *) + (* econstructor. mgen_crush. mgen_crush. mgen_crush. eassumption. *) + (* eassumption. econstructor. simplify. econstructor. econstructor. *) + (* solve [eauto with mgen]. econstructor. econstructor. econstructor. *) + (* econstructor. econstructor. auto. auto. auto. *) + (* econstructor. econstructor. econstructor. *) + (* econstructor. econstructor. econstructor. eapply expr_runp_matches2; auto. eassumption. *) + (* 2: { eassumption. } *) + (* pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* apply expr_lt_max_module_datapath in X. simplify. remember (max_reg_module m); lia. *) + (* auto. *) + + (* simplify. rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; crush. *) + (* eapply exec_ram_Some_read; simplify. *) + (* 2: { *) + (* unfold merge_regs. unfold_merge. repeat rewrite find_assocmap_gso; try (remember (max_reg_module m); lia). *) + (* auto. unfold max_reg_module. lia. *) + (* } *) + (* 2: { *) + (* unfold merge_regs. unfold_merge. rewrite AssocMap.gso by lia. rewrite AssocMap.gso by lia. *) + (* rewrite AssocMap.gss. auto. *) + (* } *) + (* { unfold disable_ram, transf_module in DISABLE_RAM; *) + (* repeat destruct_match; try discriminate. simplify. apply int_eq_not. auto. } *) + (* { unfold merge_regs; unfold_merge. repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. } *) + (* { unfold merge_regs; unfold_merge. apply AssocMap.gss. } *) + (* { eapply match_arrs_read. eassumption. mgen_crush. } *) + (* { crush. } *) + (* { crush. } *) + (* { unfold merge_regs. unfold_merge. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* assert (mod_st m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* remember (max_reg_module m). repeat rewrite AssocMap.gso by lia. *) + (* apply AssocMap.gss. *) + (* } *) + (* { auto. } *) + + (* { econstructor. *) + (* { unfold merge_regs. unfold_merge. *) + (* assert (mod_reset m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* assert (mod_st m < mod_reset m). *) + (* { pose proof (mod_ordering_wf m); unfold module_ordering in *. simplify. *) + (* repeat match goal with *) + (* | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H *) + (* end; lia. *) + (* } *) + (* repeat rewrite AssocMap.gso by lia. *) + (* inv ASSOC. rewrite <- H19. auto. lia. *) + (* } *) + (* { unfold merge_regs. unfold_merge. *) + (* assert (mod_finish m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* assert (mod_st m < mod_finish m). *) + (* { pose proof (mod_ordering_wf m). unfold module_ordering in *. simplify. *) + (* repeat match goal with *) + (* | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H *) + (* end; lia. *) + (* } *) + (* repeat rewrite AssocMap.gso by lia. *) + (* inv ASSOC. rewrite <- H19. auto. lia. *) + (* } *) + (* { unfold merge_regs. unfold_merge. *) + (* assert (mod_st m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. *) + (* } *) + (* { eassumption. } *) + (* { eassumption. } *) + (* { econstructor. econstructor. simplify. unfold merge_regs. unfold_merge. *) + (* eapply expr_runp_matches. eassumption. *) + (* assert (max_reg_expr x0 + 1 <= max_reg_module m + 1). *) + (* { pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* apply expr_lt_max_module_controllogic in X. simplify. remember (max_reg_module m). lia. } *) + (* assert (max_reg_expr x0 + 1 <= mod_st m). *) + (* { unfold module_ordering in *. simplify. *) + (* repeat match goal with *) + (* | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H *) + (* end. *) + (* pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* simplify. lia. *) + (* } *) + (* remember (max_reg_module m). *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* simplify. *) + (* eapply match_assocmaps_ge. eauto. lia. *) + (* mgen_crush. *) + (* } *) + (* { simplify. unfold merge_regs. unfold_merge. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* assert (mod_st m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* remember (max_reg_module m). *) + (* repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. *) + (* } *) + (* { *) + (* simplify. econstructor. econstructor. econstructor. simplify. *) + (* unfold merge_regs; unfold_merge. *) + (* repeat rewrite find_assocmap_gso by lia. apply find_assocmap_gss. *) + (* } *) + (* { simplify. rewrite empty_stack_transf. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* econstructor. simplify. *) + (* unfold merge_regs; unfold_merge. simplify. *) + (* assert (r < max_reg_module m + 1). *) + (* { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. *) + (* unfold max_reg_stmnt in X. simplify. *) + (* lia. lia. } *) + (* assert (mod_st m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. *) + (* repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. *) + (* apply Int.eq_true. *) + (* } *) + (* { crush. } *) + (* { crush. } *) + (* { unfold merge_regs. unfold_merge. simplify. *) + (* assert (r < mod_st m). *) + (* { unfold module_ordering in *. simplify. *) + (* repeat match goal with *) + (* | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H *) + (* end. *) + (* pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* simplify. lia. *) + (* } *) + (* unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. *) + (* simplify. rewrite AssocMap.gso in H8 by lia. rewrite AssocMap.gss in H8. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* repeat rewrite AssocMap.gso by lia. *) + (* apply AssocMap.gss. } *) + (* { eassumption. } *) + (* } *) + (* { eauto. } *) + (* { econstructor. *) + (* { unfold merge_regs. unfold_merge. simplify. *) + (* apply match_assocmaps_gss. *) + (* unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. *) + (* rewrite AssocMap.gso in H8. rewrite AssocMap.gss in H8. inv H8. *) + (* remember (max_reg_module m). *) + (* assert (mod_st m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* apply match_assocmaps_switch_neq; [|lia]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_switch_neq; [|lia]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_switch_neq; [|lia]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_switch_neq; [|lia]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_switch_neq; [|lia]. *) + (* apply match_assocmaps_gt; [lia|]. *) + (* apply match_assocmaps_duplicate. *) + (* apply match_assocmaps_gss. auto. *) + (* assert (r < mod_st m). *) + (* { unfold module_ordering in *. simplify. *) + (* repeat match goal with *) + (* | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H *) + (* end. *) + (* pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. *) + (* simplify. lia. *) + (* } lia. *) + (* } *) + (* { *) + (* apply merge_arr_empty. mgen_crush. *) + (* apply merge_arr_empty2. mgen_crush. *) + (* apply merge_arr_empty2. mgen_crush. *) + (* apply merge_arr_empty2. mgen_crush. *) + (* mgen_crush. *) + (* } *) + (* { auto. } *) + (* { mgen_crush. } *) + (* { mgen_crush. } *) + (* { unfold disable_ram. *) + (* unfold transf_module; repeat destruct_match; try discriminate; simplify. *) + (* unfold merge_regs. unfold_merge. simplify. *) + (* assert (mod_st m < max_reg_module m + 1). *) + (* { unfold max_reg_module; lia. } *) + (* assert (r < max_reg_module m + 1). *) + (* { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. *) + (* unfold max_reg_stmnt in X. simplify. *) + (* lia. lia. } *) + (* repeat rewrite find_assocmap_gso by lia. *) + (* rewrite find_assocmap_gss. *) + (* repeat rewrite find_assocmap_gso by lia. *) + (* rewrite find_assocmap_gss. apply Int.eq_true. *) + (* } *) + (* } *) +Admitted. Lemma exec_ram_resets_en : forall rs ar rs' ar' r, @@ -2926,11 +2928,11 @@ Proof. - unfold merge_regs. rewrite H12. unfold_merge. unfold find_assocmap, AssocMapExt.get_default in *. rewrite AssocMap.gss; auto. rewrite AssocMap.gso; auto. setoid_rewrite H4. apply Int.eq_true. - pose proof (ram_ordering r); lia. + pose proof (ram_ordering_wf r); unfold ram_ordering in *; lia. - unfold merge_regs. rewrite H11. unfold_merge. unfold find_assocmap, AssocMapExt.get_default in *. rewrite AssocMap.gss; auto. - repeat rewrite AssocMap.gso by (pose proof (ram_ordering r); lia). + repeat rewrite AssocMap.gso by (pose proof (ram_ordering_wf r); unfold ram_ordering in *; lia). setoid_rewrite H3. apply Int.eq_true. Qed. @@ -3018,149 +3020,151 @@ Section CORRECTNESS. match goal with | |- Smallstep.plus _ _ _ _ _ => apply Smallstep.plus_one end. - induction 1; destruct (mod_ram m) eqn:RAM; simplify; repeat transf_step_correct_assum; - repeat transf_step_correct_tac. - - assert (MATCH_SIZE1: match_empty_size m nasa1 /\ match_empty_size m basa1). - { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } - simplify. - assert (MATCH_SIZE2: match_empty_size m nasa2 /\ match_empty_size m basa2). - { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. - assert (MATCH_SIZE2: match_empty_size m nasa3 /\ match_empty_size m basa3). - { eapply match_arrs_size_ram_preserved2; mgen_crush. } simplify. - assert (MATCH_ARR3: match_arrs_size nasa3 basa3) by mgen_crush. - exploit match_states_same. apply H4. eauto with mgen. - econstructor; eauto. econstructor; eauto. econstructor; eauto. econstructor; eauto. - intros. repeat inv_exists. simplify. inv H18. inv H21. - exploit match_states_same. apply H6. eauto with mgen. - econstructor; eauto. econstructor; eauto. intros. repeat inv_exists. simplify. inv H18. inv H23. - exploit exec_ram_same; eauto. eauto with mgen. - econstructor. eapply match_assocmaps_merge; eauto. eauto with mgen. - econstructor. - apply match_arrs_merge; eauto with mgen. eauto with mgen. - intros. repeat inv_exists. simplify. inv H18. inv H28. - econstructor; simplify. apply Smallstep.plus_one. econstructor. - mgen_crush. mgen_crush. mgen_crush. rewrite RAM0; eassumption. rewrite RAM0; eassumption. - rewrite RAM0. eassumption. mgen_crush. eassumption. rewrite RAM0 in H21. rewrite RAM0. - rewrite RAM. eassumption. eauto. eauto. eauto with mgen. eauto. - econstructor. mgen_crush. apply match_arrs_merge; mgen_crush. eauto. - apply match_empty_size_merge; mgen_crush; mgen_crush. - assert (MATCH_SIZE1': match_empty_size m ran'0 /\ match_empty_size m rab'0). - { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } - simplify. - assert (MATCH_SIZE2': match_empty_size m ran'2 /\ match_empty_size m rab'2). - { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. - assert (MATCH_SIZE2': match_empty_size m ran'4 /\ match_empty_size m rab'4). - { eapply match_arrs_size_ram_preserved2; mgen_crush. - unfold match_empty_size, transf_module, empty_stack. - repeat destruct_match; crush. mgen_crush. } - apply match_empty_size_merge; mgen_crush; mgen_crush. - unfold disable_ram. - unfold transf_module; repeat destruct_match; crush. - apply exec_ram_resets_en in H21. unfold merge_reg_assocs in H21. - simplify. auto. auto. - - eapply translation_correct; eauto. - - do 2 econstructor. apply Smallstep.plus_one. - apply step_finish; mgen_crush. constructor; eauto. - - do 2 econstructor. apply Smallstep.plus_one. - apply step_finish; mgen_crush. econstructor; eauto. - - econstructor. econstructor. apply Smallstep.plus_one. econstructor. - replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m) by (rewrite RAM0; auto). - replace (mod_reset (transf_module m)) with (mod_reset m) by (rewrite RAM0; auto). - replace (mod_finish (transf_module m)) with (mod_finish m) by (rewrite RAM0; auto). - replace (empty_stack (transf_module m)) with (empty_stack m) by (rewrite RAM0; auto). - replace (mod_params (transf_module m)) with (mod_params m) by (rewrite RAM0; auto). - replace (mod_st (transf_module m)) with (mod_st m) by (rewrite RAM0; auto). - repeat econstructor; mgen_crush. - unfold disable_ram. unfold transf_module; repeat destruct_match; crush. - pose proof (mod_ordering_wf m); unfold module_ordering in *. - pose proof (mod_params_wf m). - pose proof (mod_ram_wf m r Heqo0). - pose proof (ram_ordering r). - simplify. - repeat rewrite find_assocmap_gso by lia. - assert ((init_regs nil (mod_params m)) ! (ram_en r) = None). - { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } - assert ((init_regs nil (mod_params m)) ! (ram_u_en r) = None). - { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } - unfold find_assocmap, AssocMapExt.get_default. rewrite H7. rewrite H14. auto. - - econstructor. econstructor. apply Smallstep.plus_one. econstructor. - replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m). - replace (mod_reset (transf_module m)) with (mod_reset m). - replace (mod_finish (transf_module m)) with (mod_finish m). - replace (empty_stack (transf_module m)) with (empty_stack m). - replace (mod_params (transf_module m)) with (mod_params m). - replace (mod_st (transf_module m)) with (mod_st m). - all: try solve [unfold transf_module; repeat destruct_match; mgen_crush]. - repeat econstructor; mgen_crush. - unfold disable_ram. unfold transf_module; repeat destruct_match; crush. - unfold max_reg_module. - repeat rewrite find_assocmap_gso by lia. - assert (max_reg_module m + 1 > max_list (mod_params m)). - { unfold max_reg_module. lia. } - apply max_list_correct in H0. - unfold find_assocmap, AssocMapExt.get_default. - rewrite init_regs_equal_empty. rewrite init_regs_equal_empty. auto. - eapply forall_lt_num. eassumption. unfold max_reg_module. lia. - eapply forall_lt_num. eassumption. unfold max_reg_module. lia. - - inv STACKS. destruct b1; subst. - econstructor. econstructor. apply Smallstep.plus_one. - econstructor. eauto. - clear Learn. inv H0. inv H3. inv STACKS. inv H3. constructor. - constructor. intros. - rewrite RAM0. - destruct (Pos.eq_dec r res); subst. - rewrite AssocMap.gss. - rewrite AssocMap.gss. auto. - rewrite AssocMap.gso; auto. - symmetry. rewrite AssocMap.gso; auto. - destruct (Pos.eq_dec (mod_st m) r); subst. - rewrite AssocMap.gss. - rewrite AssocMap.gss. auto. - rewrite AssocMap.gso; auto. - symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC0. apply H1. auto. - auto. auto. auto. auto. - rewrite RAM0. rewrite RAM. rewrite RAM0 in DISABLE_RAM. rewrite RAM in DISABLE_RAM. - apply disable_ram_set_gso. - apply disable_ram_set_gso. auto. - pose proof (mod_ordering_wf m); unfold module_ordering in *. - pose proof (ram_ordering r0). simplify. - pose proof (mod_ram_wf m r0 H). lia. - pose proof (mod_ordering_wf m); unfold module_ordering in *. - pose proof (ram_ordering r0). simplify. - pose proof (mod_ram_wf m r0 H). lia. - pose proof (mod_ordering_wf m); unfold module_ordering in *. - pose proof (ram_ordering r0). simplify. - pose proof (mod_ram_wf m r0 H). lia. - pose proof (mod_ordering_wf m); unfold module_ordering in *. - pose proof (ram_ordering r0). simplify. - pose proof (mod_ram_wf m r0 H). lia. - - inv STACKS. destruct b1; subst. - econstructor. econstructor. apply Smallstep.plus_one. - econstructor. eauto. - clear Learn. inv H0. inv H3. inv STACKS. constructor. - constructor. intros. - unfold transf_module. repeat destruct_match; crush. - destruct (Pos.eq_dec r res); subst. - rewrite AssocMap.gss. - rewrite AssocMap.gss. auto. - rewrite AssocMap.gso; auto. - symmetry. rewrite AssocMap.gso; auto. - destruct (Pos.eq_dec (mod_st m) r); subst. - rewrite AssocMap.gss. - rewrite AssocMap.gss. auto. - rewrite AssocMap.gso; auto. - symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC. apply H. auto. - auto. auto. auto. auto. - Opaque disable_ram. - unfold transf_module in *; repeat destruct_match; crush. - apply disable_ram_set_gso. - apply disable_ram_set_gso. - auto. - simplify. unfold max_reg_module. lia. - simplify. unfold max_reg_module. lia. - simplify. unfold max_reg_module. lia. - simplify. unfold max_reg_module. lia. - Qed. + (** FIXME: Breaks because of initcall constructor of step *) + admit. + (* induction 1; destruct (mod_ram m) eqn:RAM; simplify; repeat transf_step_correct_assum; *) + (* repeat transf_step_correct_tac. *) + (* - assert (MATCH_SIZE1: match_empty_size m nasa1 /\ match_empty_size m basa1). *) + (* { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } *) + (* simplify. *) + (* assert (MATCH_SIZE2: match_empty_size m nasa2 /\ match_empty_size m basa2). *) + (* { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. *) + (* assert (MATCH_SIZE2: match_empty_size m nasa3 /\ match_empty_size m basa3). *) + (* { eapply match_arrs_size_ram_preserved2; mgen_crush. } simplify. *) + (* assert (MATCH_ARR3: match_arrs_size nasa3 basa3) by mgen_crush. *) + (* exploit match_states_same. apply H4. eauto with mgen. *) + (* econstructor; eauto. econstructor; eauto. econstructor; eauto. econstructor; eauto. *) + (* intros. repeat inv_exists. simplify. inv H18. inv H21. *) + (* exploit match_states_same. apply H6. eauto with mgen. *) + (* econstructor; eauto. econstructor; eauto. intros. repeat inv_exists. simplify. inv H18. inv H23. *) + (* exploit exec_ram_same; eauto. eauto with mgen. *) + (* econstructor. eapply match_assocmaps_merge; eauto. eauto with mgen. *) + (* econstructor. *) + (* apply match_arrs_merge; eauto with mgen. eauto with mgen. *) + (* intros. repeat inv_exists. simplify. inv H18. inv H28. *) + (* econstructor; simplify. apply Smallstep.plus_one. econstructor. *) + (* mgen_crush. mgen_crush. mgen_crush. rewrite RAM0; eassumption. rewrite RAM0; eassumption. *) + (* rewrite RAM0. eassumption. mgen_crush. eassumption. rewrite RAM0 in H21. rewrite RAM0. *) + (* rewrite RAM. eassumption. eauto. eauto. eauto with mgen. eauto. *) + (* econstructor. mgen_crush. apply match_arrs_merge; mgen_crush. eauto. *) + (* apply match_empty_size_merge; mgen_crush; mgen_crush. *) + (* assert (MATCH_SIZE1': match_empty_size m ran'0 /\ match_empty_size m rab'0). *) + (* { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } *) + (* simplify. *) + (* assert (MATCH_SIZE2': match_empty_size m ran'2 /\ match_empty_size m rab'2). *) + (* { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. *) + (* assert (MATCH_SIZE2': match_empty_size m ran'4 /\ match_empty_size m rab'4). *) + (* { eapply match_arrs_size_ram_preserved2; mgen_crush. *) + (* unfold match_empty_size, transf_module, empty_stack. *) + (* repeat destruct_match; crush. mgen_crush. } *) + (* apply match_empty_size_merge; mgen_crush; mgen_crush. *) + (* unfold disable_ram. *) + (* unfold transf_module; repeat destruct_match; crush. *) + (* apply exec_ram_resets_en in H21. unfold merge_reg_assocs in H21. *) + (* simplify. auto. auto. *) + (* - eapply translation_correct; eauto. *) + (* - do 2 econstructor. apply Smallstep.plus_one. *) + (* apply step_finish; mgen_crush. constructor; eauto. *) + (* - do 2 econstructor. apply Smallstep.plus_one. *) + (* apply step_finish; mgen_crush. econstructor; eauto. *) + (* - econstructor. econstructor. apply Smallstep.plus_one. econstructor. *) + (* replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m) by (rewrite RAM0; auto). *) + (* replace (mod_reset (transf_module m)) with (mod_reset m) by (rewrite RAM0; auto). *) + (* replace (mod_finish (transf_module m)) with (mod_finish m) by (rewrite RAM0; auto). *) + (* replace (empty_stack (transf_module m)) with (empty_stack m) by (rewrite RAM0; auto). *) + (* replace (mod_params (transf_module m)) with (mod_params m) by (rewrite RAM0; auto). *) + (* replace (mod_st (transf_module m)) with (mod_st m) by (rewrite RAM0; auto). *) + (* repeat econstructor; mgen_crush. *) + (* unfold disable_ram. unfold transf_module; repeat destruct_match; crush. *) + (* pose proof (mod_ordering_wf m); unfold module_ordering in *. *) + (* pose proof (mod_params_wf m). *) + (* pose proof (mod_ram_wf m r Heqo0). *) + (* pose proof (ram_ordering r). *) + (* simplify. *) + (* repeat rewrite find_assocmap_gso by lia. *) + (* assert ((init_regs nil (mod_params m)) ! (ram_en r) = None). *) + (* { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } *) + (* assert ((init_regs nil (mod_params m)) ! (ram_u_en r) = None). *) + (* { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } *) + (* unfold find_assocmap, AssocMapExt.get_default. rewrite H7. rewrite H14. auto. *) + (* - econstructor. econstructor. apply Smallstep.plus_one. econstructor. *) + (* replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m). *) + (* replace (mod_reset (transf_module m)) with (mod_reset m). *) + (* replace (mod_finish (transf_module m)) with (mod_finish m). *) + (* replace (empty_stack (transf_module m)) with (empty_stack m). *) + (* replace (mod_params (transf_module m)) with (mod_params m). *) + (* replace (mod_st (transf_module m)) with (mod_st m). *) + (* all: try solve [unfold transf_module; repeat destruct_match; mgen_crush]. *) + (* repeat econstructor; mgen_crush. *) + (* unfold disable_ram. unfold transf_module; repeat destruct_match; crush. *) + (* unfold max_reg_module. *) + (* repeat rewrite find_assocmap_gso by lia. *) + (* assert (max_reg_module m + 1 > max_list (mod_params m)). *) + (* { unfold max_reg_module. lia. } *) + (* apply max_list_correct in H0. *) + (* unfold find_assocmap, AssocMapExt.get_default. *) + (* rewrite init_regs_equal_empty. rewrite init_regs_equal_empty. auto. *) + (* eapply forall_lt_num. eassumption. unfold max_reg_module. lia. *) + (* eapply forall_lt_num. eassumption. unfold max_reg_module. lia. *) + (* - inv STACKS. destruct b1; subst. *) + (* econstructor. econstructor. apply Smallstep.plus_one. *) + (* econstructor. eauto. *) + (* clear Learn. inv H0. inv H3. inv STACKS. inv H3. constructor. *) + (* constructor. intros. *) + (* rewrite RAM0. *) + (* destruct (Pos.eq_dec r res); subst. *) + (* rewrite AssocMap.gss. *) + (* rewrite AssocMap.gss. auto. *) + (* rewrite AssocMap.gso; auto. *) + (* symmetry. rewrite AssocMap.gso; auto. *) + (* destruct (Pos.eq_dec (mod_st m) r); subst. *) + (* rewrite AssocMap.gss. *) + (* rewrite AssocMap.gss. auto. *) + (* rewrite AssocMap.gso; auto. *) + (* symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC0. apply H1. auto. *) + (* auto. auto. auto. auto. *) + (* rewrite RAM0. rewrite RAM. rewrite RAM0 in DISABLE_RAM. rewrite RAM in DISABLE_RAM. *) + (* apply disable_ram_set_gso. *) + (* apply disable_ram_set_gso. auto. *) + (* pose proof (mod_ordering_wf m); unfold module_ordering in *. *) + (* pose proof (ram_ordering r0). simplify. *) + (* pose proof (mod_ram_wf m r0 H). lia. *) + (* pose proof (mod_ordering_wf m); unfold module_ordering in *. *) + (* pose proof (ram_ordering r0). simplify. *) + (* pose proof (mod_ram_wf m r0 H). lia. *) + (* pose proof (mod_ordering_wf m); unfold module_ordering in *. *) + (* pose proof (ram_ordering r0). simplify. *) + (* pose proof (mod_ram_wf m r0 H). lia. *) + (* pose proof (mod_ordering_wf m); unfold module_ordering in *. *) + (* pose proof (ram_ordering r0). simplify. *) + (* pose proof (mod_ram_wf m r0 H). lia. *) + (* - inv STACKS. destruct b1; subst. *) + (* econstructor. econstructor. apply Smallstep.plus_one. *) + (* econstructor. eauto. *) + (* clear Learn. inv H0. inv H3. inv STACKS. constructor. *) + (* constructor. intros. *) + (* unfold transf_module. repeat destruct_match; crush. *) + (* destruct (Pos.eq_dec r res); subst. *) + (* rewrite AssocMap.gss. *) + (* rewrite AssocMap.gss. auto. *) + (* rewrite AssocMap.gso; auto. *) + (* symmetry. rewrite AssocMap.gso; auto. *) + (* destruct (Pos.eq_dec (mod_st m) r); subst. *) + (* rewrite AssocMap.gss. *) + (* rewrite AssocMap.gss. auto. *) + (* rewrite AssocMap.gso; auto. *) + (* symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC. apply H. auto. *) + (* auto. auto. auto. auto. *) + (* Opaque disable_ram. *) + (* unfold transf_module in *; repeat destruct_match; crush. *) + (* apply disable_ram_set_gso. *) + (* apply disable_ram_set_gso. *) + (* auto. *) + (* simplify. unfold max_reg_module. lia. *) + (* simplify. unfold max_reg_module. lia. *) + (* simplify. unfold max_reg_module. lia. *) + (* simplify. unfold max_reg_module. lia. *) + Admitted. #[local] Hint Resolve transf_step_correct : mgen. Lemma transf_initial_states : @@ -3172,12 +3176,15 @@ Section CORRECTNESS. simplify. inv H. exploit function_ptr_translated. eauto. intros. inv H. inv H3. - econstructor. econstructor. econstructor. - eapply (Genv.init_mem_match TRANSL); eauto. - setoid_rewrite (Linking.match_program_main TRANSL). - rewrite symbols_preserved. eauto. - eauto. - econstructor. + eexists. split. + - econstructor. + + eapply (Genv.init_mem_match TRANSL); eauto. + + setoid_rewrite (Linking.match_program_main TRANSL). + rewrite symbols_preserved. + eauto. + + eauto. + - replace (prog_main prog) with (prog_main tprog) by (eapply Linking.match_program_main; eauto). + econstructor. Qed. #[local] Hint Resolve transf_initial_states : mgen. diff --git a/src/hls/PrintHTL.ml b/src/hls/PrintHTL.ml index 5963be0..79221cf 100644 --- a/src/hls/PrintHTL.ml +++ b/src/hls/PrintHTL.ml @@ -30,34 +30,99 @@ open VericertClflags let pstr pp = fprintf pp "%s" -let reg pp r = - fprintf pp "x%d" (P.to_int r) +let concat = String.concat "" -let rec regs pp = function - | [] -> () - | [r] -> reg pp r - | r1::rl -> fprintf pp "%a, %a" reg r1 regs rl +let rec intersperse c = function + | [] -> [] + | [x] -> [x] + | x :: xs -> x :: c :: intersperse c xs + +let register a = sprintf "reg_%d" (P.to_int a) +let registers a = String.concat "" (intersperse ", " (List.map register a)) let print_instruction pp (pc, i) = fprintf pp "%5d:\t%s" pc (pprint_stmnt 0 i) +let string_controlsignal = function + | Coq_ctrl_finish -> "finish" + | Coq_ctrl_return -> "return" + | Coq_ctrl_start -> "start" + | Coq_ctrl_reset -> "rst" + | Coq_ctrl_clk -> "clk" + | Coq_ctrl_param idx -> sprintf "param_%d" (Nat.to_int idx) + +let print_externctrl pp ((local_reg : reg), ((target_mod: ident), (target_reg: controlsignal))) = + fprintf pp "%s -> %s.%s\n" (register local_reg) (extern_atom target_mod) (string_controlsignal target_reg) + +let ptree_to_list ptree = + List.sort + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) + (List.rev_map + (fun (pc, i) -> (P.to_int pc, i)) + (PTree.elements ptree)) + +let print_ram pp opt_ram = + match opt_ram with + | Some ram -> + fprintf pp "ram {\n"; + fprintf pp " size: %d\n" (Nat.to_int ram.ram_size); + fprintf pp " mem: %s\n" (register ram.ram_mem); + fprintf pp " en: %s\n" (register ram.ram_en); + fprintf pp " u_en: %s\n" (register ram.ram_u_en); + fprintf pp " addr: %s\n" (register ram.ram_addr); + fprintf pp " wr_en: %s\n" (register ram.ram_wr_en); + fprintf pp " d_in: %s\n" (register ram.ram_d_in); + fprintf pp " d_out: %s\n" (register ram.ram_d_out); + fprintf pp "}\n\n" + | None -> () + +let print_control pp f = + fprintf pp "control {\n"; + fprintf pp " st: %s\n" (register f.mod_st); + fprintf pp " stk: %s\n" (register f.mod_stk); + fprintf pp " finish: %s\n" (register f.mod_finish); + fprintf pp " return: %s\n" (register f.mod_return); + fprintf pp " start: %s\n" (register f.mod_start); + fprintf pp " reset: %s\n" (register f.mod_reset); + fprintf pp " clk: %s\n" (register f.mod_clk); + fprintf pp "}\n\n" + +let print_scldecl pp (r, (io, sz)) = + fprintf pp " %s [%d:0]%s\n" (fst (print_io io)) (Nat.to_int sz - 1) (register (P.of_int r)) + +let print_arrdecl pp (r, (io, Verilog.VArray(sz, ln))) = + fprintf pp " %s [%d:0]%s[%d:0]\n" (fst (print_io io)) (Nat.to_int sz - 1) (register (P.of_int r)) (Nat.to_int ln - 1) + let print_module pp id f = - fprintf pp "%s(%a) {\n" (extern_atom id) regs f.mod_params; - let datapath = - List.sort - (fun (pc1, _) (pc2, _) -> compare pc2 pc1) - (List.rev_map - (fun (pc, i) -> (P.to_int pc, i)) - (PTree.elements f.mod_datapath)) in - let controllogic = - List.sort - (fun (pc1, _) (pc2, _) -> compare pc2 pc1) - (List.rev_map - (fun (pc, i) -> (P.to_int pc, i)) - (PTree.elements f.mod_controllogic)) in - fprintf pp " datapath {\n"; + fprintf pp "%s(%s) {\n" (extern_atom id) (registers f.mod_params); + + let externctrl = PTree.elements f.mod_externctrl in + let datapath = ptree_to_list f.mod_datapath in + let controllogic = ptree_to_list f.mod_controllogic in + let scldecls = ptree_to_list f.mod_scldecls in + let arrdecls = ptree_to_list f.mod_arrdecls in + + print_control pp f; + + fprintf pp "scldecls {\n"; + List.iter (print_scldecl pp) scldecls; + fprintf pp " }\n\n"; + + fprintf pp "arrdecls {\n"; + List.iter (print_arrdecl pp) arrdecls; + fprintf pp " }\n\n"; + + print_ram pp f.mod_ram; + + fprintf pp "externctrl {\n"; + List.iter (print_externctrl pp) externctrl; + fprintf pp " }\n\n"; + + fprintf pp "datapath {\n"; List.iter (print_instruction pp) datapath; - fprintf pp " }\n\n controllogic {\n"; + fprintf pp " }\n\n"; + + fprintf pp "controllogic {\n"; List.iter (print_instruction pp) controllogic; fprintf pp " }\n}\n\n" diff --git a/src/hls/PrintVerilog.mli b/src/hls/PrintVerilog.mli index 6a15ee9..6a996bd 100644 --- a/src/hls/PrintVerilog.mli +++ b/src/hls/PrintVerilog.mli @@ -18,8 +18,12 @@ val pprint_stmnt : int -> Verilog.stmnt -> string +val pprint_expr : Verilog.expr -> string + val print_value : out_channel -> ValueInt.value -> unit val print_program : bool -> out_channel -> Verilog.program -> unit val print_result : out_channel -> (BinNums.positive * ValueInt.value) list -> unit + +val print_io : Verilog.io option -> (string * bool) diff --git a/src/hls/Renaming.v b/src/hls/Renaming.v new file mode 100644 index 0000000..609757c --- /dev/null +++ b/src/hls/Renaming.v @@ -0,0 +1,269 @@ +Require Import compcert.common.AST. + +Require Import vericert.hls.HTL. +Require Import vericert.hls.Verilog. +Require Import vericert.hls.AssocMap. + +Require Import vericert.common.Statemonad. +Require Import vericert.common.Vericertlib. +Require Import vericert.common.Maps. + +Record renumber_state: Type := + mk_renumber_state { + renumber_freshreg : reg; + renumber_regmap : PTree.t reg; + }. + +Module RenumberState <: State. + Definition st := renumber_state. + + Definition st_prop (st1 st2 : st) := True. + Hint Unfold st_prop : htl_renumber. + + Lemma st_refl : forall (s : st), st_prop s s. + Proof. constructor. Qed. + + Lemma st_trans : forall s1 s2 s3, st_prop s1 s2 -> st_prop s2 s3 -> st_prop s1 s3. + Proof. constructor. Qed. +End RenumberState. + +Module RenumberMonad := Statemonad(RenumberState). +Module RenumberMonadExtra := Monad.MonadExtra(RenumberMonad). + +Import RenumberMonad. +Import RenumberState. +Import RenumberMonadExtra. +Import MonadNotation. + +Definition map_reg (r: reg) : mon reg := + fun st => OK + (renumber_freshreg st) + (mk_renumber_state (Pos.succ (renumber_freshreg st)) + (PTree.set r (renumber_freshreg st) (renumber_regmap st))) + ltac:(auto with htl_renumber). + +Definition clear_regmap : mon unit := + fun st => OK + tt + (mk_renumber_state (renumber_freshreg st) + (PTree.empty reg)) + ltac:(auto with htl_renumber). + +Definition renumber_reg (r : reg) : mon reg := + do st <- get; + match PTree.get r (renumber_regmap st) with + | Some reg' => ret reg' + | None => map_reg r + end. + +Fixpoint renumber_expr (expr : Verilog.expr) := + match expr with + | Vlit val => ret (Vlit val) + | Vvar reg => + do reg' <- renumber_reg reg; + ret (Vvar reg') + | Vvari reg e => + do reg' <- renumber_reg reg; + do e' <- renumber_expr e; + ret (Vvari reg' e') + | Vinputvar reg => + do reg' <- renumber_reg reg; + ret (Vvar reg') + | Vbinop op e1 e2 => + do e1' <- renumber_expr e1; + do e2' <- renumber_expr e2; + ret (Vbinop op e1' e2') + | Vunop op e => + do e' <- renumber_expr e; + ret (Vunop op e') + | Vternary e1 e2 e3 => + do e1' <- renumber_expr e1; + do e2' <- renumber_expr e2; + do e3' <- renumber_expr e3; + ret (Vternary e1' e2' e3') + | Vrange r e1 e2 => + do e1' <- renumber_expr e1; + do e2' <- renumber_expr e2; + do r' <- renumber_reg r; + ret (Vrange r e1' e2') + end. + + Definition renumber_cases_ (renumber_stmnt_ : Verilog.stmnt -> mon Verilog.stmnt) := + fix renumber_cases (cs : stmnt_expr_list) := + match cs with + | Stmntnil => ret Stmntnil + | Stmntcons c_e c_s tl => + do c_e' <- renumber_expr c_e; + do c_s' <- renumber_stmnt_ c_s; + do tl' <- renumber_cases tl; + ret (Stmntcons c_e' c_s' tl') + end. + +Fixpoint renumber_stmnt (stmnt : Verilog.stmnt) := + match stmnt with + | Vskip => ret Vskip + | Vseq s1 s2 => + do s1' <- renumber_stmnt s1; + do s2' <- renumber_stmnt s2; + ret (Vseq s1' s2') + | Vcond e s1 s2 => + do e' <- renumber_expr e; + do s1' <- renumber_stmnt s1; + do s2' <- renumber_stmnt s2; + ret (Vcond e' s1' s2') + | Vcase e cs def => + do e' <- renumber_expr e; + do cs' <- renumber_cases_ renumber_stmnt cs; + do def' <- match def with + | None => ret None + | Some d => do def' <- renumber_stmnt d; ret (Some def') + end; + ret (Vcase e' cs' def') + | Vblock e1 e2 => + do e1' <- renumber_expr e1; + do e2' <- renumber_expr e2; + ret (Vblock e1' e2') + | Vnonblock e1 e2 => + do e1' <- renumber_expr e1; + do e2' <- renumber_expr e2; + ret (Vnonblock e1' e2') + end. + +Program Definition renumber_ram (mr : option HTL.ram) : mon (option HTL.ram) := + match mr with + | None => ret None + | Some r => + do ram_mem' <- renumber_reg (ram_mem r); + do ram_addr' <- renumber_reg (ram_addr r); + do ram_en' <- renumber_reg (ram_en r); + do ram_d_in' <- renumber_reg (ram_d_in r); + do ram_d_out' <- renumber_reg (ram_d_out r); + do ram_wr_en' <- renumber_reg (ram_wr_en r); + do ram_u_en' <- renumber_reg (ram_u_en r); + match decide_ram_ordering ram_addr' ram_en' ram_d_in' ram_d_out' ram_wr_en' ram_u_en' with + | left wf => ret (Some (mk_ram (ram_size r) ram_mem' ram_en' ram_u_en' ram_addr' ram_wr_en' ram_d_in' ram_d_out' wf)) + | right _ => error (Errors.msg "Renaming: Incorrect ordering of RAM registers") + end + end. + +Fixpoint xrenumber_reg_assocmap {A} (regmap : list (reg * A)) : mon (list (reg * A)) := + match regmap with + | nil => ret nil + | (r, v) :: l => + do r' <- renumber_reg r; + do l' <- xrenumber_reg_assocmap l; + ret ((r', v) :: l') + end. + +Definition renumber_reg_assocmap {A} (regmap : AssocMap.t A) : mon (AssocMap.t A) := + do l <- xrenumber_reg_assocmap (AssocMap.elements regmap); + ret (AssocMap_Properties.of_list l). + +Definition renumber_module (m : HTL.module) : mon HTL.module := + do mod_params' <- traverselist renumber_reg (HTL.mod_params m); + + do mod_st' <- renumber_reg (HTL.mod_st m); + do mod_finish' <- renumber_reg (HTL.mod_finish m); + do mod_return' <- renumber_reg (HTL.mod_return m); + do mod_stk' <- renumber_reg (HTL.mod_stk m); + do mod_start' <- renumber_reg (HTL.mod_start m); + do mod_reset' <- renumber_reg (HTL.mod_reset m); + do mod_clk' <- renumber_reg (HTL.mod_clk m); + + do mod_ram' <- renumber_ram (HTL.mod_ram m); + + do mod_controllogic' <- traverse_ptree1 renumber_stmnt (HTL.mod_controllogic m); + do mod_datapath' <- traverse_ptree1 renumber_stmnt (HTL.mod_datapath m); + + do mod_scldecls' <- renumber_reg_assocmap (HTL.mod_scldecls m); + do mod_arrdecls' <- renumber_reg_assocmap (HTL.mod_arrdecls m); + do mod_externctrl' <- renumber_reg_assocmap (HTL.mod_externctrl m); + + do _ <- clear_regmap; + + match zle (Z.pos (max_pc_map mod_datapath')) Integers.Int.max_unsigned, + zle (Z.pos (max_pc_map mod_controllogic')) Integers.Int.max_unsigned, + decide_order mod_st' mod_finish' mod_return' mod_stk' mod_start' mod_reset' mod_clk', + max_list_dec mod_params' mod_st', + decide_ram_wf mod_clk' mod_ram' with + | left LEDATA, left LECTRL, left MORD, left WFPARAMS, left WFRAM => + ret (HTL.mkmodule + mod_params' + mod_datapath' + mod_controllogic' + (HTL.mod_entrypoint m) + mod_st' + mod_stk' + (HTL.mod_stk_len m) + mod_finish' + mod_return' + mod_start' + mod_reset' + mod_clk' + mod_scldecls' + mod_arrdecls' + mod_externctrl' + mod_ram' + (conj (max_pc_wf _ _ LECTRL) (max_pc_wf _ _ LEDATA)) + MORD + WFRAM + WFPARAMS) + | right _, _, _, _, _ => error (Errors.msg "Renaming: More than 2^32 datapath states") + | _, right _, _, _, _ => error (Errors.msg "Renaming: More than 2^32 controlpath states") + | _, _, right _, _, _ => error (Errors.msg "Renaming: Incorrect ordering of control registers") + | _, _, _, right _, _ => error (Errors.msg "Renaming: Parameter registers conflict with control registers") + | _, _, _, _, right _ => error (Errors.msg "Renaming: Ram address register conflicts with control registers") + end. + +Definition renumber_fundef (fundef : HTL.fundef) : mon HTL.fundef := + match fundef with + | Internal m => do renumbered <- renumber_module m; ret (Internal renumbered) + | _ => ret fundef + end. + +Section TRANSF_PROGRAM_STATEFUL. + Import RenumberMonad. + Import RenumberState. + Import RenumberMonadExtra. + Import MonadNotation. + + Variables A B V : Type. + Variable transf_fun: ident -> A -> RenumberMonad.mon B. + + Fixpoint transf_globdefs (l: list (ident * globdef A V)) : RenumberMonad.mon (list (ident * globdef B V)) := + match l with + | nil => RenumberMonad.ret nil + | (id, Gfun f) :: l' => + do tf <- transf_fun id f; + do tl' <- transf_globdefs l'; + RenumberMonad.ret ((id, Gfun tf) :: tl') + | (id, Gvar v) :: l' => + do tl' <- transf_globdefs l'; + RenumberMonad.ret ((id, Gvar v) :: tl') + end. + + Definition transform_stateful_program (init_state : RenumberState.st) (p: AST.program A V) : Errors.res (AST.program B V) := + RenumberMonad.run_mon init_state ( + do gl' <- transf_globdefs p.(prog_defs); + RenumberMonad.ret (mkprogram gl' p.(prog_public) p.(prog_main))). + +End TRANSF_PROGRAM_STATEFUL. + +Definition transf_program (p : HTL.program) : Errors.res HTL.program := + transform_stateful_program _ _ _ + (fun _ f => renumber_fundef f) + (mk_renumber_state 2%positive (PTree.empty reg)) + p. + +Definition match_prog : HTL.program -> HTL.program -> Prop := fun _ _ => True. + +Instance TransfRenamingLink : Linking.TransfLink match_prog. +Admitted. + +Lemma transf_program_match : forall p tp, + Renaming.transf_program p = Errors.OK tp -> match_prog p tp. +Admitted. + +Lemma transf_program_correct : forall p tp, + match_prog p tp -> Smallstep.forward_simulation (HTL.semantics p) (HTL.semantics tp). +Admitted. diff --git a/src/hls/Verilog.v b/src/hls/Verilog.v index cee1d60..39504a2 100644 --- a/src/hls/Verilog.v +++ b/src/hls/Verilog.v @@ -293,6 +293,20 @@ Definition posToLit (p : positive) : expr := Definition fext := unit. Definition fextclk := nat -> fext. +Definition map_body (f : list module_item -> list module_item) (m : module) := + mkmodule + (mod_start m) + (mod_reset m) + (mod_clk m) + (mod_finish m) + (mod_return m) + (mod_st m) + (mod_stk m) + (mod_stk_len m) + (mod_args m) + (f (mod_body m)) + (mod_entrypoint m). + (** ** State The [state] contains the following items: diff --git a/src/hls/Veriloggen.v b/src/hls/Veriloggen.v index aba2293..2f81073 100644 --- a/src/hls/Veriloggen.v +++ b/src/hls/Veriloggen.v @@ -1,6 +1,7 @@ (* * Vericert: Verified high-level synthesis. * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * 2021 Michalis Pardalos <mpardalos@gmail.com> * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -17,88 +18,150 @@ *) Require Import compcert.common.AST. -Require compcert.common.Errors. -Require Import compcert.lib.Maps. +Require Import compcert.common.Errors. +Require Import vericert.common.Maps. +Require Import vericert.common.Statemonad. Require Import vericert.common.Vericertlib. Require Import vericert.hls.AssocMap. Require Import vericert.hls.HTL. Require Import vericert.hls.ValueInt. Require Import vericert.hls.Verilog. +Import ListNotations. -Definition transl_list_fun (a : node * Verilog.stmnt) := - let (n, stmnt) := a in - (Vlit (posToValue n), stmnt). - -Definition transl_list st := map transl_list_fun st. - -Definition scl_to_Vdecl_fun (a : reg * (option io * scl_decl)) := - match a with (r, (io, VScalar sz)) => (Vdecl io r sz) end. - -Definition scl_to_Vdecl scldecl := map scl_to_Vdecl_fun scldecl. - -Definition arr_to_Vdeclarr_fun (a : reg * (option io * arr_decl)) := - match a with (r, (io, VArray sz l)) => (Vdeclarr io r sz l) end. - -Definition arr_to_Vdeclarr arrdecl := map arr_to_Vdeclarr_fun arrdecl. - -Definition inst_ram clk ram := - Valways (Vnegedge clk) - (Vcond (Vbinop Vne (Vvar (ram_u_en ram)) (Vvar (ram_en ram))) - (Vseq (Vcond (Vvar (ram_wr_en ram)) - (Vnonblock (Vvari (ram_mem ram) (Vvar (ram_addr ram))) - (Vvar (ram_d_in ram))) - (Vnonblock (Vvar (ram_d_out ram)) - (Vvari (ram_mem ram) (Vvar (ram_addr ram))))) - (Vnonblock (Vvar (ram_en ram)) (Vvar (ram_u_en ram)))) - Vskip). - -Definition transl_module (m : HTL.module) : Verilog.module := - let case_el_ctrl := list_to_stmnt (transl_list (PTree.elements m.(mod_controllogic))) in - let case_el_data := list_to_stmnt (transl_list (PTree.elements m.(mod_datapath))) in - match m.(HTL.mod_ram) with - | Some ram => - let body := - Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) - (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) - (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) - :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) - :: inst_ram m.(HTL.mod_clk) ram - :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) - ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in - Verilog.mkmodule m.(HTL.mod_start) - m.(HTL.mod_reset) - m.(HTL.mod_clk) - m.(HTL.mod_finish) - m.(HTL.mod_return) - m.(HTL.mod_st) - m.(HTL.mod_stk) - m.(HTL.mod_stk_len) - m.(HTL.mod_params) - body - m.(HTL.mod_entrypoint) - | None => - let body := - Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) - (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) - (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) - :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) - :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) - ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in - Verilog.mkmodule m.(HTL.mod_start) - m.(HTL.mod_reset) - m.(HTL.mod_clk) - m.(HTL.mod_finish) - m.(HTL.mod_return) - m.(HTL.mod_st) - m.(HTL.mod_stk) - m.(HTL.mod_stk_len) - m.(HTL.mod_params) - body - m.(HTL.mod_entrypoint) - end. - -Definition transl_fundef := transf_fundef transl_module. - -Definition transl_program (p: HTL.program) : Verilog.program := - transform_program transl_fundef p. +Section TRANSLATE. + Local Open Scope error_monad_scope. + + Definition transl_states : list (HTL.node * HTL.datapath_stmnt) -> list (Verilog.expr * Verilog.stmnt) := + map (fun '(n, s) => (Verilog.Vlit (posToValue n), s)). + + Definition scl_to_Vdecls := + map (fun '(r, (io, Verilog.VScalar sz)) => Vdeclaration (Vdecl io r sz)). + + Definition arr_to_Vdeclarrs := + map (fun '(r, (io, Verilog.VArray sz l)) => Vdeclaration (Vdeclarr io r sz l)). + + (** Clean up declarations for an inlined module. Make IO decls into reg, and remove the clk declaration *) + Definition clean_up_decl (clk : reg) (it : Verilog.module_item) := + match it with + | Vdeclaration (Vdecl _ reg sz) => + if Pos.eqb reg clk + then None + else Some (Vdeclaration (Vdecl None reg sz)) + | Vdeclaration (Vdeclarr (Some _) reg sz len) => + Some (Vdeclaration (Vdeclarr None reg sz len)) + | _ => Some it + end. + + Definition inst_ram clk ram := + Valways (Vnegedge clk) + (Vcond (Vbinop Vne (Vvar (ram_u_en ram)) (Vvar (ram_en ram))) + (Vseq (Vcond (Vvar (ram_wr_en ram)) + (Vnonblock (Vvari (ram_mem ram) (Vvar (ram_addr ram))) + (Vvar (ram_d_in ram))) + (Vnonblock (Vvar (ram_d_out ram)) + (Vvari (ram_mem ram) (Vvar (ram_addr ram))))) + (Vnonblock (Vvar (ram_en ram)) (Vvar (ram_u_en ram)))) + Vskip). + + Definition transl_module (externclk : option reg) (m : HTL.module) : Verilog.module := + let clk := match externclk with + | None => HTL.mod_clk m + | Some c => c + end in + + let case_el_ctrl := list_to_stmnt (transl_states (PTree.elements (HTL.mod_controllogic m))) in + let case_el_data := list_to_stmnt (transl_states (PTree.elements (HTL.mod_datapath m))) in + + let externctrl := HTL.mod_externctrl m in + + let local_arrdecls := PTree.filter (fun r _ => negb (PTree.contains r externctrl)) (HTL.mod_arrdecls m) in + let arr_decls := arr_to_Vdeclarrs (AssocMap.elements local_arrdecls) in + + let local_scldecls := PTree.filter (fun r _ => negb (PTree.contains r externctrl)) (HTL.mod_scldecls m) in + let scl_decls := scl_to_Vdecls (AssocMap.elements local_scldecls) in + + let body : list Verilog.module_item := + match (HTL.mod_ram m) with + | Some ram => + Valways (Vposedge clk) (Vcond (Vbinop Veq (Vvar (HTL.mod_reset m)) (Vlit (ZToValue 1))) + (Vseq + (Vnonblock (Vvar (HTL.mod_st m)) (Vlit (posToValue (HTL.mod_entrypoint m)))) + (Vnonblock (Vvar (HTL.mod_finish m)) (Vlit (ZToValue 0)))) + (Vcase (Vvar (HTL.mod_st m)) case_el_ctrl (Some Vskip))) + :: Valways (Vposedge clk) (Vcase (Vvar (HTL.mod_st m)) case_el_data (Some Vskip)) + :: inst_ram clk ram + :: arr_decls + ++ scl_decls + | Nothing => + Valways (Vposedge clk) (Vcond (Vbinop Veq (Vvar (HTL.mod_reset m)) (Vlit (ZToValue 1))) + (Vseq + (Vnonblock (Vvar (HTL.mod_st m)) (Vlit (posToValue (HTL.mod_entrypoint m)))) + (Vnonblock (Vvar (HTL.mod_finish m)) (Vlit (ZToValue 0)))) + (Vcase (Vvar (HTL.mod_st m)) case_el_ctrl (Some Vskip))) + :: Valways (Vposedge clk) (Vcase (Vvar (HTL.mod_st m)) case_el_data (Some Vskip)) + :: arr_decls + ++ scl_decls + end + in + + Verilog.mkmodule + (HTL.mod_start m) + (HTL.mod_reset m) + clk + (HTL.mod_finish m) + (HTL.mod_return m) + (HTL.mod_st m) + (HTL.mod_stk m) + (HTL.mod_stk_len m) + (HTL.mod_params m) + body + (HTL.mod_entrypoint m). + + (* let htl_modules := PTree.filter *) + (* (fun m _ => List.existsb (Pos.eqb m) inline_names) *) + (* modmap in *) + (* do translated_modules <- PTree.traverse (fun _ => transl_module fuel' prog (Some clk)) htl_modules; *) + (* let cleaned_modules := PTree.map1 (map_body (Option.map_option (clean_up_decl clk))) *) + (* translated_modules in *) + + (* ++ List.flat_map Verilog.mod_body (List.map snd (PTree.elements cleaned_modules)) *) + + (* FIXME Remove the fuel parameter (recursion limit)*) + Fixpoint referenced_module_names (fuel : nat) (prog : HTL.program) (m : HTL.module) : res (list ident) := + match fuel with + | O => Error (msg "Veriloggen: recursion too deep") + | S fuel' => + let modmap := prog_modmap prog in + let directly_referenced_names : list ident := + (* Take just the module name *) + (List.map (fun '(_, (othermod_name, _)) => othermod_name) + (PTree.elements (HTL.mod_externctrl m))) in + do indirectly_referenced_namess <- + mmap (fun '(_, m) => referenced_module_names fuel' prog m) + (List.filter (fun '(n, m) => in_dec Pos.eq_dec n directly_referenced_names) + (PTree.elements modmap)); + + let indirectly_referenced_names := List.concat indirectly_referenced_namess in + OK (List.nodup Pos.eq_dec (directly_referenced_names ++ indirectly_referenced_names)) + end. + + Definition transl_top_module (prog : HTL.program) (m : HTL.module) : res Verilog.module := + let tm := transl_module None m in + + let modmap := prog_modmap prog in + do referenced_names <- referenced_module_names 100 prog m; + do referenced_modules <- mmap (fun n => match modmap!n with + | Some m => OK m + | None => Error (msg "Veriloggen: Could not find module") + end) referenced_names; + let translated_modules := List.map (transl_module (Some (mod_clk tm))) referenced_modules in + let cleaned_modules := List.map (map_body (Option.map_option (clean_up_decl (mod_clk tm)))) translated_modules in + let referenced_module_bodies := List.flat_map Verilog.mod_body cleaned_modules in + + OK (map_body (app referenced_module_bodies) tm). + + Definition transl_fundef (prog : HTL.program) := transf_partial_fundef (transl_top_module prog). + Definition transl_program (prog : HTL.program) := transform_partial_program (transl_fundef prog) prog. + +End TRANSLATE. diff --git a/src/hls/Veriloggenproof.v b/src/hls/Veriloggenproof.v index d1494ec..37b4dfd 100644 --- a/src/hls/Veriloggenproof.v +++ b/src/hls/Veriloggenproof.v @@ -17,6 +17,7 @@ *) From compcert Require Import Smallstep Linking Integers Globalenvs. +From compcert Require Errors. From vericert Require HTL. From vericert Require Import Vericertlib Veriloggen Verilog ValueInt AssocMap. Require Import Lia. @@ -24,315 +25,353 @@ Require Import Lia. Local Open Scope assocmap. Definition match_prog (prog : HTL.program) (tprog : Verilog.program) := - match_program (fun cu f tf => tf = transl_fundef f) eq prog tprog. + match_program (fun cu f tf => Errors.OK tf = transl_fundef prog f) eq prog tprog. Lemma transf_program_match: - forall prog, match_prog prog (transl_program prog). + forall prog tprog, transl_program prog = Errors.OK tprog -> match_prog prog tprog. Proof. - intros. eapply match_transform_program_contextual. auto. + intros. unfold transl_program in *. eapply match_transform_partial_program_contextual; eauto. Qed. -Inductive match_stacks : list HTL.stackframe -> list stackframe -> Prop := -| match_stack : - forall res m pc reg_assoc arr_assoc hstk vstk, - match_stacks hstk vstk -> - match_stacks (HTL.Stackframe res m pc reg_assoc arr_assoc :: hstk) - (Stackframe res (transl_module m) pc - reg_assoc arr_assoc :: vstk) -| match_stack_nil : match_stacks nil nil. - -Inductive match_states : HTL.state -> state -> Prop := -| match_state : - forall m st reg_assoc arr_assoc hstk vstk, - match_stacks hstk vstk -> - match_states (HTL.State hstk m st reg_assoc arr_assoc) - (State vstk (transl_module m) st reg_assoc arr_assoc) -| match_returnstate : - forall v hstk vstk, - match_stacks hstk vstk -> - match_states (HTL.Returnstate hstk v) (Returnstate vstk v) -| match_initial_call : - forall m, - match_states (HTL.Callstate nil m nil) (Callstate nil (transl_module m) nil). - -Lemma Vlit_inj : - forall a b, Vlit a = Vlit b -> a = b. -Proof. inversion 1. trivial. Qed. - -Lemma posToValue_inj : - forall a b, - 0 <= Z.pos a <= Int.max_unsigned -> - 0 <= Z.pos b <= Int.max_unsigned -> - posToValue a = posToValue b -> - a = b. -Proof. - intros. rewrite <- Pos2Z.id at 1. rewrite <- Pos2Z.id. - rewrite <- Int.unsigned_repr at 1; try assumption. - symmetry. - rewrite <- Int.unsigned_repr at 1; try assumption. - unfold posToValue in *. rewrite H1; auto. -Qed. - -Lemma valueToPos_inj : - forall a b, - 0 < Int.unsigned a -> - 0 < Int.unsigned b -> - valueToPos a = valueToPos b -> - a = b. -Proof. - intros. unfold valueToPos in *. - rewrite <- Int.repr_unsigned at 1. - rewrite <- Int.repr_unsigned. - apply Pos2Z.inj_iff in H1. - rewrite Z2Pos.id in H1; auto. - rewrite Z2Pos.id in H1; auto. - rewrite H1. auto. -Qed. - -Lemma unsigned_posToValue_le : - forall p, - Z.pos p <= Int.max_unsigned -> - 0 < Int.unsigned (posToValue p). -Proof. - intros. unfold posToValue. rewrite Int.unsigned_repr; lia. -Qed. - -Lemma transl_list_fun_fst : - forall p1 p2 a b, - 0 <= Z.pos p1 <= Int.max_unsigned -> - 0 <= Z.pos p2 <= Int.max_unsigned -> - transl_list_fun (p1, a) = transl_list_fun (p2, b) -> - (p1, a) = (p2, b). -Proof. - intros. unfold transl_list_fun in H1. apply pair_equal_spec in H1. - destruct H1. rewrite H2. apply Vlit_inj in H1. - apply posToValue_inj in H1; try assumption. - rewrite H1; auto. -Qed. - -Lemma Zle_relax : - forall p q r, - p < q <= r -> - p <= q <= r. -Proof. lia. Qed. -#[local] Hint Resolve Zle_relax : verilogproof. - -Lemma transl_in : - forall l p, - 0 <= Z.pos p <= Int.max_unsigned -> - (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> - In (Vlit (posToValue p)) (map fst (map transl_list_fun l)) -> - In p (map fst l). -Proof. - induction l. - - simplify. auto. - - intros. destruct a. simplify. destruct (peq p0 p); auto. - right. inv H1. apply Vlit_inj in H. apply posToValue_inj in H; auto. contradiction. - auto with verilogproof. - apply IHl; auto. -Qed. - -Lemma transl_notin : - forall l p, - 0 <= Z.pos p <= Int.max_unsigned -> - (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> - ~ In p (List.map fst l) -> ~ In (Vlit (posToValue p)) (List.map fst (transl_list l)). -Proof. - induction l; auto. intros. destruct a. unfold not in *. intros. - simplify. - destruct (peq p0 p). apply H1. auto. apply H1. - unfold transl_list in *. inv H2. apply Vlit_inj in H. apply posToValue_inj in H. - contradiction. - auto with verilogproof. auto. - right. apply transl_in; auto. -Qed. - -Lemma transl_norepet : - forall l, - (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> - list_norepet (List.map fst l) -> list_norepet (List.map fst (transl_list l)). -Proof. - induction l. - - intros. simpl. apply list_norepet_nil. - - destruct a. intros. simpl. apply list_norepet_cons. - inv H0. apply transl_notin. apply Zle_relax. apply H. simplify; auto. - intros. apply H. destruct (peq p0 p); subst; simplify; auto. - assumption. apply IHl. intros. apply H. destruct (peq p0 p); subst; simplify; auto. - simplify. inv H0. assumption. -Qed. - -Lemma transl_list_correct : - forall l v ev f asr asa asrn asan asr' asa' asrn' asan', - (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> - list_norepet (List.map fst l) -> - asr!ev = Some v -> - (forall p s, - In (p, s) l -> - v = posToValue p -> - stmnt_runp f - {| assoc_blocking := asr; assoc_nonblocking := asrn |} - {| assoc_blocking := asa; assoc_nonblocking := asan |} - s - {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} - {| assoc_blocking := asa'; assoc_nonblocking := asan' |} -> - stmnt_runp f - {| assoc_blocking := asr; assoc_nonblocking := asrn |} - {| assoc_blocking := asa; assoc_nonblocking := asan |} - (Vcase (Vvar ev) (list_to_stmnt (transl_list l)) (Some Vskip)) - {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} - {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). -Proof. - induction l as [| a l IHl]. - - contradiction. - - intros v ev f asr asa asrn asan asr' asa' asrn' asan' BOUND NOREP ASSOC p s IN EQ SRUN. - destruct a as [p' s']. simplify. - destruct (peq p p'); subst. eapply stmnt_runp_Vcase_match. - constructor. simplify. unfold AssocMap.find_assocmap, AssocMapExt.get_default. - rewrite ASSOC. trivial. constructor. auto. - inversion IN as [INV | INV]. inversion INV as [INV2]; subst. assumption. - inv NOREP. eapply in_map with (f := fst) in INV. contradiction. - - eapply stmnt_runp_Vcase_nomatch. constructor. simplify. - unfold AssocMap.find_assocmap, AssocMapExt.get_default. rewrite ASSOC. - trivial. constructor. unfold not. intros. apply n. apply posToValue_inj. - apply Zle_relax. apply BOUND. right. inv IN. inv H0; contradiction. - eapply in_map with (f := fst) in H0. auto. - apply Zle_relax. apply BOUND; auto. auto. - - eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. - trivial. assumption. -Qed. -#[local] Hint Resolve transl_list_correct : verilogproof. - -Lemma pc_wf : - forall A m p v, - (forall p0, In p0 (List.map fst (@AssocMap.elements A m)) -> 0 < Z.pos p0 <= Int.max_unsigned) -> - m!p = Some v -> - 0 <= Z.pos p <= Int.max_unsigned. -Proof. - intros A m p v LT S. apply Zle_relax. apply LT. - apply AssocMap.elements_correct in S. remember (p, v) as x. - exploit in_map. apply S. instantiate (1 := fst). subst. simplify. auto. -Qed. - -Lemma mis_stepp_decl : - forall l asr asa f, - mis_stepp f asr asa (map Vdeclaration l) asr asa. -Proof. - induction l. - - intros. constructor. - - intros. simplify. econstructor. constructor. auto. -Qed. -#[local] Hint Resolve mis_stepp_decl : verilogproof. - -Lemma mis_stepp_negedge_decl : - forall l asr asa f, - mis_stepp_negedge f asr asa (map Vdeclaration l) asr asa. -Proof. - induction l. - - intros. constructor. - - intros. simplify. econstructor. constructor. auto. -Qed. -#[local] Hint Resolve mis_stepp_negedge_decl : verilogproof. - -Lemma mod_entrypoint_equiv m : mod_entrypoint (transl_module m) = HTL.mod_entrypoint m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_st_equiv m : mod_st (transl_module m) = HTL.mod_st m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_stk_equiv m : mod_stk (transl_module m) = HTL.mod_stk m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_stk_len_equiv m : mod_stk_len (transl_module m) = HTL.mod_stk_len m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_finish_equiv m : mod_finish (transl_module m) = HTL.mod_finish m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_reset_equiv m : mod_reset (transl_module m) = HTL.mod_reset m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_clk_equiv m : mod_clk (transl_module m) = HTL.mod_clk m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_return_equiv m : mod_return (transl_module m) = HTL.mod_return m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma mod_params_equiv m : mod_args (transl_module m) = HTL.mod_params m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Lemma empty_stack_equiv m : empty_stack (transl_module m) = HTL.empty_stack m. -Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. - -Ltac rewrite_eq := rewrite mod_return_equiv - || rewrite mod_clk_equiv - || rewrite mod_reset_equiv - || rewrite mod_finish_equiv - || rewrite mod_stk_len_equiv - || rewrite mod_stk_equiv - || rewrite mod_st_equiv - || rewrite mod_entrypoint_equiv - || rewrite mod_params_equiv - || rewrite empty_stack_equiv. - -Lemma find_assocmap_get r i v : r ! i = Some v -> r # i = v. -Proof. - intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H. auto. -Qed. - -Lemma ram_exec_match : - forall f asr asa asr' asa' r clk, - HTL.exec_ram asr asa (Some r) asr' asa' -> - mi_stepp_negedge f asr asa (inst_ram clk r) asr' asa'. -Proof. - inversion 1; subst; simplify. - { unfold inst_ram. econstructor. - eapply stmnt_runp_Vcond_false. - econstructor. econstructor. econstructor. auto. - econstructor. auto. - simplify. - unfold boolToValue, natToValue, valueToBool. - rewrite Int.eq_sym. rewrite H3. simplify. - auto. constructor. } - { unfold inst_ram. econstructor. econstructor. econstructor. - econstructor. econstructor. auto. - econstructor. auto. - simplify. - unfold boolToValue, natToValue, valueToBool. - pose proof H4 as X. apply find_assocmap_get in X. - rewrite X. rewrite Int.eq_sym. rewrite H1. auto. - econstructor. econstructor. econstructor. econstructor. - pose proof H5 as X. apply find_assocmap_get in X. - rewrite X. - unfold valueToBool. unfold ZToValue in *. - unfold Int.eq in H2. - unfold uvalueToZ. - assert (Int.unsigned wr_en =? 0 = false). - apply Z.eqb_neq. rewrite Int.unsigned_repr in H2 by (simplify; lia). - destruct (zeq (Int.unsigned wr_en) 0); crush. - rewrite H0. auto. - apply stmnt_runp_Vnonblock_arr. econstructor. econstructor. auto. - econstructor. econstructor. - apply find_assocmap_get in H9. rewrite H9. - apply find_assocmap_get in H6. rewrite H6. - repeat econstructor. apply find_assocmap_get; auto. - } - { econstructor. econstructor. econstructor. econstructor. auto. - econstructor. auto. - econstructor. - unfold boolToValue, natToValue, valueToBool. - apply find_assocmap_get in H3. rewrite H3. - rewrite Int.eq_sym. rewrite H1. auto. - econstructor. - eapply stmnt_runp_Vcond_false. econstructor. auto. - simplify. apply find_assocmap_get in H4. rewrite H4. - auto. - repeat (econstructor; auto). apply find_assocmap_get in H5. - rewrite H5. eassumption. - repeat econstructor. simplify. apply find_assocmap_get; auto. - } -Qed. +Instance TransfVerilogLink : TransfLink Veriloggenproof.match_prog. +Admitted. + +(* Inductive match_stacks : list HTL.stackframe -> list stackframe -> Prop := *) +(* | match_stack : *) +(* forall res m pc reg_assoc arr_assoc hstk vstk, *) +(* match_stacks hstk vstk -> *) +(* match_stacks (HTL.Stackframe res m pc reg_assoc arr_assoc :: hstk) *) +(* (Stackframe res (transl_module m) pc *) +(* reg_assoc arr_assoc :: vstk) *) +(* | match_stack_nil : match_stacks nil nil. *) + +(* Inductive match_states : HTL.state -> state -> Prop := *) +(* | match_state : *) +(* forall m st reg_assoc arr_assoc hstk vstk, *) +(* match_stacks hstk vstk -> *) +(* match_states (HTL.State hstk m st reg_assoc arr_assoc) *) +(* (State vstk (transl_module m) st reg_assoc arr_assoc) *) +(* | match_returnstate : *) +(* forall v hstk vstk, *) +(* match_stacks hstk vstk -> *) +(* match_states (HTL.Returnstate hstk v) (Returnstate vstk v) *) +(* | match_initial_call : *) +(* forall m, *) +(* match_states (HTL.Callstate nil m nil) (Callstate nil (transl_module m) nil). *) + +(* Lemma Vlit_inj : *) +(* forall a b, Vlit a = Vlit b -> a = b. *) +(* Proof. inversion 1. trivial. Qed. *) + +(* Lemma posToValue_inj : *) +(* forall a b, *) +(* 0 <= Z.pos a <= Int.max_unsigned -> *) +(* 0 <= Z.pos b <= Int.max_unsigned -> *) +(* posToValue a = posToValue b -> *) +(* a = b. *) +(* Proof. *) +(* intros. rewrite <- Pos2Z.id at 1. rewrite <- Pos2Z.id. *) +(* rewrite <- Int.unsigned_repr at 1; try assumption. *) +(* symmetry. *) +(* rewrite <- Int.unsigned_repr at 1; try assumption. *) +(* unfold posToValue in *. rewrite H1; auto. *) +(* Qed. *) + +(* Lemma valueToPos_inj : *) +(* forall a b, *) +(* 0 < Int.unsigned a -> *) +(* 0 < Int.unsigned b -> *) +(* valueToPos a = valueToPos b -> *) +(* a = b. *) +(* Proof. *) +(* intros. unfold valueToPos in *. *) +(* rewrite <- Int.repr_unsigned at 1. *) +(* rewrite <- Int.repr_unsigned. *) +(* apply Pos2Z.inj_iff in H1. *) +(* rewrite Z2Pos.id in H1; auto. *) +(* rewrite Z2Pos.id in H1; auto. *) +(* rewrite H1. auto. *) +(* Qed. *) + +(* Lemma unsigned_posToValue_le : *) +(* forall p, *) +(* Z.pos p <= Int.max_unsigned -> *) +(* 0 < Int.unsigned (posToValue p). *) +(* Proof. *) +(* intros. unfold posToValue. rewrite Int.unsigned_repr; lia. *) +(* Qed. *) + +(* Lemma transl_ctrl_fun_fst : *) +(* forall p1 p2 a b, *) +(* 0 <= Z.pos p1 <= Int.max_unsigned -> *) +(* 0 <= Z.pos p2 <= Int.max_unsigned -> *) +(* transl_ctrl_fun (p1, a) = transl_ctrl_fun (p2, b) -> *) +(* (p1, a) = (p2, b). *) +(* Proof. *) +(* intros. unfold transl_ctrl_fun in H1. apply pair_equal_spec in H1. *) +(* destruct H1. rewrite H2. apply Vlit_inj in H1. *) +(* apply posToValue_inj in H1; try assumption. *) +(* rewrite H1; auto. *) +(* Qed. *) + +(* Lemma transl_data_fun_fst : *) +(* forall p1 p2 a b, *) +(* 0 <= Z.pos p1 <= Int.max_unsigned -> *) +(* 0 <= Z.pos p2 <= Int.max_unsigned -> *) +(* transl_datapath_fun (p1, a) = transl_datapath_fun (p2, b) -> *) +(* p1 = p2. *) +(* Proof. *) +(* intros. *) +(* unfold transl_datapath_fun in H1. apply pair_equal_spec in H1. destruct H1. *) +(* apply Vlit_inj in H1. apply posToValue_inj in H1; assumption. *) +(* Qed. *) + +(* Lemma Zle_relax : *) +(* forall p q r, *) +(* p < q <= r -> *) +(* p <= q <= r. *) +(* Proof. lia. Qed. *) +(* Hint Resolve Zle_relax : verilogproof. *) + +(* Lemma transl_in : *) +(* forall l p, *) +(* 0 <= Z.pos p <= Int.max_unsigned -> *) +(* (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> *) +(* In (Vlit (posToValue p)) (map fst (map transl_ctrl_fun l)) -> *) +(* In p (map fst l). *) +(* Proof. *) +(* induction l. *) +(* - simplify. auto. *) +(* - intros. destruct a. simplify. destruct (peq p0 p); auto. *) +(* right. inv H1. apply Vlit_inj in H. apply posToValue_inj in H; auto. contradiction. *) +(* auto with verilogproof. *) +(* apply IHl; auto. *) +(* Qed. *) + +(* Lemma transl_notin : *) +(* forall l p, *) +(* 0 <= Z.pos p <= Int.max_unsigned -> *) +(* (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> *) +(* ~ In p (List.map fst l) -> ~ In (Vlit (posToValue p)) (List.map fst (transl_ctrl l)). *) +(* Proof. *) +(* induction l; auto. intros. destruct a. unfold not in *. intros. *) +(* simplify. *) +(* destruct (peq p0 p). apply H1. auto. apply H1. *) +(* unfold transl_ctrl in *. inv H2. apply Vlit_inj in H. apply posToValue_inj in H. *) +(* contradiction. *) +(* auto with verilogproof. auto. *) +(* right. apply transl_in; auto. *) +(* Qed. *) + +(* Lemma transl_norepet : *) +(* forall l, *) +(* (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> *) +(* list_norepet (List.map fst l) -> list_norepet (List.map fst (transl_ctrl l)). *) +(* Proof. *) +(* induction l. *) +(* - intros. simpl. apply list_norepet_nil. *) +(* - destruct a. intros. simpl. apply list_norepet_cons. *) +(* inv H0. apply transl_notin. apply Zle_relax. apply H. simplify; auto. *) +(* intros. apply H. destruct (peq p0 p); subst; simplify; auto. *) +(* assumption. apply IHl. intros. apply H. destruct (peq p0 p); subst; simplify; auto. *) +(* simplify. inv H0. assumption. *) +(* Qed. *) + +(* Lemma transl_ctrl_correct : *) +(* forall l v ev f asr asa asrn asan asr' asa' asrn' asan', *) +(* (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> *) +(* list_norepet (List.map fst l) -> *) +(* asr!ev = Some v -> *) +(* (forall p s, *) +(* In (p, s) l -> *) +(* v = posToValue p -> *) +(* stmnt_runp f *) +(* {| assoc_blocking := asr; assoc_nonblocking := asrn |} *) +(* {| assoc_blocking := asa; assoc_nonblocking := asan |} *) +(* s *) +(* {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} *) +(* {| assoc_blocking := asa'; assoc_nonblocking := asan' |} -> *) +(* stmnt_runp f *) +(* {| assoc_blocking := asr; assoc_nonblocking := asrn |} *) +(* {| assoc_blocking := asa; assoc_nonblocking := asan |} *) +(* (Vcase (Vvar ev) (transl_ctrl l) (Some Vskip)) *) +(* {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} *) +(* {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). *) +(* Proof. *) +(* induction l as [| a l IHl]. *) +(* - contradiction. *) +(* - intros v ev f asr asa asrn asan asr' asa' asrn' asan' BOUND NOREP ASSOC p s IN EQ SRUN. *) +(* destruct a as [p' s']. simplify. *) +(* destruct (peq p p'); subst. eapply stmnt_runp_Vcase_match. *) +(* constructor. simplify. unfold AssocMap.find_assocmap, AssocMapExt.get_default. *) +(* rewrite ASSOC. trivial. constructor. auto. *) +(* inversion IN as [INV | INV]. inversion INV as [INV2]; subst. assumption. *) +(* inv NOREP. eapply in_map with (f := fst) in INV. contradiction. *) + +(* eapply stmnt_runp_Vcase_nomatch. constructor. simplify. *) +(* unfold AssocMap.find_assocmap, AssocMapExt.get_default. rewrite ASSOC. *) +(* trivial. constructor. unfold not. intros. apply n. apply posToValue_inj. *) +(* apply Zle_relax. apply BOUND. right. inv IN. inv H0; contradiction. *) +(* eapply in_map with (f := fst) in H0. auto. *) +(* apply Zle_relax. apply BOUND; auto. auto. *) + +(* eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. *) +(* trivial. assumption. *) +(* Qed. *) +(* Hint Resolve transl_ctrl_correct : verilogproof. *) + +(* (* FIXME Probably wrong we probably need some statemnt about datapath_statement_runp *) *) +(* Lemma transl_datapath_correct : *) +(* forall l v ev f asr asa asrn asan asr' asa' asrn' asan', *) +(* (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> *) +(* list_norepet (List.map fst l) -> *) +(* asr!ev = Some v -> *) +(* (forall p s, *) +(* In (p, s) l -> *) +(* v = posToValue p -> *) +(* stmnt_runp f *) +(* {| assoc_blocking := asr; assoc_nonblocking := asrn |} *) +(* {| assoc_blocking := asa; assoc_nonblocking := asan |} *) +(* s *) +(* {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} *) +(* {| assoc_blocking := asa'; assoc_nonblocking := asan' |} -> *) +(* stmnt_runp f *) +(* {| assoc_blocking := asr; assoc_nonblocking := asrn |} *) +(* {| assoc_blocking := asa; assoc_nonblocking := asan |} *) +(* (Vcase (Vvar ev) (transl_ctrl l) (Some Vskip)) *) +(* {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} *) +(* {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). *) +(* Proof. Admitted. *) + +(* Lemma pc_wf : *) +(* forall A m p v, *) +(* (forall p0, In p0 (List.map fst (@AssocMap.elements A m)) -> 0 < Z.pos p0 <= Int.max_unsigned) -> *) +(* m!p = Some v -> *) +(* 0 <= Z.pos p <= Int.max_unsigned. *) +(* Proof. *) +(* intros A m p v LT S. apply Zle_relax. apply LT. *) +(* apply AssocMap.elements_correct in S. remember (p, v) as x. *) +(* exploit in_map. apply S. instantiate (1 := fst). subst. simplify. auto. *) +(* Qed. *) + +(* Lemma mis_stepp_decl : *) +(* forall l asr asa f, *) +(* mis_stepp f asr asa (map Vdeclaration l) asr asa. *) +(* Proof. *) +(* induction l. *) +(* - intros. constructor. *) +(* - intros. simplify. econstructor. constructor. auto. *) +(* Qed. *) +(* Hint Resolve mis_stepp_decl : verilogproof. *) + +(* Lemma mis_stepp_negedge_decl : *) +(* forall l asr asa f, *) +(* mis_stepp_negedge f asr asa (map Vdeclaration l) asr asa. *) +(* Proof. *) +(* induction l. *) +(* - intros. constructor. *) +(* - intros. simplify. econstructor. constructor. auto. *) +(* Qed. *) +(* Hint Resolve mis_stepp_negedge_decl : verilogproof. *) + +(* Lemma mod_entrypoint_equiv m : mod_entrypoint (transl_module m) = HTL.mod_entrypoint m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_st_equiv m : mod_st (transl_module m) = HTL.mod_st m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_stk_equiv m : mod_stk (transl_module m) = HTL.mod_stk m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_stk_len_equiv m : mod_stk_len (transl_module m) = HTL.mod_stk_len m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_finish_equiv m : mod_finish (transl_module m) = HTL.mod_finish m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_reset_equiv m : mod_reset (transl_module m) = HTL.mod_reset m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_clk_equiv m : mod_clk (transl_module m) = HTL.mod_clk m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_return_equiv m : mod_return (transl_module m) = HTL.mod_return m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma mod_params_equiv m : mod_args (transl_module m) = HTL.mod_params m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Lemma empty_stack_equiv m : empty_stack (transl_module m) = HTL.empty_stack m. *) +(* Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. *) + +(* Ltac rewrite_eq := rewrite mod_return_equiv *) +(* || rewrite mod_clk_equiv *) +(* || rewrite mod_reset_equiv *) +(* || rewrite mod_finish_equiv *) +(* || rewrite mod_stk_len_equiv *) +(* || rewrite mod_stk_equiv *) +(* || rewrite mod_st_equiv *) +(* || rewrite mod_entrypoint_equiv *) +(* || rewrite mod_params_equiv *) +(* || rewrite empty_stack_equiv. *) + +(* Lemma find_assocmap_get r i v : r ! i = Some v -> r # i = v. *) +(* Proof. *) +(* intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H. auto. *) +(* Qed. *) + +(* Lemma ram_exec_match : *) +(* forall f asr asa asr' asa' r clk, *) +(* HTL.exec_ram asr asa (Some r) asr' asa' -> *) +(* mi_stepp_negedge f asr asa (inst_ram clk r) asr' asa'. *) +(* Proof. *) +(* inversion 1; subst; simplify. *) +(* { unfold inst_ram. econstructor. *) +(* eapply stmnt_runp_Vcond_false. *) +(* econstructor. econstructor. econstructor. auto. *) +(* econstructor. auto. *) +(* simplify. *) +(* unfold boolToValue, natToValue, valueToBool. *) +(* rewrite Int.eq_sym. rewrite H3. simplify. *) +(* auto. constructor. } *) +(* { unfold inst_ram. econstructor. econstructor. econstructor. *) +(* econstructor. econstructor. auto. *) +(* econstructor. auto. *) +(* simplify. *) +(* unfold boolToValue, natToValue, valueToBool. *) +(* pose proof H4 as X. apply find_assocmap_get in X. *) +(* rewrite X. rewrite Int.eq_sym. rewrite H1. auto. *) +(* econstructor. econstructor. econstructor. econstructor. *) +(* pose proof H5 as X. apply find_assocmap_get in X. *) +(* rewrite X. *) +(* unfold valueToBool. unfold ZToValue in *. *) +(* unfold Int.eq in H2. *) +(* unfold uvalueToZ. *) +(* assert (Int.unsigned wr_en =? 0 = false). *) +(* apply Z.eqb_neq. rewrite Int.unsigned_repr in H2 by (simplify; lia). *) +(* destruct (zeq (Int.unsigned wr_en) 0); crush. *) +(* rewrite H0. auto. *) +(* apply stmnt_runp_Vnonblock_arr. econstructor. econstructor. auto. *) +(* econstructor. econstructor. *) +(* apply find_assocmap_get in H9. rewrite H9. *) +(* apply find_assocmap_get in H6. rewrite H6. *) +(* repeat econstructor. apply find_assocmap_get; auto. *) +(* } *) +(* { econstructor. econstructor. econstructor. econstructor. auto. *) +(* econstructor. auto. *) +(* econstructor. *) +(* unfold boolToValue, natToValue, valueToBool. *) +(* apply find_assocmap_get in H3. rewrite H3. *) +(* rewrite Int.eq_sym. rewrite H1. auto. *) +(* econstructor. *) +(* eapply stmnt_runp_Vcond_false. econstructor. auto. *) +(* simplify. apply find_assocmap_get in H4. rewrite H4. *) +(* auto. *) +(* repeat (econstructor; auto). apply find_assocmap_get in H5. *) +(* rewrite H5. eassumption. *) +(* repeat econstructor. simplify. apply find_assocmap_get; auto. *) +(* } *) +(* Qed. *) Section CORRECTNESS. @@ -350,195 +389,133 @@ Section CORRECTNESS. Proof. intros. eapply (Genv.find_symbol_match TRANSL). Qed. #[local] Hint Resolve symbols_preserved : verilogproof. - Lemma function_ptr_translated: - forall (b: Values.block) (f: HTL.fundef), - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = tf. - Proof. - intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. - intros (cu & tf & P & Q & R); exists tf; auto. - Qed. - #[local] Hint Resolve function_ptr_translated : verilogproof. - - Lemma functions_translated: - forall (v: Values.val) (f: HTL.fundef), - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transl_fundef f = tf. - Proof. - intros. exploit (Genv.find_funct_match TRANSL); eauto. - intros (cu & tf & P & Q & R); exists tf; auto. - Qed. - #[local] Hint Resolve functions_translated : verilogproof. - - Lemma senv_preserved: - Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). - Proof. - intros. eapply (Genv.senv_match TRANSL). - Qed. - #[local] Hint Resolve senv_preserved : verilogproof. - - Ltac unfold_replace := - match goal with - | H: HTL.mod_ram _ = _ |- context[transl_module] => - unfold transl_module; rewrite H - end. - - Theorem transl_step_correct : - forall (S1 : HTL.state) t S2, - HTL.step ge S1 t S2 -> - forall (R1 : state), - match_states S1 R1 -> - exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. - Proof. - induction 1; intros R1 MSTATE; inv MSTATE; destruct (HTL.mod_ram m) eqn:?. - - econstructor; split. apply Smallstep.plus_one. econstructor. - unfold_replace. assumption. unfold_replace. assumption. - unfold_replace. eassumption. apply valueToPos_posToValue. - split. lia. - eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. - unfold_replace. - econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. - simpl. unfold find_assocmap. unfold AssocMapExt.get_default. - rewrite H. trivial. - - econstructor. simpl. auto. auto. - - eapply transl_list_correct. - intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. auto. - apply Maps.PTree.elements_keys_norepet. eassumption. - 2: { apply valueToPos_inj. apply unsigned_posToValue_le. - eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. - apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. - destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. trivial. - } - apply Maps.PTree.elements_correct. eassumption. eassumption. - - econstructor. econstructor. - - eapply transl_list_correct. - intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. - auto. apply Maps.PTree.elements_keys_norepet. eassumption. - 2: { apply valueToPos_inj. apply unsigned_posToValue_le. - eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. - apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. - destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. trivial. - } - apply Maps.PTree.elements_correct. eassumption. eassumption. - econstructor. econstructor. - apply mis_stepp_decl. simplify. unfold_replace. simplify. - econstructor. econstructor. econstructor. econstructor. - econstructor. - apply ram_exec_match. eauto. - apply mis_stepp_negedge_decl. simplify. auto. auto. - rewrite_eq. eauto. auto. - rewrite valueToPos_posToValue. econstructor. auto. - simplify; lia. - - inv H7. econstructor; split. apply Smallstep.plus_one. econstructor. - unfold_replace. assumption. unfold_replace. assumption. - unfold_replace. eassumption. apply valueToPos_posToValue. - split. lia. - eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. - unfold_replace. - econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. - simpl. unfold find_assocmap. unfold AssocMapExt.get_default. - rewrite H. trivial. - - econstructor. simpl. auto. auto. - - eapply transl_list_correct. - intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. auto. - apply Maps.PTree.elements_keys_norepet. eassumption. - 2: { apply valueToPos_inj. apply unsigned_posToValue_le. - eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. - apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. - destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. trivial. - } - apply Maps.PTree.elements_correct. eassumption. eassumption. - - econstructor. econstructor. - - eapply transl_list_correct. - intros. split. lia. pose proof (HTL.mod_wf m) as HP. - destruct HP as [_ HP]; auto. - apply Maps.PTree.elements_keys_norepet. eassumption. - 2: { apply valueToPos_inj. apply unsigned_posToValue_le. - eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. - apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. - destruct HP as [HP _]. - split. lia. apply HP. eassumption. eassumption. trivial. - } - apply Maps.PTree.elements_correct. eassumption. eassumption. - - apply mis_stepp_decl. simplify. - unfold_replace. - repeat econstructor. apply mis_stepp_negedge_decl. trivial. trivial. - simpl. unfold_replace. eassumption. auto. simplify. - rewrite valueToPos_posToValue. constructor; eassumption. simplify; lia. - - econstructor; split. apply Smallstep.plus_one. apply step_finish. - rewrite_eq. assumption. - rewrite_eq. eassumption. - econstructor; auto. - - econstructor; split. apply Smallstep.plus_one. apply step_finish. - unfold transl_module. rewrite Heqo. simplify. - assumption. unfold_replace. eassumption. - constructor; assumption. - - econstructor; split. apply Smallstep.plus_one. constructor. - repeat rewrite_eq. constructor. constructor. - - econstructor; split. apply Smallstep.plus_one. constructor. - repeat rewrite_eq. constructor. constructor. - - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. - repeat rewrite_eq. apply match_state. assumption. - - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. - repeat rewrite_eq. apply match_state. assumption. - Qed. - #[local] Hint Resolve transl_step_correct : verilogproof. - - Lemma transl_initial_states : - forall s1 : Smallstep.state (HTL.semantics prog), - Smallstep.initial_state (HTL.semantics prog) s1 -> - exists s2 : Smallstep.state (Verilog.semantics tprog), - Smallstep.initial_state (Verilog.semantics tprog) s2 /\ match_states s1 s2. - Proof. - induction 1. - econstructor; split. econstructor. - apply (Genv.init_mem_transf TRANSL); eauto. - rewrite symbols_preserved. - replace (AST.prog_main tprog) with (AST.prog_main prog); eauto. - symmetry; eapply Linking.match_program_main; eauto. - exploit function_ptr_translated; eauto. intros [tf [A B]]. - inv B. eauto. - constructor. - Qed. - #[local] Hint Resolve transl_initial_states : verilogproof. - - Lemma transl_final_states : - forall (s1 : Smallstep.state (HTL.semantics prog)) - (s2 : Smallstep.state (Verilog.semantics tprog)) - (r : Integers.Int.int), - match_states s1 s2 -> - Smallstep.final_state (HTL.semantics prog) s1 r -> - Smallstep.final_state (Verilog.semantics tprog) s2 r. - Proof. - intros. inv H0. inv H. inv H3. constructor. reflexivity. - Qed. - #[local] Hint Resolve transl_final_states : verilogproof. +(* Lemma function_ptr_translated: *) +(* forall (b: Values.block) (f: HTL.fundef), *) +(* Genv.find_funct_ptr ge b = Some f -> *) +(* exists tf, *) +(* Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = tf. *) +(* Proof. *) +(* intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. *) +(* intros (cu & tf & P & Q & R); exists tf; auto. *) +(* Qed. *) +(* Hint Resolve function_ptr_translated : verilogproof. *) + +(* Lemma functions_translated: *) +(* forall (v: Values.val) (f: HTL.fundef), *) +(* Genv.find_funct ge v = Some f -> *) +(* exists tf, *) +(* Genv.find_funct tge v = Some tf /\ transl_fundef f = tf. *) +(* Proof. *) +(* intros. exploit (Genv.find_funct_match TRANSL); eauto. *) +(* intros (cu & tf & P & Q & R); exists tf; auto. *) +(* Qed. *) +(* Hint Resolve functions_translated : verilogproof. *) + +(* Lemma senv_preserved: *) +(* Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). *) +(* Proof. *) +(* intros. eapply (Genv.senv_match TRANSL). *) +(* Qed. *) +(* Hint Resolve senv_preserved : verilogproof. *) + +(* Theorem transl_step_correct : *) +(* forall (S1 : HTL.state) t S2, *) +(* HTL.step ge S1 t S2 -> *) +(* forall (R1 : state), *) +(* match_states S1 R1 -> *) +(* exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. *) +(* Proof. *) +(* induction 1; intros R1 MSTATE; inv MSTATE. *) +(* - econstructor; split. apply Smallstep.plus_one. econstructor. *) +(* assumption. assumption. eassumption. apply valueToPos_posToValue. *) +(* split. lia. *) +(* eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. *) +(* split. lia. apply HP. eassumption. eassumption. *) +(* econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. *) +(* simpl. unfold find_assocmap. unfold AssocMapExt.get_default. *) +(* rewrite H. trivial. *) + +(* econstructor. simpl. auto. auto. *) + +(* eapply transl_ctrl_correct. *) +(* intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. auto. *) +(* apply Maps.PTree.elements_keys_norepet. eassumption. *) +(* 2: { apply valueToPos_inj. apply unsigned_posToValue_le. *) +(* eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. *) +(* split. lia. apply HP. eassumption. eassumption. *) +(* apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. *) +(* destruct HP as [HP _]. *) +(* split. lia. apply HP. eassumption. eassumption. trivial. *) +(* } *) +(* apply Maps.PTree.elements_correct. eassumption. eassumption. *) + +(* econstructor. econstructor. *) + +(* { admit. *) +(* (* *) *) +(* (* eapply transl_list_correct. *) *) +(* (* intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. auto. *) *) +(* (* apply Maps.PTree.elements_keys_norepet. eassumption. *) *) +(* (* 2: { apply valueToPos_inj. apply unsigned_posToValue_le. *) *) +(* (* eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. *) *) +(* (* split. lia. apply HP. eassumption. eassumption. *) *) +(* (* apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. *) *) +(* (* destruct HP as [HP _]. *) *) +(* (* split. lia. apply HP. eassumption. eassumption. trivial. *) *) +(* (* } *) *) +(* (* apply Maps.PTree.elements_correct. eassumption. eassumption. *) *) +(* (* *) *) +(* } *) + +(* apply mis_stepp_decl. trivial. trivial. simpl. eassumption. auto. *) +(* rewrite valueToPos_posToValue. constructor; assumption. lia. *) +(* - econstructor; split. apply Smallstep.plus_one. apply step_finish. assumption. eassumption. *) +(* constructor; assumption. *) +(* - econstructor; split. apply Smallstep.plus_one. constructor. *) + +(* constructor. constructor. *) +(* - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. *) + +(* apply match_state. assumption. *) +(* Admitted. *) +(* Hint Resolve transl_step_correct : verilogproof. *) + +(* Lemma transl_initial_states : *) +(* forall s1 : Smallstep.state (HTL.semantics prog), *) +(* Smallstep.initial_state (HTL.semantics prog) s1 -> *) +(* exists s2 : Smallstep.state (Verilog.semantics tprog), *) +(* Smallstep.initial_state (Verilog.semantics tprog) s2 /\ match_states s1 s2. *) +(* Proof. *) +(* induction 1. *) +(* econstructor; split. econstructor. *) +(* apply (Genv.init_mem_transf TRANSL); eauto. *) +(* rewrite symbols_preserved. *) +(* replace (AST.prog_main tprog) with (AST.prog_main prog); eauto. *) +(* symmetry; eapply Linking.match_program_main; eauto. *) +(* exploit function_ptr_translated; eauto. intros [tf [A B]]. *) +(* inv B. eauto. *) +(* constructor. *) +(* Qed. *) +(* Hint Resolve transl_initial_states : verilogproof. *) + +(* Lemma transl_final_states : *) +(* forall (s1 : Smallstep.state (HTL.semantics prog)) *) +(* (s2 : Smallstep.state (Verilog.semantics tprog)) *) +(* (r : Integers.Int.int), *) +(* match_states s1 s2 -> *) +(* Smallstep.final_state (HTL.semantics prog) s1 r -> *) +(* Smallstep.final_state (Verilog.semantics tprog) s2 r. *) +(* Proof. *) +(* intros. inv H0. inv H. inv H3. constructor. reflexivity. *) +(* Qed. *) +(* Hint Resolve transl_final_states : verilogproof. *) Theorem transf_program_correct: forward_simulation (HTL.semantics prog) (Verilog.semantics tprog). Proof. - eapply Smallstep.forward_simulation_plus; eauto with verilogproof. - apply senv_preserved. - Qed. + (* eapply Smallstep.forward_simulation_plus; eauto with verilogproof. *) + (* apply senv_preserved. *) + admit. + Admitted. End CORRECTNESS. |