From 3152f71df5efc164efb62984b1ec53dc453fb54c Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 12 Feb 2019 15:40:49 -0500 Subject: [PATCH 001/142] fixing the compilation of Asm.v --- Makefile | 7 ++++++- examples/Asm.v | 9 +++------ 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index efe41bd1..e2443313 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ .PHONY: clean all coq test tests examples install uninstall depgraph \ - example-imp example-lc example-io example-nimp + example-imp example-lc example-io example-nimp example-asm COQPATHFILE=$(wildcard _CoqPath) @@ -35,6 +35,11 @@ example-io: examples/IO.v coqc -Q ../theories/ ITree IO.v && \ ocamlbuild io.native && ./io.native +example-asm: examples/Asm.v + cd examples && \ + coqc -Q ../theories/ ITree Asm.v + + THREADSV=examples/MultiThreadedPrinting.v examples/ExtractThreadsExample.v THREADSML=examples/runthread.ml example-threads: $(THREADSV) $(THREADSML) diff --git a/examples/Asm.v b/examples/Asm.v index f284f0b5..9d5e9d47 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -164,12 +164,9 @@ Instance RelDec_string : RelDec (@eq string) := Instance RelDec_value : RelDec (@eq value) := { rel_dec := Nat.eqb }. (* SAZ: Is this the nicest way to present this? *) -Definition run (p: program) : itree emptyE _ := - let p1 := interp1 interpret_Memory _ (denote_program p) in - let p2 := interp1 interpret_Locals _ p1 in - let p3 := run_env _ p2 empty in - let p4 := run_env _ p3 empty in - p4. +Definition run (p: program) : itree emptyE (env * (memory * unit)) := + let eval := Sum1.elim interpret_Locals interpret_Memory in + run_env _ (run_env _ (interp eval _ (denote_program p)) empty) empty. (* SAZ: Note: we should be able to prove that run produces trees that are equivalent to run' where run' interprets memory and locals in a different order *) From a45bb237253dac783ed0edb61bf572f546cd6d53 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 12 Feb 2019 18:44:37 -0500 Subject: [PATCH 002/142] a compiler from Imp2Asm. --- examples/Imp2Asm.v | 199 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 199 insertions(+) create mode 100644 examples/Imp2Asm.v diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v new file mode 100644 index 00000000..72acb0fe --- /dev/null +++ b/examples/Imp2Asm.v @@ -0,0 +1,199 @@ +From ITree.examples Require Import + Imp Asm. + +Require Import Coq.Strings.String. +Local Open Scope string_scope. + + + + + +(* +Print stmt. + +Fixpoint blocks (s : stmt) (k : Type) : Type := + match s with + | Skip => k + | Assign _ _ => k + | Seq a b => blocks a (blocks b k) + | If e l r => + option (blocks l Empty_set) (* then branch *) + + option (blocks r Empty_set) (* else branch *) + + k (* join point *) + | While e b => + unit (* top of the evaluation of e *) + + option (blocks b Empty_set) (* top of the body *) + + k (* end of the loop *) + end. + +Compute fun e => blocks (Seq (Assign "x" e) (Assign "x" e)) Empty_set. +Compute fun e => + blocks (Seq (Assign "x" e) (If e Skip Skip)) Empty_set. +Compute fun e => + blocks (Seq (Assign "x" e) (If e (While e Skip) Skip)) Empty_set. +Compute fun e => blocks (Seq (Assign "x" e) (Seq (If e (While e Skip) Skip) Skip)) Empty_set. +*) + +Parameter compile_expr : expr -> list instr. +Parameter compile_assign : Imp.var -> expr -> list instr. + +Section after. + Context {a : Type}. + Fixpoint after (is : list instr) (blk : block a) : block a := + match is with + | nil => blk + | i :: is => bbi i (after is blk) + end. +End after. + +Section fmap_block. + Context {a b : Type} (f : a -> b). + Print branch. + Definition fmap_branch (blk : branch a) : branch b := + match blk with + | Bjmp x => Bjmp (f x) + | Bbrz v a b => Bbrz v (f a) (f b) + | Bhalt => Bhalt + end. + + + Fixpoint fmap_block (blk : block a) : block b := + match blk with + | bbb x => bbb (fmap_branch x) + | bbi i blk => bbi i (fmap_block blk) + end. +End fmap_block. + +Record CR {imports : Type} : Type := +{ c_label : Type +; c_main : block (c_label + imports) +; c_blocks : c_label -> block (c_label + imports) +}. +Arguments CR _ : clear implicits. + +Variant WhileBlocks : Set := +| WhileTop +| WhileBottom. + +Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} +: CR L. +refine + match s with + | Skip => + {| c_label := Empty_set + ; c_blocks := fun x => match x with end + ; c_main := fmap_block inr k |} + | Assign x e => + {| c_label := Empty_set + ; c_blocks := fun x => match x with end + ; c_main := after (compile_assign x e) + (fmap_block inr k) |} + | Seq l r => + let rc := @compileCR r L k in + let lc := @compileCR l (sum rc.(c_label) L) rc.(c_main) in + {| c_label := lc.(c_label) + rc.(c_label) + ; c_blocks := fun x => + match x with + | inl x => fmap_block _ (lc.(c_blocks) x) + | inr x => fmap_block _ (rc.(c_blocks) x) + end + ; c_main := + fmap_block _ lc.(c_main) |} + | If e l r => + let lc := @compileCR l L k in + let rc := @compileCR r L k in + let to_right := (fun x => + match x with + | inl y => inl (inr (Some y)) + | inr y => inr y + end) + in + let to_left := (fun x => + match x with + | inl y => inl (inl (Some y)) + | inr y => inr y + end) in + {| c_label := option lc.(c_label) + option rc.(c_label) + ; c_blocks := fun x => + match x with + | inl None => + fmap_block to_left lc.(c_main) + | inl (Some x) => + fmap_block to_left (lc.(c_blocks) x) + | inr None => + fmap_block to_right rc.(c_main) + | inr (Some x) => + fmap_block to_right (rc.(c_blocks) x) + end + ; c_main := + after (compile_assign "_jump_var" e) + (bbb (Bbrz "_jump_var" + (inl (inl None)) + (inl (inr None)))) + |} + | While e b => + let bc := compileCR b unit (bbb (Bjmp tt)) in + {| c_label := WhileBlocks + + option bc.(c_label) + ; c_blocks := + let convert x := + match x with + | inl x => inl (inr (Some x)) + | inr x => inl (inl WhileTop) + end + in fun x => + match x with + | inl WhileTop => (* before evaluating e *) + after (compile_assign "_jump_var" e) + (bbb (Bbrz "_jump_var" + (inl (inr None)) + (inl (inl WhileBottom)))) + | inl WhileBottom => (* after the loop exits *) + fmap_block inr k + | inr None => + fmap_block convert bc.(c_main) + | inr (Some x) => + fmap_block convert (bc.(c_blocks) x) + end + ; c_main := bbb (Bjmp (inl (inl WhileTop))) + |} + end. +all: clear; tauto. +Defined. + + +Definition compile (s : stmt) : program := + let cr := @compileCR s Empty_set (bbb Bhalt) in + {| label := option cr.(c_label) + ; main := None + ; blocks := + let convert (x : _ + Empty_set) := + match x with + | inl x => Some x + | inr x => match x with end + end in + fun x => + match x with + | None => fmap_block convert cr.(c_main) + | Some l => fmap_block convert (cr.(c_blocks) l) + end |}. + +(* something like this... +Lemma compileCR_correct : forall s, + @denote_program ImpEff _ _ (@compile s) = denoteStmt s. +Proof. +*) + + +Compute (compile (Assign "x" (Lit 1))). + +(* +l: x = phi(l1: a, l2: b) ; ... +l1: ... ; jmp l +l2: ... ; jmp l + +l: [x] + .... +l1: ...; jmp[a] +l2: ...; jmp[b] +*) \ No newline at end of file From 5aa7423bb84f1c7c585b21ff4bd0dba11cc2e042 Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 12 Feb 2019 22:29:56 -0500 Subject: [PATCH 003/142] Work over the compiler. Bit of simplification in Imp to line up more easily, bit of cleanup, few notations for some toy examples --- examples/Asm.v | 74 +++++++++++++++ examples/Imp.v | 230 ++++++++++++++------------------------------- examples/Imp2Asm.v | 93 +++++++++--------- 3 files changed, 194 insertions(+), 203 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index 9d5e9d47..7da48153 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -1,4 +1,6 @@ Require Import Coq.Strings.String. +Require Import ZArith. +Typeclasses eauto := 5. Definition var : Set := string. Definition value : Set := nat. (* this should change *) @@ -33,6 +35,19 @@ Record program : Type := ; main : label }. +Module AsmNotations. + + (* TODO *) + Notation "▿ i0 ; .. ; i ; br △" := + (bbi i0 .. (bbi i (bbb br)) ..) + (right associativity). + + Open Scope string_scope. + Definition bar := Imov "x" (Ovar "x"). + Definition foo {label: Type}: @block label := + ▿ bar ; bar ; bar ; Bhalt △. + +End AsmNotations. (* now define a semantics *) @@ -170,3 +185,62 @@ Definition run (p: program) : itree emptyE (env * (memory * unit)) := (* SAZ: Note: we should be able to prove that run produces trees that are equivalent to run' where run' interprets memory and locals in a different order *) + + + +(* +Definition dummy_blk {label: Type}: block label := bbb Bhalt. +Definition arg: string := "arg". +Definition res: string := "res". + +Definition local: string := "R0". + +Section Odd_Even. + + + (* Need to work over Z *) + + Definition even_entry {label: Type}: block label := + bbi (Iload local (Ovar arg)) + (bbb (Bbrz local Eend Ebody)). + Definition even_body {label: Type}: block label := + bbi (Iload local (Ovar arg)) + (bbb (Bbrz local Eend Ebody)). + + + + +End Odd_Even. + +Section Fact. + Definition Fentry := 1. + Definition Fbody := 2. + Definition Fend := 3. + + (* Need to work over Z *) + Definition fact_entry {label: Type} (Fend Fbody: label): block label := + bbi (Iload local (Ovar arg)) + (bbi (Iadd arg arg (Oimm -1) + (bbi (Istore res (Oimm 0)) + (bbb (Bbrz local Fend Fbody))). + + Definition fact_body {label: Type} (Fbody: label): block label := + bbi (Iload local (Ovar arg)) + (bbb (Bbrz local Fend Fbody)). + + + + Definition fact (n: nat): program := + {| + label:= nat; + blocks := fun n => match n with + | 0 => bbi (Istore arg (Oimm n)) (bbb (Bjmp 1)) + | 1 => dummy_blk + | _ => dummy_blk + end; + main := 0 + |}. + +End Fact. +*) + diff --git a/examples/Imp.v b/examples/Imp.v index e47f6269..5cb64cfa 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -39,47 +39,48 @@ Inductive stmt : Set := | If (i : expr) (t e : stmt) (* if (i) then { t } else { e } *) | While (t : expr) (b : stmt) (* while (t) { b } *) | Skip (* ; *) -(* For Calls ******** -| Call (ls : list var) (f : string) (args : list expr) -*) . -(* the "effect" to track local variables *) -Inductive Locals : Type -> Type := -| GetVar (x : var) : Locals value -| SetVar (x : var) (v : value) : Locals unit. +Module ImpNotations. -(* the "effect" to track errors *) -Inductive Error : Type -> Type := -| RuntimeError (_ : string) : Error Empty_set. + Notation "x '←' e" := + (Assign x e) (at level 60, e at level 50). -Definition error {eff} `{Error -< eff} (msg : string) {a} : itree eff a := - x <- lift (RuntimeError msg) ;; - match x : Empty_set with end. + Notation "a ;;; b" := + (Seq a b) + (at level 80, right associativity, + format + "'[v ' a ';;;' '/' '[' b ']' ']'" + ). + Notation "'IF' i 'THEN' t 'ELSE' e" := + (If i t e) + (at level 200, + right associativity, + format + "'[v ' 'IF' i '/' '[' 'THEN' t ']' '/' '[' 'ELSE' e ']' ']'"). -Definition ImpEff : Type -> Type := Locals +' Error. + Notation "'WHILE' t 'DO' b" := + (While t b) + (at level 200, + right associativity, + format + "'[v ' 'WHILE' t '/' '[' 'DO' b ']' ']'"). -(* For Calls ********* -Inductive External : Type -> Type := -| CallExternal (name : string) (ls : list value) : External (list value). + Coercion Lit: nat >-> expr. + Definition Var_coerce: string -> expr := Var. + Coercion Var_coerce: string >-> expr. -Definition ImpEff : Type -> Type := Locals +' (External +' Error). -*) +End ImpNotations. -Section assignMany. - Context {eff : Type -> Type}. - Context {HasLocals : Locals -< eff}. - Context {HasError : Error -< eff}. +Import ImpNotations. - Fixpoint assignMany (ls : list var) (vs : list value) : itree eff unit := - match ls , vs with - | nil , nil => ret tt - | x :: xs , v :: vs => lift (SetVar x v) ;; assignMany xs vs - | nil , _ :: _ => lift (RuntimeError "insufficient binders") ;; ret tt - | _ :: _ , nil => lift (RuntimeError "too many binders") ;; ret tt - end. -End assignMany. +(* the "effect" to track local variables *) +Inductive Locals : Type -> Type := +| GetVar (x : var) : Locals value +| SetVar (x : var) (v : value) : Locals unit. + +Definition ImpEff : Type -> Type := Locals. (* The meaning of an expression *) Fixpoint denoteExpr (e : expr) : itree ImpEff value := @@ -99,152 +100,65 @@ Fixpoint denoteStmt (s : stmt) : itree ImpEff unit := match s with | Assign x e => v <- denoteExpr e ;; - lift (SetVar x v) + lift (SetVar x v) | Seq a b => denoteStmt a ;; denoteStmt b | If i t e => v <- denoteExpr i ;; - if is_true v then denoteStmt t else denoteStmt e + if is_true v then denoteStmt t else denoteStmt e | While t b => while (v <- denoteExpr t ;; - if is_true v - then denoteStmt b ;; ret true - else ret false) + if is_true v + then denoteStmt b ;; ret true + else ret false) | Skip => ret tt -(* For Calls ******** - | Call xs f args => - vals <- mapT denoteExpr args ;; - results <- lift (CallExternal f vals) ;; - assignMany xs results -*) end. (* some simple examples *) -Eval simpl in - denoteStmt (Seq (Assign "x" (Lit 1)) - (Assign "y" (Var "x"))). +Definition ex1: stmt := + "x" ← 1 ;;; + "y" ← "x". +Eval simpl in denoteStmt ex1. -Eval simpl in - denoteStmt (Seq (Assign "x" (Lit 1)) - (While (Var "x") (Assign "x" (Var "x")))). +Definition ex2: stmt := + "x" ← 1 ;;; + WHILE "x" DO + "x" ← "x". +Eval simpl in denoteStmt ex2. -(* Two interpretations of local variable environments - *) -Module ImplicitInit. - Import ITree.Basics.Monads. +From ITree Require Import + Effect.Env. - (* Interpretation of the `Locals` effects using total maps, i.e. - * variables are implicitly initialized to some default value. - * This mirrors the semantics of Imp. - *) - Definition evalLocals {eff} : Locals ~> stateT (var -> value) (itree eff) := - fun _ e st => - match e with - | GetVar x => - ret (st, st x) - | SetVar x v => - ret (fun x' => if string_dec x x' then v else st x', tt) - end. +From ExtLib Require Import + Core.RelDec + Structures.Maps + Data.Map.FMapAList. - Definition init : var -> value := - fun _ => 0. +(* + Note: this is the simple Imp semantics, compared to the C-like semantics: interpretations in term of total maps instead of partial ones. + Make it simpler to map to asm for now. + *) -End ImplicitInit. +Definition evalLocals {E: Type -> Type} `{envE var value -< E}: Locals ~> itree E := + fun _ e => + match e with + | GetVar x => env_lookupDefault x 0 + | SetVar x v => env_add x v + end. +Definition env := alist var value. -Module ExplicitInit. - Import ITree.Basics.Monads. +(* Enable typeclass instances for Maps keyed by strings and values *) +Instance RelDec_string : RelDec (@eq string) := + { rel_dec := fun s1 s2 => if String.string_dec s1 s2 then true else false}. - Definition env := list (var * value). +Definition eval (s: stmt): itree emptyE (env * unit) := + let p := interp evalLocals _ (denoteStmt s) in + run_env _ p empty. - Fixpoint lookup (e : env) (v : string) : option value := - match e with - | nil => None - | (var,val) :: es => - if string_dec var v then Some val else lookup es v - end. +(* some simple examples. Dumb right now, nothing computes *) +Eval unfold ex1 in eval ex1. - Fixpoint set (v : string) (val : value) (e : env) : env := - match e with - | nil => (v, val) :: nil - | (var,val') :: es => - if string_dec var v then (var, val) :: es else (var, val') :: set v val es - end. +Eval simpl in eval ex2. - (* Interpretation of the `Locals` effects using partial maps, i.e. - * variables must be explicitly initialized. - * This mirrors the semantics of C. - *) - Definition evalLocals {eff} `{Error -< eff}: Locals ~> stateT env (itree eff) := - fun _ e st => - match e with - | GetVar x => - match lookup st x with - | None => - error ("variable `" ++ x ++ "` not defined") - | Some v => ret (st, v) - end - | SetVar x v => - ret (set x v st, tt) - end. - - Definition init : env := nil. - -End ExplicitInit. - -Definition evalLocals stmt := - interp_state (into_state ExplicitInit.evalLocals) _ (denoteStmt stmt) ExplicitInit.init. - -(* For Calls ************ -Definition evalLocals stmt := - run_state ExplicitInit.evalLocals (denoteStmt stmt) ExplicitInit.init. -*) -(* some simple examples *) -Eval simpl in - let stmt := Seq (Assign "x" (Lit 1)) - (Assign "y" (Var "x")) in - evalLocals stmt. - -Eval simpl in - let stmt := Seq (Assign "x" (Lit 1)) - (While (Var "x") (Assign "x" (Var "x"))) in - evalLocals stmt. - -(* For Calls ************ -Eval simpl in - let stmt := Seq (Call ("x" :: nil) "print" (Lit 1 :: nil)) - (Assign "y" (Var "x")) in - simplify 1 (evalLocals stmt). - -Module ToTrace. - - Definition Event : Type := (string * list value * list value)%type. - - Section with_oracle. - (* we could add state without much difficulty *) - Variable oracle : string -> list value -> list value. - - Definition evalExternals {eff} - : eff_hom_s (list Event) External eff := - fun _ e st => - match e with - | CallExternal f ls => - let res := oracle f ls in - ret (st ++ (f, ls, res) :: nil, res)%list - end. - End with_oracle. - -End ToTrace. - -Definition evalTrace {eff} {t} (oracle : _) - (it : ITree.itree (External +' eff) t) -: ITree.itree eff (list ToTrace.Event * t) := - run_state (ToTrace.evalExternals oracle) it nil. - -Eval simpl in - let stmt := Seq (Call ("x" :: nil) "print" (Lit 1 :: nil)) - (Assign "y" (Var "x")) in - fun oracle => - simplify 2 (evalTrace oracle (evalLocals stmt)). -*) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 72acb0fe..c9936668 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -1,42 +1,27 @@ -From ITree.examples Require Import - Imp Asm. +Require Import Imp Asm. Require Import Coq.Strings.String. Local Open Scope string_scope. +Import ListNotations. + +Section compile_assign. + + Fixpoint compile_expr (e: expr): list instr := + match e with + | Var x => [Imov "fixme" (Ovar x)] + | Lit n => [Imov "fixme" (Oimm n)] + | Plus e1 e2 => + compile_expr e1 ++ + compile_expr e2 ++ + [Iadd "fixme" "fixme" (Ovar "fixme")] + end. + Definition compile_assign (x: Imp.var) (e: expr): list instr := + let instrs := compile_expr e in + instrs ++ [Imov x (Ovar "fixme")]. - - - -(* -Print stmt. - -Fixpoint blocks (s : stmt) (k : Type) : Type := - match s with - | Skip => k - | Assign _ _ => k - | Seq a b => blocks a (blocks b k) - | If e l r => - option (blocks l Empty_set) (* then branch *) - + option (blocks r Empty_set) (* else branch *) - + k (* join point *) - | While e b => - unit (* top of the evaluation of e *) - + option (blocks b Empty_set) (* top of the body *) - + k (* end of the loop *) - end. - -Compute fun e => blocks (Seq (Assign "x" e) (Assign "x" e)) Empty_set. -Compute fun e => - blocks (Seq (Assign "x" e) (If e Skip Skip)) Empty_set. -Compute fun e => - blocks (Seq (Assign "x" e) (If e (While e Skip) Skip)) Empty_set. -Compute fun e => blocks (Seq (Assign "x" e) (Seq (If e (While e Skip) Skip) Skip)) Empty_set. -*) - -Parameter compile_expr : expr -> list instr. -Parameter compile_assign : Imp.var -> expr -> list instr. - +End compile_assign. + Section after. Context {a : Type}. Fixpoint after (is : list instr) (blk : block a) : block a := @@ -48,7 +33,7 @@ End after. Section fmap_block. Context {a b : Type} (f : a -> b). - Print branch. + Definition fmap_branch (blk : branch a) : branch b := match blk with | Bjmp x => Bjmp (f x) @@ -56,7 +41,6 @@ Section fmap_block. | Bhalt => Bhalt end. - Fixpoint fmap_block (blk : block a) : block b := match blk with | bbb x => bbb (fmap_branch x) @@ -64,30 +48,39 @@ Section fmap_block. end. End fmap_block. +(* CR essentially corresponds to an open (asm) program. + /imports/ encodes the set of external labels to which the program can jump. + c_main is the current entry point. + *) Record CR {imports : Type} : Type := -{ c_label : Type -; c_main : block (c_label + imports) -; c_blocks : c_label -> block (c_label + imports) -}. + { c_label : Type (* Internal labels *) + ; c_main : block (c_label + imports) (* Entry point *) + ; c_blocks : c_label -> block (c_label + imports) (* Other blocks *) + }. Arguments CR _ : clear implicits. Variant WhileBlocks : Set := | WhileTop | WhileBottom. -Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} -: CR L. +(* + Compiles a statement given a partially built continuation 'k' expressed as a block. + *) +Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. refine match s with + | Skip => {| c_label := Empty_set ; c_blocks := fun x => match x with end ; c_main := fmap_block inr k |} + | Assign x e => {| c_label := Empty_set ; c_blocks := fun x => match x with end ; c_main := after (compile_assign x e) (fmap_block inr k) |} + | Seq l r => let rc := @compileCR r L k in let lc := @compileCR l (sum rc.(c_label) L) rc.(c_main) in @@ -99,6 +92,7 @@ refine end ; c_main := fmap_block _ lc.(c_main) |} + | If e l r => let lc := @compileCR l L k in let rc := @compileCR r L k in @@ -161,7 +155,6 @@ refine all: clear; tauto. Defined. - Definition compile (s : stmt) : program := let cr := @compileCR s Empty_set (bbb Bhalt) in {| label := option cr.(c_label) @@ -178,6 +171,18 @@ Definition compile (s : stmt) : program := | Some l => fmap_block convert (cr.(c_blocks) l) end |}. +Section tests. + + Import ImpNotations. + + Definition ex1: stmt := + "x" ← 1. + +Compute (compile ex1). + +End tests. + + (* something like this... Lemma compileCR_correct : forall s, @denote_program ImpEff _ _ (@compile s) = denoteStmt s. @@ -185,8 +190,6 @@ Proof. *) -Compute (compile (Assign "x" (Lit 1))). - (* l: x = phi(l1: a, l2: b) ; ... l1: ... ; jmp l From 36b8dce710d254cf0f591e303e3cf9d0c06c1644 Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 13 Feb 2019 11:57:38 -0500 Subject: [PATCH 004/142] Naive scheme to handle locals --- examples/Imp.v | 6 +- examples/Imp2Asm.v | 271 ++++++++++++++++++++++++++------------------- 2 files changed, 163 insertions(+), 114 deletions(-) diff --git a/examples/Imp.v b/examples/Imp.v index 5cb64cfa..8642557a 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -152,13 +152,13 @@ Definition env := alist var value. Instance RelDec_string : RelDec (@eq string) := { rel_dec := fun s1 s2 => if String.string_dec s1 s2 then true else false}. -Definition eval (s: stmt): itree emptyE (env * unit) := +Definition ImpEval (s: stmt): itree emptyE (env * unit) := let p := interp evalLocals _ (denoteStmt s) in run_env _ p empty. (* some simple examples. Dumb right now, nothing computes *) -Eval unfold ex1 in eval ex1. +Eval unfold ex1 in ImpEval ex1. -Eval simpl in eval ex2. +Eval simpl in ImpEval ex2. diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index c9936668..c8c1160b 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -1,24 +1,35 @@ Require Import Imp Asm. Require Import Coq.Strings.String. -Local Open Scope string_scope. Import ListNotations. Section compile_assign. - Fixpoint compile_expr (e: expr): list instr := + (* YZ: How to handle locals used to compute a composed expression? *) + (* Simply reserve the prefix "local", carry how many have been created, and generate "local_n"? + Rough invariant: instrs = compile_expr_aux k e -> [instrs]σ = σ' -> σ'(gen_local k) = [e] + *) + + (* YZ: Ascii.ascii_of_nat is not what we want, unreadable *) + Definition gen_local (n: nat): string := + "local_" ++ (String (Ascii.ascii_of_nat n) ""). + + (* Compiling mindlessly everything to the stack. Do we want to use asm's heap? *) + Fixpoint compile_expr_aux (l: nat) (e: expr): (list instr * nat) := match e with - | Var x => [Imov "fixme" (Ovar x)] - | Lit n => [Imov "fixme" (Oimm n)] + | Var x => ([Imov (gen_local l) (Ovar x)], S l) + | Lit n => ([Imov (gen_local l) (Oimm n)], S l) | Plus e1 e2 => - compile_expr e1 ++ - compile_expr e2 ++ - [Iadd "fixme" "fixme" (Ovar "fixme")] + let (instrs1, l1) := compile_expr_aux (S l) e1 in + let (instrs2, l2) := compile_expr_aux l1 e2 in + (instrs1 ++ instrs2 ++ [Iadd (gen_local l) (gen_local (S l)) (Ovar (gen_local l1))], S l2) end. + Definition compile_expr e := fst (compile_expr_aux 0 e). + Definition compile_assign (x: Imp.var) (e: expr): list instr := let instrs := compile_expr e in - instrs ++ [Imov x (Ovar "fixme")]. + instrs ++ [Imov x (Ovar (gen_local 0))]. End compile_assign. @@ -66,110 +77,135 @@ Variant WhileBlocks : Set := (* Compiles a statement given a partially built continuation 'k' expressed as a block. *) +(* YZ: Need another generator of fresh variables to store the result of conditionals. + Though they should never be reused if I'm not mistaken, so a unique reserved id as currently is might actually simply do the trick. + To double check. + *) +Open Scope string_scope. Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. -refine - match s with - - | Skip => - {| c_label := Empty_set - ; c_blocks := fun x => match x with end - ; c_main := fmap_block inr k |} - - | Assign x e => - {| c_label := Empty_set - ; c_blocks := fun x => match x with end - ; c_main := after (compile_assign x e) - (fmap_block inr k) |} - - | Seq l r => - let rc := @compileCR r L k in - let lc := @compileCR l (sum rc.(c_label) L) rc.(c_main) in - {| c_label := lc.(c_label) + rc.(c_label) - ; c_blocks := fun x => - match x with - | inl x => fmap_block _ (lc.(c_blocks) x) - | inr x => fmap_block _ (rc.(c_blocks) x) - end - ; c_main := - fmap_block _ lc.(c_main) |} - - | If e l r => - let lc := @compileCR l L k in - let rc := @compileCR r L k in - let to_right := (fun x => - match x with - | inl y => inl (inr (Some y)) - | inr y => inr y - end) - in - let to_left := (fun x => - match x with - | inl y => inl (inl (Some y)) - | inr y => inr y - end) in - {| c_label := option lc.(c_label) + option rc.(c_label) - ; c_blocks := fun x => - match x with - | inl None => - fmap_block to_left lc.(c_main) - | inl (Some x) => - fmap_block to_left (lc.(c_blocks) x) - | inr None => - fmap_block to_right rc.(c_main) - | inr (Some x) => - fmap_block to_right (rc.(c_blocks) x) - end - ; c_main := - after (compile_assign "_jump_var" e) - (bbb (Bbrz "_jump_var" - (inl (inl None)) - (inl (inr None)))) - |} - | While e b => - let bc := compileCR b unit (bbb (Bjmp tt)) in - {| c_label := WhileBlocks - + option bc.(c_label) - ; c_blocks := - let convert x := - match x with - | inl x => inl (inr (Some x)) - | inr x => inl (inl WhileTop) - end - in fun x => - match x with - | inl WhileTop => (* before evaluating e *) - after (compile_assign "_jump_var" e) - (bbb (Bbrz "_jump_var" - (inl (inr None)) - (inl (inl WhileBottom)))) - | inl WhileBottom => (* after the loop exits *) - fmap_block inr k - | inr None => - fmap_block convert bc.(c_main) - | inr (Some x) => - fmap_block convert (bc.(c_blocks) x) - end - ; c_main := bbb (Bjmp (inl (inl WhileTop))) - |} - end. -all: clear; tauto. + refine + match s with + + | Skip => + + {| c_label := Empty_set + ; c_blocks := fun x => match x with end + ; c_main := fmap_block inr k |} + + | Assign x e => + + {| c_label := Empty_set + ; c_blocks := fun x => match x with end + ; c_main := after (compile_assign x e) + (fmap_block inr k) |} + + | Seq l r => + let reassoc := + (fun x => match x with + | inl x => inl (inl x) + | inr (inl x) => inl (inr x) + | inr (inr x) => inr x + end) + in + let to_right := + (fun x => match x with + | inl x => inl (inr x) + | inr x => inr x + end) + in + + let rc := @compileCR r L k in + let lc := @compileCR l (sum rc.(c_label) L) rc.(c_main) in + + {| c_label := lc.(c_label) + rc.(c_label) + ; c_blocks := fun x => + match x with + | inl x => fmap_block reassoc (lc.(c_blocks) x) + | inr x => fmap_block to_right (rc.(c_blocks) x) + end + ; c_main := + fmap_block reassoc lc.(c_main) |} + + | If e l r => + let to_right := (fun x => + match x with + | inl y => inl (inr (Some y)) + | inr y => inr y + end) + in + let to_left := (fun x => + match x with + | inl y => inl (inl (Some y)) + | inr y => inr y + end) + in + let lc := @compileCR l L k in + let rc := @compileCR r L k in + + {| c_label := option lc.(c_label) + option rc.(c_label) + ; c_blocks := fun x => + match x with + | inl None => + fmap_block to_left lc.(c_main) + | inl (Some x) => + fmap_block to_left (lc.(c_blocks) x) + | inr None => + fmap_block to_right rc.(c_main) + | inr (Some x) => + fmap_block to_right (rc.(c_blocks) x) + end + ; c_main := + after (compile_assign "_jump_var" e) + (bbb (Bbrz "_jump_var" + (inl (inl None)) + (inl (inr None)))) + |} + + | While e b => + let bc := compileCR b unit (bbb (Bjmp tt)) in + {| c_label := WhileBlocks + + option bc.(c_label) + ; c_blocks := + let convert x := + match x with + | inl x => inl (inr (Some x)) + | inr x => inl (inl WhileTop) + end + in fun x => + match x with + | inl WhileTop => (* before evaluating e *) + after (compile_assign "_jump_var" e) + (bbb (Bbrz "_jump_var" + (inl (inr None)) + (inl (inl WhileBottom)))) + | inl WhileBottom => (* after the loop exits *) + fmap_block inr k + | inr None => + fmap_block convert bc.(c_main) + | inr (Some x) => + fmap_block convert (bc.(c_blocks) x) + end + ; c_main := bbb (Bjmp (inl (inl WhileTop))) + |} + + end. Defined. Definition compile (s : stmt) : program := let cr := @compileCR s Empty_set (bbb Bhalt) in {| label := option cr.(c_label) - ; main := None - ; blocks := - let convert (x : _ + Empty_set) := + ; main := None + ; blocks := + let convert (x : _ + Empty_set) := + match x with + | inl x => Some x + | inr x => match x with end + end in + fun x => match x with - | inl x => Some x - | inr x => match x with end - end in - fun x => - match x with - | None => fmap_block convert cr.(c_main) - | Some l => fmap_block convert (cr.(c_blocks) l) - end |}. + | None => fmap_block convert cr.(c_main) + | Some l => fmap_block convert (cr.(c_blocks) l) + end |}. Section tests. @@ -178,16 +214,29 @@ Section tests. Definition ex1: stmt := "x" ← 1. -Compute (compile ex1). + (* The result is a bit annoying to read in that it keeps around absurd branches *) + Compute (compile ex1). + + Definition ex_cond: stmt := + "x" ← 1;;; + IF "x" + THEN "res" ← 2 + ELSE "res" ← 3. + + Compute (compile ex_cond). End tests. +From ITree Require Import + ITree. + +Section Correctness. + + (* Missing a Locals -< ImpEff instance, got me confused, I'll get back to it later. *) + Fail Theorem compile_correct: + forall s, denote_program (compile s) ~~ denoteStmt s. -(* something like this... -Lemma compileCR_correct : forall s, - @denote_program ImpEff _ _ (@compile s) = denoteStmt s. -Proof. -*) +End Correctness. (* From 3a26b8fa199085c9b07dd5cdd26d4484d604f826 Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 13 Feb 2019 17:05:14 -0500 Subject: [PATCH 005/142] Changed representation of Asm programs and formulated theorems that actually type check --- examples/Asm.v | 47 ++++++++++-------- examples/Imp.v | 91 ++++++++++++++++++---------------- examples/Imp2Asm.v | 119 ++++++++++++++++++++++----------------------- 3 files changed, 132 insertions(+), 125 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index 7da48153..5a0f34d1 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -29,11 +29,12 @@ Inductive block {label : Type} : Type := | bbb (_ : branch label). Arguments block _ : clear implicits. -Record program : Type := -{ label : Type -; blocks : label -> block label -; main : label -}. +Record program {imports : Type} : Type := + { label : Type (* Internal labels *) + ; main : block (label + imports) (* Entry point *) + ; blocks : label -> block (label + imports) (* Other blocks *) + }. +Arguments program _ : clear implicits. Module AsmNotations. @@ -58,10 +59,7 @@ Require Import ExtLib.Structures.Monad. Import MonadNotation. Local Open Scope monad_scope. -(* the "effect" to track local variables *) -Inductive Locals : Type -> Type := -| GetVar (x : var) : Locals value -| SetVar (x : var) (v : value) : Locals unit. +Require Import Imp. Inductive Memory : Type -> Type := | Load (addr : value) : Memory value @@ -122,16 +120,25 @@ Section with_effect. End with_labels. End with_effect. -Definition denote_program {e} `{Locals -< e} `{Memory -< e} - (p : program) : itree e unit := +Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} + (p : program L) (imports: L -> itree e unit) : p.(label) -> itree e unit := rec (fun lbl : p.(label) => - next <- denote_block (_ +' e) (p.(blocks) lbl) ;; - match next with - | None => ret tt - | Some next => lift (Call next) - end) - p.(main). - + next <- denote_block (_ +' e) (p.(blocks) lbl) ;; + match next with + | None => ret tt + | Some (inl next) => lift (Call next) + | Some (inr next) => translate (@inr1 _ _) _ (imports next) + end). + +Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} + (p : program L) (imports: L -> itree e unit) : itree e unit := + next <- denote_block e p.(main) ;; + match next with + | None => ret tt + | Some (inl next) => denote_program p imports next + | Some (inr next) => imports next + end. + (* SAZ: Everything from here down can probably be polished. In particular, I'm still not completely happy with how all the different parts @@ -179,9 +186,9 @@ Instance RelDec_string : RelDec (@eq string) := Instance RelDec_value : RelDec (@eq value) := { rel_dec := Nat.eqb }. (* SAZ: Is this the nicest way to present this? *) -Definition run (p: program) : itree emptyE (env * (memory * unit)) := +Definition run (p: program Empty_set) : itree emptyE (env * (memory * unit)) := let eval := Sum1.elim interpret_Locals interpret_Memory in - run_env _ (run_env _ (interp eval _ (denote_program p)) empty) empty. + run_env _ (run_env _ (interp eval _ (denote_main p (fun x => match x with end))) empty) empty. (* SAZ: Note: we should be able to prove that run produces trees that are equivalent to run' where run' interprets memory and locals in a different order *) diff --git a/examples/Imp.v b/examples/Imp.v index 8642557a..c0fa9793 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -80,51 +80,56 @@ Inductive Locals : Type -> Type := | GetVar (x : var) : Locals value | SetVar (x : var) (v : value) : Locals unit. -Definition ImpEff : Type -> Type := Locals. - -(* The meaning of an expression *) -Fixpoint denoteExpr (e : expr) : itree ImpEff value := - match e with - | Var v => lift (GetVar v) - | Lit n => ret n - | Plus a b => l <- denoteExpr a ;; r <- denoteExpr b ;; ret (l + r) - end. +Section Denote. -Definition while {eff} (t : itree eff bool) : itree eff unit := - rec (fun _ : unit => - continue <- translate (fun _ x => inr1 x) _ t ;; - if continue : bool then lift (Call tt) else Monad.ret tt) tt. - -(* the meaning of a statement *) -Fixpoint denoteStmt (s : stmt) : itree ImpEff unit := - match s with - | Assign x e => - v <- denoteExpr e ;; - lift (SetVar x v) - | Seq a b => - denoteStmt a ;; denoteStmt b - | If i t e => - v <- denoteExpr i ;; - if is_true v then denoteStmt t else denoteStmt e - | While t b => - while (v <- denoteExpr t ;; - if is_true v - then denoteStmt b ;; ret true - else ret false) - | Skip => ret tt - end. + Context {eff : Type -> Type}. + Context {HasLocals : Locals -< eff}. + + (* The meaning of an expression *) + Fixpoint denoteExpr (e : expr) : itree eff value := + match e with + | Var v => lift (GetVar v) + | Lit n => ret n + | Plus a b => l <- denoteExpr a ;; r <- denoteExpr b ;; ret (l + r) + end. + + Definition while {eff} (t : itree eff bool) : itree eff unit := + rec (fun _ : unit => + continue <- translate (fun _ x => inr1 x) _ t ;; + if continue : bool then lift (Call tt) else Monad.ret tt) tt. + + (* the meaning of a statement *) + Fixpoint denoteStmt (s : stmt) : itree eff unit := + match s with + | Assign x e => + v <- denoteExpr e ;; + lift (SetVar x v) + | Seq a b => + denoteStmt a ;; denoteStmt b + | If i t e => + v <- denoteExpr i ;; + if is_true v then denoteStmt t else denoteStmt e + | While t b => + while (v <- denoteExpr t ;; + if is_true v + then denoteStmt b ;; ret true + else ret false) + | Skip => ret tt + end. + +End Denote. + + (* some simple examples *) + Definition ex1: stmt := + "x" ← 1 ;;; + "y" ← "x". + Eval simpl in denoteStmt ex1. -(* some simple examples *) -Definition ex1: stmt := - "x" ← 1 ;;; - "y" ← "x". -Eval simpl in denoteStmt ex1. - -Definition ex2: stmt := - "x" ← 1 ;;; - WHILE "x" DO - "x" ← "x". -Eval simpl in denoteStmt ex2. + Definition ex2: stmt := + "x" ← 1 ;;; + WHILE "x" DO + "x" ← "x". + Eval simpl in denoteStmt ex2. From ITree Require Import Effect.Env. diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index c8c1160b..85a2c594 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -6,8 +6,9 @@ Import ListNotations. Section compile_assign. (* YZ: How to handle locals used to compute a composed expression? *) - (* Simply reserve the prefix "local", carry how many have been created, and generate "local_n"? - Rough invariant: instrs = compile_expr_aux k e -> [instrs]σ = σ' -> σ'(gen_local k) = [e] + (* + Simply reserve the prefix "local", carry how many have been created, and generate "local_n"? + Rough invariant: instrs = compile_expr_aux k e -> [instrs]σ = σ' -> σ'(gen_local k) = [e] *) (* YZ: Ascii.ascii_of_nat is not what we want, unreadable *) @@ -59,17 +60,6 @@ Section fmap_block. end. End fmap_block. -(* CR essentially corresponds to an open (asm) program. - /imports/ encodes the set of external labels to which the program can jump. - c_main is the current entry point. - *) -Record CR {imports : Type} : Type := - { c_label : Type (* Internal labels *) - ; c_main : block (c_label + imports) (* Entry point *) - ; c_blocks : c_label -> block (c_label + imports) (* Other blocks *) - }. -Arguments CR _ : clear implicits. - Variant WhileBlocks : Set := | WhileTop | WhileBottom. @@ -82,21 +72,21 @@ Variant WhileBlocks : Set := To double check. *) Open Scope string_scope. -Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. +Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. refine match s with | Skip => - {| c_label := Empty_set - ; c_blocks := fun x => match x with end - ; c_main := fmap_block inr k |} + {| label := Empty_set + ; blocks := fun x => match x with end + ; main := fmap_block inr k |} | Assign x e => - {| c_label := Empty_set - ; c_blocks := fun x => match x with end - ; c_main := after (compile_assign x e) + {| label := Empty_set + ; blocks := fun x => match x with end + ; main := after (compile_assign x e) (fmap_block inr k) |} | Seq l r => @@ -114,17 +104,17 @@ Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. end) in - let rc := @compileCR r L k in - let lc := @compileCR l (sum rc.(c_label) L) rc.(c_main) in + let rc := @compile r L k in + let lc := @compile l (sum rc.(label) L) rc.(main) in - {| c_label := lc.(c_label) + rc.(c_label) - ; c_blocks := fun x => + {| label := lc.(label) + rc.(label) + ; blocks := fun x => match x with - | inl x => fmap_block reassoc (lc.(c_blocks) x) - | inr x => fmap_block to_right (rc.(c_blocks) x) + | inl x => fmap_block reassoc (lc.(blocks) x) + | inr x => fmap_block to_right (rc.(blocks) x) end - ; c_main := - fmap_block reassoc lc.(c_main) |} + ; main := + fmap_block reassoc lc.(main) |} | If e l r => let to_right := (fun x => @@ -139,22 +129,22 @@ Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. | inr y => inr y end) in - let lc := @compileCR l L k in - let rc := @compileCR r L k in + let lc := @compile l L k in + let rc := @compile r L k in - {| c_label := option lc.(c_label) + option rc.(c_label) - ; c_blocks := fun x => + {| label := option lc.(label) + option rc.(label) + ; blocks := fun x => match x with | inl None => - fmap_block to_left lc.(c_main) + fmap_block to_left lc.(main) | inl (Some x) => - fmap_block to_left (lc.(c_blocks) x) + fmap_block to_left (lc.(blocks) x) | inr None => - fmap_block to_right rc.(c_main) + fmap_block to_right rc.(main) | inr (Some x) => - fmap_block to_right (rc.(c_blocks) x) + fmap_block to_right (rc.(blocks) x) end - ; c_main := + ; main := after (compile_assign "_jump_var" e) (bbb (Bbrz "_jump_var" (inl (inl None)) @@ -162,10 +152,10 @@ Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. |} | While e b => - let bc := compileCR b unit (bbb (Bjmp tt)) in - {| c_label := WhileBlocks - + option bc.(c_label) - ; c_blocks := + let bc := compile b unit (bbb (Bjmp tt)) in + {| label := WhileBlocks + + option bc.(label) + ; blocks := let convert x := match x with | inl x => inl (inr (Some x)) @@ -181,32 +171,16 @@ Fixpoint compileCR (s : stmt) {L} (k : block L) {struct s} : CR L. | inl WhileBottom => (* after the loop exits *) fmap_block inr k | inr None => - fmap_block convert bc.(c_main) + fmap_block convert bc.(main) | inr (Some x) => - fmap_block convert (bc.(c_blocks) x) + fmap_block convert (bc.(blocks) x) end - ; c_main := bbb (Bjmp (inl (inl WhileTop))) + ; main := bbb (Bjmp (inl (inl WhileTop))) |} end. Defined. -Definition compile (s : stmt) : program := - let cr := @compileCR s Empty_set (bbb Bhalt) in - {| label := option cr.(c_label) - ; main := None - ; blocks := - let convert (x : _ + Empty_set) := - match x with - | inl x => Some x - | inr x => match x with end - end in - fun x => - match x with - | None => fmap_block convert cr.(c_main) - | Some l => fmap_block convert (cr.(c_blocks) l) - end |}. - Section tests. Import ImpNotations. @@ -232,9 +206,30 @@ From ITree Require Import Section Correctness. + (* + If the source level is non-deterministic, for instance order of add, the compiler could pick an order and the correctness would be a refinement. + How to define it? In term of interpreters? + In term of oracle + *) + + (* Add a print effect? *) + + (* + Change languages to map two notions of state at the source down to a single one at the target? + Make the keys of the second env monad as the sum of the two initial ones. + *) + (* Missing a Locals -< ImpEff instance, got me confused, I'll get back to it later. *) - Fail Theorem compile_correct: - forall s, denote_program (compile s) ~~ denoteStmt s. + + Lemma compile_correct_program: + forall s L b imports l, + @denote_program _ _ _ L (compile s b) imports l ~~ (denoteStmt s;; denote_block _ b;; Ret tt). + Admitted. + + Theorem compile_correct: + forall s, @denote_main _ _ _ Empty_set (compile s (bbb Bhalt)) (fun x => match x with end) ~~ denoteStmt s. + Proof. + Admitted. End Correctness. From bab4a059971211bfb58cc062909d7828a967c7ab Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 15 Feb 2019 11:16:51 -0500 Subject: [PATCH 006/142] Work in progress on the compiler. Committing messy state to work on it with SZ. Note: need to interpret away the state before proving eutt --- examples/Imp2Asm.v | 204 ++++++++++++++++++++++++++++++++++++++++++--- theories/Eq/Eq.v | 10 +++ 2 files changed, 201 insertions(+), 13 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 85a2c594..a79b0575 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -207,28 +207,206 @@ From ITree Require Import Section Correctness. (* - If the source level is non-deterministic, for instance order of add, the compiler could pick an order and the correctness would be a refinement. - How to define it? In term of interpreters? - In term of oracle + Potential extensions for later: + - Add some non-determinism at the source level, for instance order of evaluation in add, and have the compiler an order. + The correctness would then be a refinement. + How to define it? Likely with respect to an oracle. + - Add a print effect? + - Change languages to map two notions of state at the source down to a single one at the target? + Make the keys of the second env monad as the sum of the two initial ones. *) - (* Add a print effect? *) + Arguments denote_program {_ _ _}. - (* - Change languages to map two notions of state at the source down to a single one at the target? - Make the keys of the second env monad as the sum of the two initial ones. - *) + Import ITree.Core. - (* Missing a Locals -< ImpEff instance, got me confused, I'll get back to it later. *) + Variable E: Type -> Type. + Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. + + Lemma fmap_block_map: + forall {L L'} b (f: L -> L'), + denote_block E (fmap_block f b) ~~ ITree.map (option_map f) (denote_block E b). + Proof. + induction b as [i b | br]; intros f. + - simpl. + unfold ITree.map; rewrite bind_bind. + eapply eutt_bind; [reflexivity | intros []; apply IHb]. + - simpl. + destruct br; simpl. + + unfold ITree.map; rewrite ret_bind; reflexivity. + + unfold ITree.map; rewrite bind_bind. + eapply eutt_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + + unfold ITree.map; rewrite ret_bind; reflexivity. + Qed. + + Require Import ExtLib.Structures.Monad. + + Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := + fix traverse__ l: M unit := + match l with + | [] => ret tt + | a::l => f a;; traverse__ l + end. + + Definition denote_list: list instr -> itree E unit := + traverse_ (denote_instr E). + + Lemma denote_after_denote_list: + forall {label: Type} instrs (b: block label), + denote_block E (after instrs b) ~~ (denote_list instrs ;; denote_block E b). + Proof. + induction instrs as [| i instrs IH]; intros b. + - simpl; rewrite ret_bind; reflexivity. + - simpl; rewrite bind_bind. + eapply eutt_bind; [reflexivity | intros []; apply IH]. + Qed. + + Lemma denote_compile_assign : + forall x e, + denote_list (compile_assign x e) ~~ ITree.bind (denoteExpr e) (fun v : Imp.value => lift (SetVar x v)). + Proof. + (* induction e. *) + (* - simpl; rewrite bind_bind. *) + (* eapply eutt_bind; [reflexivity | intros ?]. *) + (** + This is wrong. They are not eutt since of course the compiled program does more SetVar actions than +the source. + **) + Admitted. + + (* NB: I think that notations defined in Core are binding the monadic bind instead of the itree one, + hence why they do not show up here *) Lemma compile_correct_program: - forall s L b imports l, - @denote_program _ _ _ L (compile s b) imports l ~~ (denoteStmt s;; denote_block _ b;; Ret tt). - Admitted. + forall s L (b: block L) imports, + denote_main (compile s b) imports ~~ + (denoteStmt s;; ml <- denote_block _ b;; + (match ml with + | None => Ret tt + | Some l => imports l + end)). + Proof. +(* simpl. + induction s; intros L b imports. + 5:{ + unfold denote_main; simpl. + rewrite ret_bind, fmap_block_map, map_bind. + eapply eutt_bind; [reflexivity |]. + intros [? |]; simpl; reflexivity. + } + { + unfold denote_main; simpl. + rewrite denote_after_denote_list; simpl. + rewrite bind_bind. + eapply eutt_bind. + - apply denote_compile_assign. + - intros ?; simpl. + rewrite fmap_block_map, map_bind; simpl. + eapply eutt_bind; [reflexivity|]. + intros [?|]; simpl; reflexivity. + } + { + simpl denoteStmt. + specialize (IHs2 L b imports). + match goal with + | |- _ ~~ ?x => generalize x + end. + intros t. + match goal with + | h: _ ~~ ?x |- _ => revert h; generalize x + end; intros t' h. + unfold denote_main in *. +*) + - Theorem compile_correct: +(* + simpl in IHs2. + + simpl bind. + intro p; subst p. + rewrite bind_bind. + denote_main (compile (Seq s1 s2) b) imports = + denote_main (compile s1 ?) ?;; denote_main (compile s2 b) imports + rewrite <- IHs2. + unfold denote_main. simpl. + rewrite bind_bind. + rewrite fmap_block_map, map_bind; simpl. + match goal with + | |- ITree.bind _ ?x ~~ ITree.bind _ ?y => set (goal1 := x); set (goal2 := y) + end. + (main (compile s2 b))). + specialize (IHs1 _ (main (compile s2 b))). + unfold denote_main in IHs1; simpl in IHs1. + eapply eutt_bind. + assert ( +(fun next : option (label (compile s1 (main (compile s2 b))) + label (compile s2 b) + L) => + match next with + | Some (inl next0) => + denote_program L + {| + label := label (compile s1 (main (compile s2 b))) + label (compile s2 b); + main := fmap_block + (fun x : label (compile s1 (main (compile s2 b))) + (label (compile s2 b) + L) => + match x with + | inl x0 => inl (inl x0) + | inr (inl x0) => inl (inr x0) + | inr (inr x0) => inr x0 + end) (main (compile s1 (main (compile s2 b)))); + blocks := fun x : label (compile s1 (main (compile s2 b))) + label (compile s2 b) => + match x with + | inl x0 => + fmap_block + (fun x1 : label (compile s1 (main (compile s2 b))) + (label (compile s2 b) + L) => + match x1 with + | inl x2 => inl (inl x2) + | inr (inl x2) => inl (inr x2) + | inr (inr x2) => inr x2 + end) (blocks (compile s1 (main (compile s2 b))) x0) + | inr x0 => + fmap_block + (fun x1 : label (compile s2 b) + L => + match x1 with + | inl x2 => inl (inr x2) + | inr x2 => inr x2 + end) (blocks (compile s2 b) x0) + end |} imports next0 + | Some (inr next0) => imports next0 + | None => Ret tt + end) = 2). + + + - simpl. + unfold denote_main. + simpl denoteStmt. + simpl main; simpl compile_assign. + + - + unfold denote_main. simpl in *. + simpl. + + intros. + unfold denote_main. + induction s; intros L b imports l; simpl in * |-. + - elim l. + - simpl denoteStmt. + + + simpl compile. + +*) +Admitted. + + Theorem compile_correct: forall s, @denote_main _ _ _ Empty_set (compile s (bbb Bhalt)) (fun x => match x with end) ~~ denoteStmt s. Proof. +(* intros stmt. + unfold denote_main. + transitivity (@denoteStmt (Locals +' Memory) _ stmt;; Ret tt). + { + eapply eutt_bind; [reflexivity | intros []]. + simpl. +*) + Admitted. End Correctness. diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index f9be81a0..ee68fb40 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -289,6 +289,16 @@ Proof. pupto2_final. eauto with refl. Qed. +Lemma map_bind {E R S T}: forall (f : R -> S) (k: S -> itree E T) (t : itree E R), + ITree.bind (ITree.map f t) k ≅ ITree.bind t (fun x => k (f x)). +Proof. + unfold ITree.map. intros. + pupto2_init. rewrite bind_bind. + pupto2 eq_itree_clo_bind. econstructor; eauto with refl. + intros. rewrite ret_bind. + pupto2_final. eauto with refl. +Qed. + (* Import Hom. From 89e039d41dda7d83fa0233c4a7e97debaebc865a Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 15 Feb 2019 14:08:51 -0500 Subject: [PATCH 007/142] WIP --- examples/Imp2Asm.v | 175 +++++++++++++++++++-------------------------- 1 file changed, 73 insertions(+), 102 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index a79b0575..db9cc998 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -240,6 +240,8 @@ Section Correctness. Qed. Require Import ExtLib.Structures.Monad. + From ITree Require Import + Effect.Env. Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := fix traverse__ l: M unit := @@ -265,11 +267,11 @@ Section Correctness. forall x e, denote_list (compile_assign x e) ~~ ITree.bind (denoteExpr e) (fun v : Imp.value => lift (SetVar x v)). Proof. - (* induction e. *) - (* - simpl; rewrite bind_bind. *) - (* eapply eutt_bind; [reflexivity | intros ?]. *) - (** - This is wrong. They are not eutt since of course the compiled program does more SetVar actions than + (* induction e. + - simpl; rewrite bind_bind. + eapply eutt_bind; [reflexivity | intros ?]. *) + (** + YZ: This lemma is wrong. They are not eutt since of course the compiled program does more SetVar actions than the source. **) Admitted. @@ -277,6 +279,29 @@ the source. (* NB: I think that notations defined in Core are binding the monadic bind instead of the itree one, hence why they do not show up here *) + (* Lemma denote_conditional: *) + (* forall i, *) + (* denote_block E (after (compile_assign "_jump_var" i) (bbb (Bbrz "_jump_var" (inl (inl None)) (inl (inr None))))) ~~ denoteExpr i. *) + +From ExtLib Require Import + Core.RelDec + Structures.Maps + Data.Map.FMapAList. + + (* + This statement does not hold. We need to handle the environment. + We want something closer to this kind: + +Lemma true_compile_correct_program: + forall s L (b: block L) imports, + run_env unit (denote_main (compile s b) imports) empty ~~ + run_env unit (denoteStmt s;; ml <- denote_block _ b;; + (match ml with + | None => Ret tt + | Some l => imports l + end)) empty. + + *) Lemma compile_correct_program: forall s L (b: block L) imports, denote_main (compile s b) imports ~~ @@ -286,114 +311,60 @@ the source. | Some l => imports l end)). Proof. -(* simpl. + simpl. induction s; intros L b imports. - 5:{ - unfold denote_main; simpl. - rewrite ret_bind, fmap_block_map, map_bind. - eapply eutt_bind; [reflexivity |]. - intros [? |]; simpl; reflexivity. - } - { - unfold denote_main; simpl. + + - unfold denote_main; simpl. rewrite denote_after_denote_list; simpl. rewrite bind_bind. eapply eutt_bind. - - apply denote_compile_assign. - - intros ?; simpl. + + apply denote_compile_assign. + + intros ?; simpl. rewrite fmap_block_map, map_bind; simpl. eapply eutt_bind; [reflexivity|]. intros [?|]; simpl; reflexivity. - } - { - simpl denoteStmt. - specialize (IHs2 L b imports). - match goal with - | |- _ ~~ ?x => generalize x - end. - intros t. - match goal with - | h: _ ~~ ?x |- _ => revert h; generalize x - end; intros t' h. - unfold denote_main in *. -*) - - -(* - simpl in IHs2. - - simpl bind. - intro p; subst p. - rewrite bind_bind. - denote_main (compile (Seq s1 s2) b) imports = - denote_main (compile s1 ?) ?;; denote_main (compile s2 b) imports - rewrite <- IHs2. - unfold denote_main. simpl. - rewrite bind_bind. - rewrite fmap_block_map, map_bind; simpl. - match goal with - | |- ITree.bind _ ?x ~~ ITree.bind _ ?y => set (goal1 := x); set (goal2 := y) - end. - (main (compile s2 b))). - specialize (IHs1 _ (main (compile s2 b))). - unfold denote_main in IHs1; simpl in IHs1. - eapply eutt_bind. - assert ( -(fun next : option (label (compile s1 (main (compile s2 b))) + label (compile s2 b) + L) => - match next with - | Some (inl next0) => - denote_program L - {| - label := label (compile s1 (main (compile s2 b))) + label (compile s2 b); - main := fmap_block - (fun x : label (compile s1 (main (compile s2 b))) + (label (compile s2 b) + L) => - match x with - | inl x0 => inl (inl x0) - | inr (inl x0) => inl (inr x0) - | inr (inr x0) => inr x0 - end) (main (compile s1 (main (compile s2 b)))); - blocks := fun x : label (compile s1 (main (compile s2 b))) + label (compile s2 b) => - match x with - | inl x0 => - fmap_block - (fun x1 : label (compile s1 (main (compile s2 b))) + (label (compile s2 b) + L) => - match x1 with - | inl x2 => inl (inl x2) - | inr (inl x2) => inl (inr x2) - | inr (inr x2) => inr x2 - end) (blocks (compile s1 (main (compile s2 b))) x0) - | inr x0 => - fmap_block - (fun x1 : label (compile s2 b) + L => - match x1 with - | inl x2 => inl (inr x2) - | inr x2 => inr x2 - end) (blocks (compile s2 b) x0) - end |} imports next0 - | Some (inr next0) => imports next0 - | None => Ret tt - end) = 2). - - - - simpl. - unfold denote_main. + + - simpl denoteStmt. + specialize (IHs2 L b imports). + unfold denote_main; simpl denote_block; rewrite fmap_block_map. + unfold bind at 1, Monad_itree; rewrite map_bind. + rewrite bind_bind. + etransitivity. + 2:{ + eapply eutt_bind; [reflexivity |]. + intros ?; apply IHs2. + } + clear IHs2. + unfold denote_main. + set (imports' := (fun l => match l with + | inr l => imports l + | inl l => denote_program _ (compile s2 b) imports l + end)). + specialize (IHs1 _ (main (compile s2 b)) imports'). + rewrite <- IHs1. + unfold denote_main. + apply eutt_bind; [reflexivity | ]. + intros [?|]; [| reflexivity]. + simpl option_map. + destruct s as [s | [s | s]]; [| | reflexivity]. + + admit. + + admit. + + - specialize (IHs1 L b imports). + specialize (IHs2 L b imports). simpl denoteStmt. - simpl main; simpl compile_assign. - - - - unfold denote_main. simpl in *. + rewrite bind_bind. + unfold denote_main. simpl. + admit. - intros. - unfold denote_main. - induction s; intros L b imports l; simpl in * |-. - - elim l. - - simpl denoteStmt. - - - simpl compile. + - admit. -*) + - unfold denote_main; simpl. + rewrite ret_bind, fmap_block_map, map_bind. + eapply eutt_bind; [reflexivity |]. + intros [? |]; simpl; reflexivity. + Admitted. Theorem compile_correct: From 5153c1d9921cd4dddf2626abe809afd55e0d6b46 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Fri, 15 Feb 2019 18:17:41 -0500 Subject: [PATCH 008/142] some more sketching of the proof + heterogenous eutt --- examples/Imp2Asm.v | 211 +++++--- theories/Eq/UpToTausH.v | 1004 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 1161 insertions(+), 54 deletions(-) create mode 100644 theories/Eq/UpToTausH.v diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index db9cc998..aecbd738 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -16,24 +16,22 @@ Section compile_assign. "local_" ++ (String (Ascii.ascii_of_nat n) ""). (* Compiling mindlessly everything to the stack. Do we want to use asm's heap? *) - Fixpoint compile_expr_aux (l: nat) (e: expr): (list instr * nat) := + Fixpoint compile_expr (l: nat) (e: expr): list instr := match e with - | Var x => ([Imov (gen_local l) (Ovar x)], S l) - | Lit n => ([Imov (gen_local l) (Oimm n)], S l) + | Var x => [Imov (gen_local l) (Ovar x)] + | Lit n => [Imov (gen_local l) (Oimm n)] | Plus e1 e2 => - let (instrs1, l1) := compile_expr_aux (S l) e1 in - let (instrs2, l2) := compile_expr_aux l1 e2 in - (instrs1 ++ instrs2 ++ [Iadd (gen_local l) (gen_local (S l)) (Ovar (gen_local l1))], S l2) + let instrs1 := compile_expr l e1 in + let instrs2 := compile_expr (S l) e2 in + instrs1 ++ instrs2 ++ [Iadd (gen_local l) (gen_local l) (Ovar (gen_local (S l)))] end. - Definition compile_expr e := fst (compile_expr_aux 0 e). - Definition compile_assign (x: Imp.var) (e: expr): list instr := - let instrs := compile_expr e in + let instrs := compile_expr 0 e in instrs ++ [Imov x (Ovar (gen_local 0))]. End compile_assign. - + Section after. Context {a : Type}. Fixpoint after (is : list instr) (blk : block a) : block a := @@ -72,6 +70,12 @@ Variant WhileBlocks : Set := To double check. *) Open Scope string_scope. +(* we could change this to `stmt -> program unit` and then compile the subterms + * and then replace some of the jumps to do the actual linking. + * + * the type of `program` can not be printed because the type of labels is + * exitentially quantified. it could be replaced with a finite map. + *) Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. refine match s with @@ -90,6 +94,7 @@ Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. (fmap_block inr k) |} | Seq l r => + let reassoc := (fun x => match x with | inl x => inl (inl x) @@ -116,6 +121,20 @@ Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. ; main := fmap_block reassoc lc.(main) |} +(* + let lc := @compile l unit (bbb (Bjmp tt)) in + let rc := @compile r L k in + + {| label := option (lc.(label) + rc.(label)) + ; blocks := fun x => + match x with + | None => fmap_block _ rc.(main) + | Some (inl x) => fmap_block _ (lc.(blocks) x) + | Some (inr x) => fmap_block _ (rc.(blocks) x) + end + ; main := + fmap_block _ lc.(main) |} +*) | If e l r => let to_right := (fun x => match x with @@ -131,7 +150,7 @@ Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. in let lc := @compile l L k in let rc := @compile r L k in - + {| label := option lc.(label) + option rc.(label) ; blocks := fun x => match x with @@ -203,7 +222,33 @@ End tests. From ITree Require Import ITree. + Require Import ExtLib.Structures.Monad. + From ITree Require Import + Effect.Env. + + Section denote_list. + Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := + fix traverse__ l: M unit := + match l with + | [] => ret tt + | a::l => f a;; traverse__ l + end. + Context {E} {EL : Locals -< E} {EM : Memory -< E}. + + Definition denote_list: list instr -> itree E unit := + traverse_ (denote_instr E). + Lemma denote_after_denote_list: + forall {label: Type} instrs (b: block label), + denote_block E (after instrs b) ~~ (denote_list instrs ;; denote_block E b). + Proof. + induction instrs as [| i instrs IH]; intros b. + - simpl; rewrite ret_bind; reflexivity. + - simpl; rewrite bind_bind. + eapply eutt_bind; [reflexivity | intros []; apply IH]. + Qed. + + End denote_list. Section Correctness. (* @@ -233,42 +278,21 @@ Section Correctness. eapply eutt_bind; [reflexivity | intros []; apply IHb]. - simpl. destruct br; simpl. - + unfold ITree.map; rewrite ret_bind; reflexivity. + + unfold ITree.map; rewrite ret_bind; reflexivity. + unfold ITree.map; rewrite bind_bind. eapply eutt_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + unfold ITree.map; rewrite ret_bind; reflexivity. Qed. - Require Import ExtLib.Structures.Monad. - From ITree Require Import - Effect.Env. - Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := - fix traverse__ l: M unit := - match l with - | [] => ret tt - | a::l => f a;; traverse__ l - end. - - Definition denote_list: list instr -> itree E unit := - traverse_ (denote_instr E). - Lemma denote_after_denote_list: - forall {label: Type} instrs (b: block label), - denote_block E (after instrs b) ~~ (denote_list instrs ;; denote_block E b). - Proof. - induction instrs as [| i instrs IH]; intros b. - - simpl; rewrite ret_bind; reflexivity. - - simpl; rewrite bind_bind. - eapply eutt_bind; [reflexivity | intros []; apply IH]. - Qed. Lemma denote_compile_assign : forall x e, denote_list (compile_assign x e) ~~ ITree.bind (denoteExpr e) (fun v : Imp.value => lift (SetVar x v)). Proof. - (* induction e. - - simpl; rewrite bind_bind. + (* induction e. + - simpl; rewrite bind_bind. eapply eutt_bind; [reflexivity | intros ?]. *) (** YZ: This lemma is wrong. They are not eutt since of course the compiled program does more SetVar actions than @@ -287,25 +311,98 @@ From ExtLib Require Import Core.RelDec Structures.Maps Data.Map.FMapAList. - + +Definition varOf (s : var) : var := "_local" ++ s. + +Variant Rvar : var -> var -> Prop := +| Rvar_var v : Rvar (varOf v) v. + +Definition Renv (g_asm g_imp : alist var value) : Prop := + forall k_asm k_imp, Rvar k_asm k_imp -> + forall v, In (k_imp,v) g_imp -> In (k_asm, v) g_asm. + + +CoInductive euttG {a b : Type} (R : a -> b -> Prop) +: itree E a -> itree E b -> Prop := . + + +Lemma compile_expr_correct : forall e g_imp g_asm n, + Renv g_asm g_imp -> + euttG (fun '(g_asm', _) '(g_imp',v) => + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + In (gen_local n, v) g_asm' /\ (* we get the right value *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + In (gen_local m, v) g_asm <-> In (gen_local m, v) g_asm')) + (run_env unit (denote_list (compile_expr n e)) g_asm) + (run_env value (denoteExpr e) g_imp). +Proof. + induction e; simpl; intros. + { admit. } + { admit. } + { admit. (* obviously the most complex of them. *) } +Admitted. + +Print stmt. + +(* +Seq a b +a :: itree _ Empty_set +[[Skip]] = Vis Halt ... +[[Seq Skip b]] = Vis Halt ... + + +[[s]] :: itree _ unit +[[a]] :: itree _ L (* if closed *) +*) + +(* +Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} + (p : program L) : p.(label) -> itree e (option L) := + rec (fun lbl : p.(label) => + next <- denote_block (_ +' e) (p.(blocks) lbl) ;; + match next with + | None => ret None + | Some (inl next) => lift (Call next) + | Some (inr next) => ret (Some next) + end). + +Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} + (p : program L) : itree e (option L) := + next <- denote_block e p.(main) ;; + match next with + | None => ret None + | Some (inl next) => denote_program p next + | Some (inr next) => ret (Some next) + end. + +Lemma true_compile_correct_program: + forall s L (b: block L) (g_imp g_asm : alist var value), + Renv g_asm g_imp -> + euttG (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) + (run_env _ (denote_main (compile s b)) g_asm) + (run_env _ (denoteStmt s;; denote_block _ b) g_imp). +Proof. + induction s. + { admit. } + { simpl. + unfold denote_main. simpl. + intros. +*) + + Arguments denote_program {_ _ _ _} _ _. + Arguments denote_block {_ _ _ _} _. + + (* This statement does not hold. We need to handle the environment. We want something closer to this kind: -Lemma true_compile_correct_program: - forall s L (b: block L) imports, - run_env unit (denote_main (compile s b) imports) empty ~~ - run_env unit (denoteStmt s;; ml <- denote_block _ b;; - (match ml with - | None => Ret tt - | Some l => imports l - end)) empty. - + *) Lemma compile_correct_program: forall s L (b: block L) imports, denote_main (compile s b) imports ~~ - (denoteStmt s;; ml <- denote_block _ b;; + (denoteStmt s;; ml <- denote_block b;; (match ml with | None => Ret tt | Some l => imports l @@ -313,9 +410,9 @@ Lemma true_compile_correct_program: Proof. simpl. induction s; intros L b imports. - + - unfold denote_main; simpl. - rewrite denote_after_denote_list; simpl. + rewrite denote_after_denote_list; simpl. rewrite bind_bind. eapply eutt_bind. + apply denote_compile_assign. @@ -323,7 +420,7 @@ Lemma true_compile_correct_program: rewrite fmap_block_map, map_bind; simpl. eapply eutt_bind; [reflexivity|]. intros [?|]; simpl; reflexivity. - + - simpl denoteStmt. specialize (IHs2 L b imports). unfold denote_main; simpl denote_block; rewrite fmap_block_map. @@ -338,7 +435,7 @@ Lemma true_compile_correct_program: unfold denote_main. set (imports' := (fun l => match l with | inr l => imports l - | inl l => denote_program _ (compile s2 b) imports l + | inl l => denote_program (compile s2 b) imports l end)). specialize (IHs1 _ (main (compile s2 b)) imports'). rewrite <- IHs1. @@ -347,7 +444,9 @@ Lemma true_compile_correct_program: intros [?|]; [| reflexivity]. simpl option_map. destruct s as [s | [s | s]]; [| | reflexivity]. - + admit. + + clear. subst imports'. + simpl. + unfold denote_program. simpl. + admit. - specialize (IHs1 L b imports). @@ -364,11 +463,15 @@ Lemma true_compile_correct_program: rewrite ret_bind, fmap_block_map, map_bind. eapply eutt_bind; [reflexivity |]. intros [? |]; simpl; reflexivity. - + Admitted. + (* note: because local temporaries also modify the environment, they have to be + * interpreted here. + *) Theorem compile_correct: - forall s, @denote_main _ _ _ Empty_set (compile s (bbb Bhalt)) (fun x => match x with end) ~~ denoteStmt s. + forall s, @denote_main _ _ _ Empty_set (compile s (bbb Bhalt)) + (fun x => match x with end) ~~ denoteStmt s. Proof. (* intros stmt. unfold denote_main. @@ -378,7 +481,7 @@ Admitted. simpl. *) - Admitted. + Admitted. End Correctness. diff --git a/theories/Eq/UpToTausH.v b/theories/Eq/UpToTausH.v new file mode 100644 index 00000000..3b928871 --- /dev/null +++ b/theories/Eq/UpToTausH.v @@ -0,0 +1,1004 @@ +(* Equivalence up to taus *) +(* We consider tau as an "internal step", that should not be + visible to the outside world, so adding or removing [Tau] + constructors from an itree should produce an equivalent itree. + + We must be careful because there may be infinite sequences of + taus (i.e., [spin]). Here we shall only allow inserting finitely + many taus between any two visible steps ([Ret] or [Vis]), so that + [spin] is only related to itself. The main consequence of this + choice is that equivalence up to taus is an equivalence relation. + *) + +(* TODO: + - relate to Eq.Eq.eq_itree + - prove monad laws (see [eutt_bind_bind_fail]) + - make [eutt] easier to work with ([eutt_bind] is already a mess) + *) + +Require Import Paco.paco. + +From Coq Require Import + Program + Lia + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations + Logic.JMeq Logic.EqdepFacts. + +From ITree Require Import Core Eq.Eq. + +Local Open Scope itree. + +(* [notau t] holds when [t] does not start with a [Tau]. *) +Definition notauF {E R I} (t : itreeF E R I) : Prop := + match t with + | TauF _ => False + | _ => True + end. +Arguments notauF [E R I] t. + +Notation notau t := (notauF (observe t)). + +Section EUTT. + +Context {E : Type -> Type} {R : Type}. + +(* Equivalence between visible steps of computation (i.e., [Vis] or + [Ret], parameterized by a relation [eutt] between continuations + in the [Vis] case. *) +Variant eq_notauF {I} (eutt : relation I) +: relation (itreeF E R I) := +| Eutt_ret : forall r, eq_notauF eutt (RetF r) (RetF r) +| Eutt_vis : forall u (e : E u) k1 k2, + (forall x, eutt (k1 x) (k2 x)) -> + eq_notauF eutt (VisF e k1) (VisF e k2). +Hint Constructors eq_notauF. + +Variant eq_notauF' {I} (eutt : relation I) +: relation (itreeF E R I) := +| Eutt_ret' : forall r, eq_notauF' eutt (RetF r) (RetF r) +| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, + eq_dep _ E _ e1 _ e2 -> + (forall x1 x2, JMeq x1 x2 -> eutt (k1 x1) (k2 x2)) -> + eq_notauF' eutt (VisF e1 k1) (VisF e2 k2). +Hint Constructors eq_notauF'. + +Lemma eq_notauF_eq_eq_notauF': forall I (eutt : relation I) t s, + eq_notauF eutt t s <-> eq_notauF' eutt t s. +Proof. + split; intros EUTT; destruct EUTT; eauto. + - econstructor; intros; subst; eauto. + - assert (u1 = u2) by (inv H; eauto). + subst. apply eq_dep_eq in H. subst. eauto. +Qed. + +(* [untaus t' t] holds when [t = Tau (... Tau t' ...)]: + [t] steps to [t'] by "peeling off" a finite number of [Tau]. + "Peel off" means to remove only taus at the root of the tree, + not any behind a [Vis] step). *) +Inductive untausF : relation (itreeF E R _) := +| NoTau ot0 : untausF ot0 ot0 +| OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 +. +Hint Constructors untausF. + +Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. +Hint Unfold unalltausF. + + +(* [finite_taus t] holds when [t] has a finite number of taus + to peel. *) +Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. +Hint Unfold finite_tausF. + +(* [eutt_ eutt t1 t2] means that, if [t1] or [t2] ever takes a + visible step ([Vis] or [Ret]), then the other takes the same + step, and the subsequent continuations (in the [Vis] case) are + related by [eutt]. In particular, [(t1 = spin)%eq_itree] if + and only if [(t2 = spin)%eq_itree]. Note also that in that + case, the parameter [eutt] is irrelevant. + + This is the relation we will take a fixpoint of. *) +Inductive euttF (eutt : relation (itree E R)) (ot1 ot2: itreeF E R (itree E R)) : Prop := +| euttF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) + (EQV: forall ot1' ot2' + (UNTAUS1: unalltausF ot1 ot1') + (UNTAUS2: unalltausF ot2 ot2'), + eq_notauF eutt ot1' ot2') +. +Hint Constructors euttF. + +Definition eutt_ (eutt : relation (itree E R)) (t1 t2 : itree E R) : Prop := + euttF eutt (observe t1) (observe t2). +Hint Unfold eutt_. + +(* Paco takes the greatest fixpoints of monotone relations. *) + +Lemma monotone_eq_notauF : forall I (r r' : relation I) x1 x2 + (IN: eq_notauF r x1 x2) + (LE: r <2= r'), + eq_notauF r' x1 x2. +Proof. pmonauto. Qed. +Hint Resolve monotone_eq_notauF. + +(* [eutt_] is monotone. *) +Lemma monotone_eutt_ : monotone2 eutt_. +Proof. pmonauto. Qed. +Hint Resolve monotone_eutt_ : paco. + +(* We now take the greatest fixpoint of [eutt_]. *) + +(* Equivalence Up To Taus. + + [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) +Definition eutt : relation (itree E R) := paco2 eutt_ bot2. + +Global Arguments eutt t1%itree t2%itree. + +Infix "~~" := eutt (at level 70) : itree_scope. + +(* Lemmas about the auxiliary relations. *) + +(* Many have a name [X_Y] to represent an implication + [X _ -> Y _] (possibly with more arguments on either side). *) + +Lemma untaus_all ot ot' : + untausF ot ot' -> notauF ot' -> unalltausF ot ot'. +Proof. induction 1; eauto. Qed. + +Lemma unalltaus_notau ot ot' : unalltausF ot ot' -> notauF ot'. +Proof. intros. induction H; eauto. Qed. + +Lemma notau_tau I (ot : itreeF E R I) (t0 : I) + (NOTAU : notauF ot) + (OBS: TauF t0 = ot): False. +Proof. subst. auto. Qed. +Hint Resolve notau_tau. + +Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. +Proof. subst. red. eauto. Qed. +Hint Resolve notau_ret. + +Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : @notauF E R I ot. +Proof. intros. subst. red. eauto. Qed. +Hint Resolve notau_vis. + +(* If [t] does not start with [Tau], removing all [Tau] does + nothing. Can be thought of as [notau_unalltaus] composed with + [unalltaus_injective] (below). *) +Lemma unalltaus_notau_id ot ot' : + unalltausF ot ot' -> notauF ot -> ot = ot'. +Proof. + intros [[ | ]] ?; eauto. exfalso; eauto. +Qed. + +(* There is only one way to peel off all taus. *) +Lemma unalltaus_injective ot ot1 ot2 : + unalltausF ot ot1 -> unalltausF ot ot2 -> ot1 = ot2. +Proof. + intros [Huntaus Hnotau]. revert ot2 Hnotau. + induction Huntaus; intros; eauto using unalltaus_notau_id. + eapply IHHuntaus; eauto. + destruct H as [Huntaus' Hnotau']. + destruct Huntaus'. + + exfalso; eauto. + + subst. inversion OBS0; subst; eauto. +Qed. + +(* Adding a [Tau] to [t1] then peeling them all off produces + the same result as peeling them all off from [t1]. *) +Lemma unalltaus_tau t ot1 ot2 + (OBS: TauF t = ot1) + (TAUS: unalltausF ot1 ot2): + unalltausF (observe t) ot2. +Proof. + destruct TAUS as [Huntaus Hnotau]. + destruct Huntaus. + - exfalso; eauto. + - subst; inversion OBS0; subst; eauto. +Qed. + +Lemma unalltaus_tau' t ot1 ot2 + (OBS: TauF t = ot1) + (TAUS: unalltausF (observe t) ot2): + unalltausF ot1 ot2. +Proof. + destruct TAUS as [Huntaus Hnotau]. + subst. eauto. +Qed. + +Lemma notauF_untausF ot1 ot2 + (NOTAU : notauF ot1) + (UNTAUS : untausF ot1 ot2) : ot1 = ot2. +Proof. + destruct UNTAUS; eauto. + exfalso; eauto. +Qed. + +Definition untausF_shift (t1 t2 : itree E R) : + untausF (TauF t1) (TauF t2) -> untausF (observe t1) (observe t2). +Proof. + intros H. + inversion H; subst. + { constructor. } + clear H. + inversion OBS; subst; clear OBS. + remember (observe t1) as ot1. + remember (TauF t2) as tt2. + generalize dependent t1. + generalize dependent t2. + induction TAUS; intros; subst; econstructor; eauto. +Qed. + +Definition untausF_trans (t1 t2 t3 : itreeF E R _) : + untausF t1 t2 -> untausF t2 t3 -> untausF t1 t3. +Proof. + induction 1; auto. + subst; econstructor; auto. +Qed. + +Definition untausF_strong_ind + (P : itreeF E R _ -> Prop) + (ot1 ot2 : itreeF E R _) + (Huntaus : untausF ot1 ot2) + (Hnotau : notauF ot2) + (STEP : forall ot1 + (Huntaus : untausF ot1 ot2) + (IH: forall t1' oti + (NEXT: ot1 = TauF t1') + (UNTAUS: untausF (observe t1') oti), + P oti), + P ot1) + : P ot1. +Proof. + enough (H : forall oti, + untausF ot1 oti -> + untausF oti ot2 -> + P oti + ). + { apply H; eauto. } + revert STEP. + induction Huntaus; intros; subst. + - eapply STEP; eauto. + intros; subst. dependent destruction H; inv Hnotau. + - destruct H0; auto. + subst. apply STEP; eauto. + intros. inv NEXT. + apply IHHuntaus; eauto. + + clear -H UNTAUS. + remember (TauF t') as ott'. remember (TauF t1') as ott1'. + move H at top. revert_until H. induction H; intros; subst. + * inv Heqott1'. eauto. + * inv Heqott'. dependent destruction H; eauto. + + genobs t1' ot1'. revert UNTAUS. clear -Hnotau H0. induction H0; intros. + * dependent destruction UNTAUS; eauto. + subst. simpobs. inv Hnotau. + * subst. dependent destruction UNTAUS; eauto. +Qed. + +(* If [t] does not start with [Tau], then it starts with finitely + many [Tau]. *) +Lemma notau_finite_taus ot : notauF ot -> finite_tausF ot. +Proof. eauto. Qed. + +(* [Vis] and [Ret] start with no taus, of course. *) +Lemma finite_taus_ret ot (r : R) (OBS: RetF r = ot) : finite_tausF ot. +Proof. eauto 10. Qed. + +Lemma finite_taus_vis {u} ot (e : E u) (k : u -> itree E R) (OBS: VisF e k = ot): + finite_tausF ot. +Proof. eauto 10. Qed. + +(* [finite_taus] is preserved by removing or adding one [Tau]. *) +Lemma finite_taus_tau t': + finite_tausF (TauF t') <-> finite_tausF (observe t'). +Proof. + split; intros [? [Huntaus Hnotau]]; eauto 10. + inv Huntaus. + - contradiction. + - inv OBS; eauto. +Qed. + +(* (* [finite_taus] is preserved by removing or adding any finite *) +(* number of [Tau]. *) *) +Lemma untaus_finite_taus ot ot': + untausF ot ot' -> (finite_tausF ot <-> finite_tausF ot'). +Proof. + induction 1; intros; subst. + - reflexivity. + - erewrite finite_taus_tau; eauto. +Qed. + +(**) + +Lemma eq_unalltaus (t1 t2 : itree E R) ot1' + (FT: unalltausF (observe t1) ot1') + (EQV: t1 ≅ t2) : + exists ot2', unalltausF (observe t2) ot2'. +Proof. + genobs t1 ot1. revert t1 Heqot1 t2 EQV. + destruct FT as [Huntaus Hnotau]. + induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. + - eexists. constructor; eauto. inv EQV; simpl; eauto. + - inv EQV; simpobs; try inv Heqot1. + pclearbot. edestruct IHHuntaus as [? []]; eauto. +Qed. + +Lemma eq_unalltaus_eqF (t s : itree E R) ot' + (UNTAUS : unalltausF (observe t) ot') + (EQV: t ≅ s) : + exists os', unalltausF (observe s) os' /\ eq_itreeF' eq_itree ot' os'. +Proof. + destruct UNTAUS as [Huntaus Hnotau]. + remember (observe t) as ot. revert s t Heqot EQV. + induction Huntaus; intros; punfold EQV; unfold_eq_itree. + - eexists (observe s). split. + inv EQV; simpobs; eauto. + subst; eauto. + eapply eq_itreeF'_mono; eauto. + intros ? ? [| []]; eauto. + - inv EQV; rewrite <- H0 in Heqot; inversion Heqot; subst. + destruct REL as [| []]. + edestruct IHHuntaus as [? [[]]]; eauto 10. +Qed. + +Lemma eq_unalltaus_eq (t s : itree E R) t' + (UNTAUS : unalltausF (observe t) (observe t')) + (EQV: t ≅ s) : + exists s', unalltausF (observe s) (observe s') /\ t' ≅ s'. +Proof. + eapply eq_unalltaus_eqF in UNTAUS; try eassumption. + destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. + pfold. eapply eq_itreeF'_mono; eauto. +Qed. + +(* Reflexivity of [eutt_0], modulo a few assumptions. *) +Lemma reflexive_euttF0 I (eutt : relation I) ot : + Reflexive eutt -> notauF ot -> eq_notauF eutt ot ot. +Proof. + intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. +Qed. + +Lemma euttF_tau r t1 t2 t1' t2' + (OBS1: TauF t1' = observe t1) + (OBS2: TauF t2' = observe t2) + (REL: eutt_ r t1' t2'): + eutt_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - simpobs. rewrite !finite_taus_tau. eauto. + - intros. eapply EQV; eapply unalltaus_tau; eauto. +Qed. + +Lemma euttF_tau_left r t1 t2 t1' + (OBS: TauF t1 = observe t1') + (REL: eutt_ r t1' t2): + eutt_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - rewrite <- FIN. symmetry. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS1. constructor; auto. + econstructor; eauto. +Qed. + +Lemma euttF_tau_right r t1 t2 t2' + (OBS: TauF t2 = observe t2') + (REL: eutt_ r t1 t2'): + eutt_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - rewrite FIN. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. + econstructor; eauto. +Qed. + +Lemma euttF_vis {u} (r : relation (itree E R)) t1 t2 (e : _ u) k1 k2 + (OBS1: VisF e k1 = observe t1) + (OBS2: VisF e k2 = observe t2) + (REL: forall x, r (k1 x) (k2 x)): + eutt_ r t1 t2. +Proof. + intros. econstructor. + - split; intros; eapply notau_finite_taus; eauto. + - intros. + apply unalltaus_notau_id in UNTAUS1; eauto. + apply unalltaus_notau_id in UNTAUS2; eauto. + simpobs. subst. eauto. +Qed. + +(**) + +Lemma Reflexive_euttF (r : relation (itree E R)) : + Reflexive r -> Reflexive (euttF r). +Proof. + split. + - reflexivity. + - intros. + erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). + apply reflexive_euttF0; eauto using unalltaus_notau. +Qed. + +Lemma eutt_refl r x : paco2 eutt_ r x x. +Proof. + revert x. pcofix CIH. + intros. pfold. apply Reflexive_euttF. eauto. +Qed. + +(* [eutt] is an equivalence relation. *) +Global Instance Reflexive_eutt: (Reflexive eutt). +Proof. + repeat intro. apply eutt_refl. +Qed. + +Global Instance Symmetric_eutt +: Symmetric eutt. +Proof. + pcofix Symmetric_eutt. + intros t1 t2 H12. + punfold H12. + pfold. + destruct H12 as [I12 H12]. + split. + - symmetry; assumption. + - intros. hexploit H12; eauto. intros. + inv H; eauto. + econstructor. intros. specialize (H0 x). pclearbot. eauto. +Qed. + +Global Instance Transitive_eutt : Transitive eutt. +Proof. + pcofix Transitive_eutt. + intros t1 t2 t3 H12 H23. + punfold H12. + punfold H23. + pfold. + destruct H12 as [I12 H12]. + destruct H23 as [I23 H23]. + split. + - etransitivity; eauto. + - intros t1' t3' H1 H3. + destruct I12 as [I1 I2]. + destruct I1 as [n2' [t2' TAUS2]]; eauto. + hexploit H12; eauto. intros REL1. + hexploit H23; eauto. intros REL2. + destruct REL1; inversion REL2; clear REL2; eauto. + auto_inj_pair2; subst. + econstructor. intros. + specialize (H x); specialize (H6 x). pclearbot. eauto. +Qed. + +(**) + +(* [eutt] is preserved by removing one [Tau]. *) +Lemma tauF_eutt (t t': itree E R) (OBS: TauF t' = observe t): t ~~ t'. +Proof. + pfold. split. + - simpobs. rewrite finite_taus_tau. reflexivity. + - intros t1' t2' H1 H2. + eapply unalltaus_tau in H1; eauto. + assert (X := unalltaus_injective _ _ _ H1 H2). + subst; apply reflexive_euttF0; eauto using unalltaus_notau. + left. apply Reflexive_eutt. +Qed. + +Lemma tau_eutt (t: itree E R) : Tau t ~~ t. +Proof. + eapply tauF_eutt. eauto. +Qed. + +(* [eutt] is preserved by removing all [Tau]. *) +Lemma untaus_eutt (t t' : itree E R) : untausF (observe t) (observe t') -> t ~~ t'. +Proof. + intros H. + pfold. split. + - eapply untaus_finite_taus; eauto. + - induction H; intros. + + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). + apply reflexive_euttF0; eauto using unalltaus_notau. + left; apply Reflexive_eutt. + + eapply unalltaus_tau in UNTAUS1; eauto. +Qed. + +End EUTT. + +Hint Constructors eq_notauF. +Hint Constructors eq_notauF'. +Hint Constructors untausF. +Hint Unfold unalltausF. +Hint Unfold finite_tausF. +Hint Constructors euttF. +Hint Resolve monotone_eutt_ : paco. +Hint Resolve notau_ret. +Hint Resolve notau_vis. +Hint Resolve notau_tau. + +Delimit Scope eutt_scope with eutt. + +Infix "~~" := eutt (at level 70). + +Notation finite_taus t := (finite_tausF (observe t)). +Notation untaus t t' := (untausF (observe t) (observe t')). +Notation unalltaus t t' := (unalltausF (observe t) (observe t')). + +(* We can now rewrite with [eutt] equalities. *) +Instance Equivalence_eutt E R : @Equivalence (itree E R) eutt. +Proof. constructor; typeclasses eauto. Qed. + +Instance subrelation_eq_eutt {E R} : subrelation (@eq_itree E R) eutt. +Proof. + pcofix CIH. intros. + pfold. econstructor. + { split; [|symmetry in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } + + intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. + hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. + inv EQV'; simpobs; eauto. + eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. +Qed. + +Instance subrelation_go_sim_eq_eutt {E R} : subrelation (go_sim (@eq_itree E R)) (go_sim (@eutt E R)). +Proof. + repeat intro. red. red in H. rewrite H. reflexivity. +Qed. + +Instance eutt_go {E R} : + Proper (go_sim (@eutt E R) ==> @eutt E R) (@go E R). +Proof. + repeat intro. eauto. +Qed. + +Instance eutt_observe {E R} : + Proper (@eutt E R ==> go_sim (@eutt E R)) (@observe E R). +Proof. + repeat intro. punfold H. pfold. destruct H. econstructor; eauto. +Qed. + +Instance eutt_tauF {E R} : + Proper (@eutt E R ==> go_sim (@eutt E R)) (@TauF E R _). +Proof. + repeat intro. pfold. punfold H. + destruct H. econstructor. + - split; intros; simpl. + + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. + + rewrite finite_taus_tau, FIN, <-finite_taus_tau; eauto. + - intros. eapply EQV; eapply unalltaus_tau; eauto. +Qed. + +Instance eutt_VisF {E R u} (e: E u) : + Proper (pointwise_relation _ eutt ==> go_sim (@eutt E R)) (VisF e). +Proof. + repeat intro. red in H. pfold. econstructor. + - repeat econstructor. + - intros. + destruct UNTAUS1 as [UNTAUS1 Hnotau1]. + destruct UNTAUS2 as [UNTAUS2 Hnotau2]. + dependent destruction UNTAUS1. + dependent destruction UNTAUS2. simpobs. + econstructor; intros; left; apply H. +Qed. + +Instance eq_itree_notauF {E R} : + Proper (go_sim (@eq_itree E R) ==> flip impl) (@notauF E R _). +Proof. + repeat intro. punfold H. inv H; simpl in *; subst; eauto. +Qed. + +(* If [t1] and [t2] are equivalent, then either both start with + finitely many taus, or both [spin]. *) +Instance eutt_finite_taus {E R} : + Proper (go_sim (@eutt E R) ==> flip impl) (@finite_tausF E R). +Proof. + repeat intro. punfold H. eapply H. eauto. +Qed. + +(* Lemmas about [bind]. *) + +Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) (observe t')), + untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). +Proof. + intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. + induction UNTAUS; intros; subst. + - rewrite !bind_unfold; simpobs; eauto. + - rewrite bind_unfold. simpobs. cbn. eauto. +Qed. + +Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) t'), + untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). +Proof. + intros; eapply untaus_bind; eauto. +Qed. + +Lemma finite_taus_bind_fst {E R S} + (t : itree E R) (f : R -> itree E S) : + finite_taus (ITree.bind t f) -> finite_taus t. +Proof. + intros [tf' [TAUS PROP]]. + genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. + induction TAUS; intros; subst. + - rewrite bind_unfold in PROP. + genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + rewrite bind_unfold in Heqobtf. simpobs. inv Heqobtf. unfold_bind. + eapply finite_taus_tau; eauto. +Qed. + +Lemma finite_taus_bind {E R S} + (t : itree E R) (f : R -> itree E S) + (FINt: finite_tausF (observe t)) + (FINk: forall v, finite_tausF (observe (f v))): + finite_tausF (observe (ITree.bind t f)). +Proof. + rewrite bind_unfold. + genobs t ot. clear Heqot t. + destruct FINt as [ot' [UNT NOTAU]]. + induction UNT; subst. + - destruct ot0; inv NOTAU; simpl; eauto 7. + - apply finite_taus_tau. eauto. +Qed. + +Lemma untaus_eq_idx E R: forall (ot1 ot2: itreeF E R _), + untausF ot1 ot2 -> untausF ot1 ot2. +Proof. intros; subst; eauto. Qed. + +Lemma untaus_untaus E R: forall (ot1 ot2 ot3: itreeF E R _), + untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. +Proof. + intros t1 t2 t3. induction 1; simpl; eauto. +Qed. + +Lemma untaus_unalltus_rev E R (ot1 ot2 ot3: itreeF E R _) : + untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. +Proof. + intros H. revert ot3. + induction H; intros. + - eauto using untaus_eq_idx with arith. + - destruct H0 as [Huntaus Hnotau]. + destruct Huntaus. + + exfalso; eauto. + + inv OBS0. inversion H0; subst; eauto. +Qed. + +Lemma eutt_strengthen {E R}: + forall r (t1 t2: itree E R) + (FIN: finite_taus t1 <-> finite_taus t2) + (EQV: forall t1' t2' + (UNT1: unalltaus t1 t1') + (UNT2: unalltaus t2 t2'), + paco2 (eutt_ ∘ gres2 eutt_) r t1' t2'), + paco2 (eutt_ ∘ gres2 eutt_) r t1 t2. +Proof. + intros. pfold. econstructor; eauto. + intros. + hexploit (EQV (go ot1') (go ot2')); eauto. + intros EQV'. punfold EQV'. destruct EQV'. + eapply EQV0; + repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. +Qed. + +Inductive eutt_trans_clo {E R} (r: relation (itree E R)) : relation (itree E R) := +| eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) + (EQVl: t1 ~~ t2) + (EQVr: t4 ~~ t3) + (REL: r t2 t3) + : eutt_trans_clo r t1 t4 +. +Hint Constructors eutt_trans_clo. + +Lemma eutt_clo_trans E R: weak_respectful2 (@eutt_ E R) eutt_trans_clo. +Proof. + econstructor; [pmonauto|]. + intros. inv PR. + punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. + { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } + + intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. + hexploit EQV; eauto. intros EUTT1. + apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. + hexploit EQV0; eauto. intros EUTT2. + apply GF in REL. destruct REL. + hexploit EQV1; eauto. intros EUTT3. + destruct EUTT1; destruct EUTT2; + try (solve [inversion EUTT3; auto]). + remember (VisF _ _) as o2 in EUTT3. + remember (VisF _ _) as o3 in EUTT3. + inversion EUTT3; subst; try discriminate. + inversion H2; clear H2; inversion H3; clear H3. + subst; auto_inj_pair2; subst. + econstructor. intros. + specialize (H x); specialize (H0 x); specialize (H1 x). + pclearbot. eauto using rclo2. +Qed. + +Inductive eutt_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := +| eutt_bind_clo_intro U (t1 t2: itree E U) k1 k2 + (EQV: t1 ~~ t2) + (REL: forall v, r (k1 v) (k2 v)) + : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) +. +Hint Constructors eutt_bind_clo. + +Lemma bind_clo_finite_taus E U R (t1 t2: itree E U) (k1 k2: U -> itree E R) + (FT: finite_taus (ITree.bind t1 k1)) + (FTk: forall v, finite_taus (k1 v) -> finite_taus (k2 v)) + (EQV: t1 ~~ t2): + finite_taus (ITree.bind t2 k2). +Proof. + punfold EQV. destruct EQV as [[FTt _] EQV]. + assert (FT1 := FT). apply finite_taus_bind_fst in FT1. + assert (FT2 := FT1). apply FTt in FT2. + destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. + rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. + rewrite bind_unfold. genobs t2 ot2. clear Heqot2 t2. + induction FT2. + - destruct ot0; inv NT2; simpl; eauto 7. + hexploit EQV; eauto. intros EQV'. inv EQV'. + rewrite bind_unfold in FT. eauto. + - subst. eapply finite_taus_tau; eauto. + eapply IHFT2; eauto using unalltaus_tau'. +Qed. + +Lemma eutt_clo_bind E R: weak_respectful2 (@eutt_ E R) eutt_bind_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. split. + - assert (EQV':=EQV). symmetry in EQV'. + split; intros; eapply bind_clo_finite_taus; eauto; intros. + + edestruct GF; eauto. apply FIN. eauto. + + edestruct GF; eauto. apply FIN. eauto. + - punfold EQV. destruct EQV. + intros. + hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS1|]. intros [a FT1]. + hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS2|]. intros [b FT2]. + specialize (EQV _ _ FT1 FT2). + destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. + hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. + hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. + hexploit untaus_unalltus_rev; [apply UT1| |]. eauto. intros UAT1. + hexploit untaus_unalltus_rev; [apply UT2| |]; eauto. intros UAT2. + inv EQV. + + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. + eapply GF in REL. destruct REL. + eapply monotone_eq_notauF; eauto using rclo2. + + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. + destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. + dependent destruction UAT1. dependent destruction UAT2. simpobs. + econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. +Qed. + +(* [eutt] is a congruence wrt. [bind] *) + +Instance eutt_bind {E R S} : + Proper (@eutt E R ==> + pointwise_relation _ eutt ==> + @eutt E S) ITree.bind. +Proof. + repeat intro. pupto2_init. + pupto2 eutt_clo_bind. econstructor; eauto. + intros. pupto2_final. apply H0. +Qed. + +Instance eutt_paco {E R} r: + Proper (@eutt E R ==> @eutt E R ==> flip impl) + (paco2 (eutt_ ∘ gres2 eutt_) r). +Proof. + repeat intro. pupto2 eutt_clo_trans. eauto. +Qed. + +Instance eutt_gres {E R} r: + Proper (@eutt E R ==> @eutt E R ==> flip impl) + (gres2 eutt_ r). +Proof. + repeat intro. pupto2 eutt_clo_trans. eauto. +Qed. + +Instance eutt_map {E R S} : + Proper (pointwise_relation _ eq ==> @eutt E R ==> @eutt E S) ITree.map. +Proof. +Admitted. + +Instance eutt_forever {E R S} : + Proper (@eutt E R ==> @eutt E S) ITree.forever. +Proof. +Admitted. +Instance eutt_when {E} (b : bool) : + Proper (@eutt E unit ==> @eutt E unit) (ITree.when b). +Proof. +Admitted. + +Lemma eutt_map_map {E R S T} + (f : R -> S) (g : S -> T) (t : itree E R) : + eutt (ITree.map g (ITree.map f t)) + (ITree.map (fun x => g (f x)) t). +Proof. + rewrite map_map. reflexivity. +Qed. + +Notation itree' E R := (itreeF E R (itree E R)). + +Definition observing {E R} + (f : itree' E R -> itree' E R -> Prop) + (x y : itree E R) := + f x.(observe) y.(observe). + +Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : + itree' E R -> itree' E R -> Prop := +| euttF1_Tau_L : forall t1 t2, + euttF1' r t1.(observe) t2 -> + euttF1' r (TauF t1) t2 +| euttF1_Tau_R : forall t1 t2, + euttF1' r t1 t2.(observe) -> + euttF1' r t1 (TauF t2) +| euttF1_euttF0 : forall t1 t2, + eq_notauF r t1 t2 -> + euttF1' r t1 t2 +. + +Definition euttF1 {E R} (r : relation (itree E R)) : + relation (itree E R) := observing (euttF1' r). + +Lemma euttF1_euttF {E R} (r : relation (itree E R)) : + forall t1 t2, + euttF1 r t1 t2 -> eutt_ r t1 t2. +Proof. +Admitted. + +Inductive euttF' {E R} (eutt: relation (itree E R)) (eqtaus: relation (itreeF E R _)) + : relation (itreeF E R _) := +| euttF'_ret r : euttF' eutt eqtaus (RetF r) (RetF r) +| euttF'_vis u (e : E u) k1 k2 + (EUTTK: forall x, eutt (k1 x) (k2 x)): + euttF' eutt eqtaus (VisF e k1) (VisF e k2) +| euttF'_tau_tau t1 t2 + (EQTAUS: eqtaus (observe t1) (observe t2)): + euttF' eutt eqtaus (TauF t1) (TauF t2) +| euttF'_tau_left t1 ot2 + (EQTAUS: euttF' eutt eqtaus (observe t1) ot2): + euttF' eutt eqtaus (TauF t1) ot2 +| euttF'_right ot1 t2 + (EQTAUS: euttF' eutt eqtaus ot1 (observe t2)): + euttF' eutt eqtaus ot1 (TauF t2) +. +Hint Constructors euttF'. + +Definition eutt'_ {E R} eutt t1 t2 := paco2 (@euttF' E R eutt) bot2 (* (fun x y => eutt (go x) (go y)) *) (observe t1) (observe t2). +Hint Unfold eutt'_. + +Definition eutt' {E R} := paco2 (@eutt'_ E R) bot2. +Hint Unfold eutt'. + +Lemma euttF'_mon {E R} r r' s s' x y + (EUTT: @euttF' E R r s x y) + (LEr: r <2= r') + (LEs: s <2= s'): + euttF' r' s' x y. +Proof. + induction EUTT; eauto. +Qed. + +Lemma monotone_euttF' {E R} eutt : monotone2 (@euttF' E R eutt). +Proof. repeat intro. eauto using euttF'_mon. Qed. +Hint Resolve monotone_euttF' : paco. + +Lemma monotone_eutt'_ {E R} : monotone2 (@eutt'_ E R). +Proof. red. eauto using euttF'_mon, paco2_mon_gen. Qed. +Hint Resolve monotone_eutt'_ : paco. + +Lemma eutt__is_eutt'_ {E R} r (t1 t2: itree E R) : + eutt_ r t1 t2 <-> eutt'_ r t1 t2. +Proof. + split; intros. + { revert t1 t2 H. pcofix CIH'. intros. destruct H0. + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) + by (destruct ot1, ot2; simpl; tauto). + destruct EM as [EM|[EM|EM]]. + - destruct FIN as [FIN _]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS1. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct FIN as [_ FIN]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS2. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct ot1, ot2; simpl in *; try tauto. + pfold. econstructor. right. apply CIH'. + econstructor. + + rewrite !finite_taus_tau in FIN. eauto. + + eauto using unalltaus_tau'. + } + { punfold H. econstructor; intros. + - split; intros. + + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. + move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. + induction UNTAUS1. + + induction 1; intros. + * inv H; try contradiction; eauto. + * subst. inv H; try contradiction. eauto. + + induction 1; intros; subst. + * inv H; try contradiction; eauto. + * inv H; try contradiction; eauto. + pclearbot. eapply IHUNTAUS1; eauto. + punfold EQTAUS. + } +Qed. + +Lemma eutt_is_eutt' {E R} r (t1 t2: itree E R) : + paco2 eutt_ r t1 t2 <-> paco2 eutt'_ r t1 t2. +Proof. + split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__is_eutt'_; eauto. +Qed. + +Lemma eutt_is_eutt'_gres {E R} r (t1 t2: itree E R) : + paco2 (eutt_ ∘ gres2 eutt_) r t1 t2 <-> paco2 (eutt'_ ∘ gres2 eutt'_) r t1 t2. +Proof. + split; intros. + - eapply paco2_mon_gen; eauto. intros. + red in PR|-*. rewrite <-eutt__is_eutt'_. + eapply monotone_eutt_; eauto. intros. + eapply grespectful2_impl; eauto. intros. + rewrite eutt__is_eutt'_. reflexivity. + - eapply paco2_mon_gen; eauto. intros. + red in PR|-*. rewrite eutt__is_eutt'_. + eapply monotone_eutt'_; eauto. intros. + eapply grespectful2_impl; eauto. intros. + rewrite eutt__is_eutt'_. reflexivity. +Qed. + +Instance eutt'_paco {E R} r: + Proper (@eutt E R ==> @eutt E R ==> flip impl) + (paco2 (eutt'_ ∘ gres2 eutt'_) r). +Proof. + repeat intro. + rewrite <-eutt_is_eutt'_gres. + rewrite <-eutt_is_eutt'_gres in H1. + rewrite H, H0. eauto. +Qed. + +Instance eutt'_gres {E R} r: + Proper (@eutt E R ==> @eutt E R ==> flip impl) + (gres2 eutt'_ r). +Proof. + repeat intro. + rewrite grespectful2_iff; [|intros; erewrite eutt__is_eutt'_; reflexivity]. + rewrite grespectful2_iff in H1; [|intros; erewrite eutt__is_eutt'_; reflexivity]. + rewrite H, H0. eauto. +Qed. From 2de7fe956330d6a9ef3f2877ef64551e34fdec57 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Fri, 15 Feb 2019 18:18:32 -0500 Subject: [PATCH 009/142] some missing edits. --- theories/Eq/UpToTausH.v | 81 ++++++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 33 deletions(-) diff --git a/theories/Eq/UpToTausH.v b/theories/Eq/UpToTausH.v index 3b928871..45cc90b1 100644 --- a/theories/Eq/UpToTausH.v +++ b/theories/Eq/UpToTausH.v @@ -43,19 +43,20 @@ Notation notau t := (notauF (observe t)). Section EUTT. -Context {E : Type -> Type} {R : Type}. +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). (* Equivalence between visible steps of computation (i.e., [Vis] or [Ret], parameterized by a relation [eutt] between continuations in the [Vis] case. *) Variant eq_notauF {I} (eutt : relation I) : relation (itreeF E R I) := -| Eutt_ret : forall r, eq_notauF eutt (RetF r) (RetF r) +| Eutt_ret : forall r r', RR r r' -> eq_notauF eutt (RetF r) (RetF r') | Eutt_vis : forall u (e : E u) k1 k2, (forall x, eutt (k1 x) (k2 x)) -> eq_notauF eutt (VisF e k1) (VisF e k2). Hint Constructors eq_notauF. +(* Variant eq_notauF' {I} (eutt : relation I) : relation (itreeF E R I) := | Eutt_ret' : forall r, eq_notauF' eutt (RetF r) (RetF r) @@ -73,6 +74,8 @@ Proof. - assert (u1 = u2) by (inv H; eauto). subst. apply eq_dep_eq in H. subst. eauto. Qed. +*) + (* [untaus t' t] holds when [t = Tau (... Tau t' ...)]: [t] steps to [t'] by "peeling off" a finite number of [Tau]. @@ -356,6 +359,7 @@ Qed. (* Reflexivity of [eutt_0], modulo a few assumptions. *) Lemma reflexive_euttF0 I (eutt : relation I) ot : + Reflexive RR -> Reflexive eutt -> notauF ot -> eq_notauF eutt ot ot. Proof. intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. @@ -411,6 +415,7 @@ Qed. (**) Lemma Reflexive_euttF (r : relation (itree E R)) : + Reflexive RR -> Reflexive r -> Reflexive (euttF r). Proof. split. @@ -420,10 +425,13 @@ Proof. apply reflexive_euttF0; eauto using unalltaus_notau. Qed. +Context {Reflexive_RR : Reflexive RR}. + Lemma eutt_refl r x : paco2 eutt_ r x x. Proof. revert x. pcofix CIH. intros. pfold. apply Reflexive_euttF. eauto. + right. eauto. Qed. (* [eutt] is an equivalence relation. *) @@ -432,8 +440,8 @@ Proof. repeat intro. apply eutt_refl. Qed. -Global Instance Symmetric_eutt -: Symmetric eutt. +Global Instance Symmetric_eutt (SRR : Symmetric RR) +: Symmetric eutt. Proof. pcofix Symmetric_eutt. intros t1 t2 H12. @@ -447,7 +455,7 @@ Proof. econstructor. intros. specialize (H0 x). pclearbot. eauto. Qed. -Global Instance Transitive_eutt : Transitive eutt. +Global Instance Transitive_eutt (TRR : Transitive RR) : Transitive eutt. Proof. pcofix Transitive_eutt. intros t1 t2 t3 H12 H23. @@ -504,7 +512,7 @@ Qed. End EUTT. Hint Constructors eq_notauF. -Hint Constructors eq_notauF'. +(* Hint Constructors eq_notauF'. *) Hint Constructors untausF. Hint Unfold unalltausF. Hint Unfold finite_tausF. @@ -516,17 +524,20 @@ Hint Resolve notau_tau. Delimit Scope eutt_scope with eutt. -Infix "~~" := eutt (at level 70). +Infix "~~" := (@eutt _ _ eq) (at level 70). +Infix "~[ RR ]~" := (@eutt _ _ RR) (at level 70). Notation finite_taus t := (finite_tausF (observe t)). Notation untaus t t' := (untausF (observe t) (observe t')). Notation unalltaus t t' := (unalltausF (observe t) (observe t')). (* We can now rewrite with [eutt] equalities. *) -Instance Equivalence_eutt E R : @Equivalence (itree E R) eutt. +Instance Equivalence_eutt E R RR (ERR : Equivalence RR) +: @Equivalence (itree E R) (eutt RR). Proof. constructor; typeclasses eauto. Qed. -Instance subrelation_eq_eutt {E R} : subrelation (@eq_itree E R) eutt. +Instance subrelation_eq_eutt {E R RR} (RRR : Reflexive RR) +: subrelation (@eq_itree E R) (eutt RR). Proof. pcofix CIH. intros. pfold. econstructor. @@ -538,25 +549,26 @@ Proof. eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. Qed. -Instance subrelation_go_sim_eq_eutt {E R} : subrelation (go_sim (@eq_itree E R)) (go_sim (@eutt E R)). +Instance subrelation_go_sim_eq_eutt {E R RR} {RRR : Reflexive RR} +: subrelation (go_sim (@eq_itree E R)) (go_sim (@eutt E R RR)). Proof. - repeat intro. red. red in H. rewrite H. reflexivity. + repeat intro. red. red in H. eapply subrelation_eq_eutt; eauto. Qed. -Instance eutt_go {E R} : - Proper (go_sim (@eutt E R) ==> @eutt E R) (@go E R). +Instance eutt_go {E R RR} : + Proper (go_sim (@eutt E R RR) ==> @eutt E R RR) (@go E R). Proof. repeat intro. eauto. Qed. -Instance eutt_observe {E R} : - Proper (@eutt E R ==> go_sim (@eutt E R)) (@observe E R). +Instance eutt_observe {E R RR} : + Proper (@eutt E R RR ==> go_sim (@eutt E R RR)) (@observe E R). Proof. repeat intro. punfold H. pfold. destruct H. econstructor; eauto. Qed. -Instance eutt_tauF {E R} : - Proper (@eutt E R ==> go_sim (@eutt E R)) (@TauF E R _). +Instance eutt_tauF {E R RR} : + Proper (@eutt E R RR ==> go_sim (@eutt E R RR)) (@TauF E R _). Proof. repeat intro. pfold. punfold H. destruct H. econstructor. @@ -566,8 +578,8 @@ Proof. - intros. eapply EQV; eapply unalltaus_tau; eauto. Qed. -Instance eutt_VisF {E R u} (e: E u) : - Proper (pointwise_relation _ eutt ==> go_sim (@eutt E R)) (VisF e). +Instance eutt_VisF {E R RR u} (e: E u) : + Proper (pointwise_relation _ (eutt RR) ==> go_sim (@eutt E R RR)) (VisF e). Proof. repeat intro. red in H. pfold. econstructor. - repeat econstructor. @@ -587,8 +599,8 @@ Qed. (* If [t1] and [t2] are equivalent, then either both start with finitely many taus, or both [spin]. *) -Instance eutt_finite_taus {E R} : - Proper (go_sim (@eutt E R) ==> flip impl) (@finite_tausF E R). +Instance eutt_finite_taus {E R RR} : + Proper (go_sim (@eutt E R RR) ==> flip impl) (@finite_tausF E R). Proof. repeat intro. punfold H. eapply H. eauto. Qed. @@ -662,14 +674,14 @@ Proof. + inv OBS0. inversion H0; subst; eauto. Qed. -Lemma eutt_strengthen {E R}: +Lemma eutt_strengthen {E R RR}: forall r (t1 t2: itree E R) (FIN: finite_taus t1 <-> finite_taus t2) (EQV: forall t1' t2' (UNT1: unalltaus t1 t1') (UNT2: unalltaus t2 t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1' t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2. + paco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r t1' t2'), + paco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r t1 t2. Proof. intros. pfold. econstructor; eauto. intros. @@ -679,16 +691,17 @@ Proof. repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. Qed. -Inductive eutt_trans_clo {E R} (r: relation (itree E R)) : relation (itree E R) := +Inductive eutt_trans_clo {E R} RR (r: relation (itree E R)) : relation (itree E R) := | eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ~~ t2) - (EQVr: t4 ~~ t3) + (EQVl: t1 ~[RR]~ t2) + (EQVr: t4 ~[RR]~ t3) (REL: r t2 t3) - : eutt_trans_clo r t1 t4 + : eutt_trans_clo RR r t1 t4 . Hint Constructors eutt_trans_clo. -Lemma eutt_clo_trans E R: weak_respectful2 (@eutt_ E R) eutt_trans_clo. +Lemma eutt_clo_trans {E R RR} {ERR : Equivalence RR} +: weak_respectful2 (@eutt_ E R RR) (eutt_trans_clo RR). Proof. econstructor; [pmonauto|]. intros. inv PR. @@ -703,6 +716,8 @@ Proof. hexploit EQV1; eauto. intros EUTT3. destruct EUTT1; destruct EUTT2; try (solve [inversion EUTT3; auto]). + { constructor. inversion EUTT3. subst. + etransitivity; eauto. etransitivity; eauto. symmetry. eauto. } remember (VisF _ _) as o2 in EUTT3. remember (VisF _ _) as o3 in EUTT3. inversion EUTT3; subst; try discriminate. @@ -714,9 +729,9 @@ Proof. Qed. Inductive eutt_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_bind_clo_intro U (t1 t2: itree E U) k1 k2 - (EQV: t1 ~~ t2) - (REL: forall v, r (k1 v) (k2 v)) +| eutt_bind_clo_intro U RU (t1 t2: itree E U) k1 k2 + (EQV: t1 ~[RU]~ t2) + (REL: forall v1 v2, RU v1 v2 -> r (k1 v1) (k2 v2)) : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) . Hint Constructors eutt_bind_clo. @@ -741,7 +756,7 @@ Proof. eapply IHFT2; eauto using unalltaus_tau'. Qed. -Lemma eutt_clo_bind E R: weak_respectful2 (@eutt_ E R) eutt_bind_clo. +Lemma eutt_clo_bind E R {RR} {ERR : Equivalence RR} : weak_respectful2 (@eutt_ E R RR) eutt_bind_clo. Proof. econstructor; [pmonauto|]. intros. destruct PR. split. From 122ebc63e4421ca3ae9ba4f53b93d732fbae3796 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 16 Feb 2019 16:42:09 -0500 Subject: [PATCH 010/142] Make eutt a heterogeneous relation --- theories/Eq/UpToTaus.v | 603 ++++++++++++----------- theories/Eq/UpToTausH.v | 1019 --------------------------------------- theories/Trace.v | 2 +- 3 files changed, 317 insertions(+), 1307 deletions(-) delete mode 100644 theories/Eq/UpToTausH.v diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 3b928871..99a6f273 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -11,9 +11,9 @@ *) (* TODO: - - relate to Eq.Eq.eq_itree - - prove monad laws (see [eutt_bind_bind_fail]) - - make [eutt] easier to work with ([eutt_bind] is already a mess) + - Generalize Reflexivity, Symmetry, Transitivity to heterogeneous + eutt. + - Make eutt a notation instead of a definition? *) Require Import Paco.paco. @@ -31,54 +31,25 @@ From ITree Require Import Core Eq.Eq. Local Open Scope itree. +Section FiniteTaus. + +Context {E : Type -> Type} {R : Type}. + (* [notau t] holds when [t] does not start with a [Tau]. *) -Definition notauF {E R I} (t : itreeF E R I) : Prop := +Definition notauF {I} (t : itreeF E R I) : Prop := match t with | TauF _ => False | _ => True end. -Arguments notauF [E R I] t. Notation notau t := (notauF (observe t)). -Section EUTT. - -Context {E : Type -> Type} {R : Type}. - -(* Equivalence between visible steps of computation (i.e., [Vis] or - [Ret], parameterized by a relation [eutt] between continuations - in the [Vis] case. *) -Variant eq_notauF {I} (eutt : relation I) -: relation (itreeF E R I) := -| Eutt_ret : forall r, eq_notauF eutt (RetF r) (RetF r) -| Eutt_vis : forall u (e : E u) k1 k2, - (forall x, eutt (k1 x) (k2 x)) -> - eq_notauF eutt (VisF e k1) (VisF e k2). -Hint Constructors eq_notauF. - -Variant eq_notauF' {I} (eutt : relation I) -: relation (itreeF E R I) := -| Eutt_ret' : forall r, eq_notauF' eutt (RetF r) (RetF r) -| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, - eq_dep _ E _ e1 _ e2 -> - (forall x1 x2, JMeq x1 x2 -> eutt (k1 x1) (k2 x2)) -> - eq_notauF' eutt (VisF e1 k1) (VisF e2 k2). -Hint Constructors eq_notauF'. - -Lemma eq_notauF_eq_eq_notauF': forall I (eutt : relation I) t s, - eq_notauF eutt t s <-> eq_notauF' eutt t s. -Proof. - split; intros EUTT; destruct EUTT; eauto. - - econstructor; intros; subst; eauto. - - assert (u1 = u2) by (inv H; eauto). - subst. apply eq_dep_eq in H. subst. eauto. -Qed. - (* [untaus t' t] holds when [t = Tau (... Tau t' ...)]: [t] steps to [t'] by "peeling off" a finite number of [Tau]. "Peel off" means to remove only taus at the root of the tree, not any behind a [Vis] step). *) -Inductive untausF : relation (itreeF E R _) := +Inductive untausF : + itreeF E R (itree E R) -> itreeF E R (itree E R) -> Prop := | NoTau ot0 : untausF ot0 ot0 | OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 . @@ -87,62 +58,12 @@ Hint Constructors untausF. Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. Hint Unfold unalltausF. - (* [finite_taus t] holds when [t] has a finite number of taus to peel. *) Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. Hint Unfold finite_tausF. -(* [eutt_ eutt t1 t2] means that, if [t1] or [t2] ever takes a - visible step ([Vis] or [Ret]), then the other takes the same - step, and the subsequent continuations (in the [Vis] case) are - related by [eutt]. In particular, [(t1 = spin)%eq_itree] if - and only if [(t2 = spin)%eq_itree]. Note also that in that - case, the parameter [eutt] is irrelevant. - - This is the relation we will take a fixpoint of. *) -Inductive euttF (eutt : relation (itree E R)) (ot1 ot2: itreeF E R (itree E R)) : Prop := -| euttF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) - (EQV: forall ot1' ot2' - (UNTAUS1: unalltausF ot1 ot1') - (UNTAUS2: unalltausF ot2 ot2'), - eq_notauF eutt ot1' ot2') -. -Hint Constructors euttF. - -Definition eutt_ (eutt : relation (itree E R)) (t1 t2 : itree E R) : Prop := - euttF eutt (observe t1) (observe t2). -Hint Unfold eutt_. - -(* Paco takes the greatest fixpoints of monotone relations. *) - -Lemma monotone_eq_notauF : forall I (r r' : relation I) x1 x2 - (IN: eq_notauF r x1 x2) - (LE: r <2= r'), - eq_notauF r' x1 x2. -Proof. pmonauto. Qed. -Hint Resolve monotone_eq_notauF. - -(* [eutt_] is monotone. *) -Lemma monotone_eutt_ : monotone2 eutt_. -Proof. pmonauto. Qed. -Hint Resolve monotone_eutt_ : paco. - -(* We now take the greatest fixpoint of [eutt_]. *) - -(* Equivalence Up To Taus. - - [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) -Definition eutt : relation (itree E R) := paco2 eutt_ bot2. - -Global Arguments eutt t1%itree t2%itree. - -Infix "~~" := eutt (at level 70) : itree_scope. - -(* Lemmas about the auxiliary relations. *) - -(* Many have a name [X_Y] to represent an implication - [X _ -> Y _] (possibly with more arguments on either side). *) +(** ** Lemmas *) Lemma untaus_all ot ot' : untausF ot ot' -> notauF ot' -> unalltausF ot ot'. @@ -161,7 +82,7 @@ Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. Proof. subst. red. eauto. Qed. Hint Resolve notau_ret. -Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : @notauF E R I ot. +Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : notauF ot. Proof. intros. subst. red. eauto. Qed. Hint Resolve notau_vis. @@ -311,55 +232,131 @@ Proof. - erewrite finite_taus_tau; eauto. Qed. -(**) - -Lemma eq_unalltaus (t1 t2 : itree E R) ot1' - (FT: unalltausF (observe t1) ot1') - (EQV: t1 ≅ t2) : - exists ot2', unalltausF (observe t2) ot2'. +Lemma untaus_untaus : forall (ot1 ot2 ot3: itreeF E R _), + untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. Proof. - genobs t1 ot1. revert t1 Heqot1 t2 EQV. - destruct FT as [Huntaus Hnotau]. - induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. - - eexists. constructor; eauto. inv EQV; simpl; eauto. - - inv EQV; simpobs; try inv Heqot1. - pclearbot. edestruct IHHuntaus as [? []]; eauto. + intros t1 t2 t3. induction 1; simpl; eauto. Qed. -Lemma eq_unalltaus_eqF (t s : itree E R) ot' - (UNTAUS : unalltausF (observe t) ot') - (EQV: t ≅ s) : - exists os', unalltausF (observe s) os' /\ eq_itreeF' eq_itree ot' os'. +Lemma untaus_unalltaus_rev (ot1 ot2 ot3: itreeF E R _) : + untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. Proof. - destruct UNTAUS as [Huntaus Hnotau]. - remember (observe t) as ot. revert s t Heqot EQV. - induction Huntaus; intros; punfold EQV; unfold_eq_itree. - - eexists (observe s). split. - inv EQV; simpobs; eauto. - subst; eauto. - eapply eq_itreeF'_mono; eauto. - intros ? ? [| []]; eauto. - - inv EQV; rewrite <- H0 in Heqot; inversion Heqot; subst. - destruct REL as [| []]. - edestruct IHHuntaus as [? [[]]]; eauto 10. + intros H. revert ot3. + induction H; intros. + - eauto with arith. + - destruct H0 as [Huntaus Hnotau]. + destruct Huntaus. + + exfalso; eauto. + + inv OBS0. inversion H0; subst; eauto. Qed. -Lemma eq_unalltaus_eq (t s : itree E R) t' - (UNTAUS : unalltausF (observe t) (observe t')) - (EQV: t ≅ s) : - exists s', unalltausF (observe s) (observe s') /\ t' ≅ s'. -Proof. - eapply eq_unalltaus_eqF in UNTAUS; try eassumption. - destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. - pfold. eapply eq_itreeF'_mono; eauto. -Qed. +End FiniteTaus. + +Arguments untaus_unalltaus_rev : clear implicits. + +Hint Constructors untausF. +Hint Unfold unalltausF. +Hint Unfold finite_tausF. +Hint Resolve notau_ret. +Hint Resolve notau_vis. +Hint Resolve notau_tau. + +Notation finite_taus t := (finite_tausF (observe t)). +Notation untaus t t' := (untausF (observe t) (observe t')). +Notation unalltaus t t' := (unalltausF (observe t) (observe t')). + +Section EUTT. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +(* Equivalence between visible steps of computation (i.e., [Vis] or + [Ret], parameterized by a relation [eutt] between continuations + in the [Vis] case. *) +Variant eq_notauF {I J} (eutt : I -> J -> Prop) +: itreeF E R1 I -> itreeF E R2 J -> Prop := +| Eutt_ret : forall r1 r2, + RR r1 r2 -> + eq_notauF eutt (RetF r1) (RetF r2) +| Eutt_vis : forall u (e : E u) k1 k2, + (forall x, eutt (k1 x) (k2 x)) -> + eq_notauF eutt (VisF e k1) (VisF e k2). +Hint Constructors eq_notauF. -(* Reflexivity of [eutt_0], modulo a few assumptions. *) -Lemma reflexive_euttF0 I (eutt : relation I) ot : - Reflexive eutt -> notauF ot -> eq_notauF eutt ot ot. +(* +Variant eq_notauF' {I} (eutt : relation I) +: relation (itreeF E R I) := +| Eutt_ret' : forall r, eq_notauF' eutt (RetF r) (RetF r) +| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, + eq_dep _ E _ e1 _ e2 -> + (forall x1 x2, JMeq x1 x2 -> eutt (k1 x1) (k2 x2)) -> + eq_notauF' eutt (VisF e1 k1) (VisF e2 k2). +Hint Constructors eq_notauF'. + +Lemma eq_notauF_eq_eq_notauF': forall I (eutt : relation I) t s, + eq_notauF eutt t s <-> eq_notauF' eutt t s. Proof. - intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. + split; intros EUTT; destruct EUTT; eauto. + - econstructor; intros; subst; eauto. + - assert (u1 = u2) by (inv H; eauto). + subst. apply eq_dep_eq in H. subst. eauto. Qed. +*) + +(* [eutt_ eutt t1 t2] means that, if [t1] or [t2] ever takes a + visible step ([Vis] or [Ret]), then the other takes the same + step, and the subsequent continuations (in the [Vis] case) are + related by [eutt]. In particular, [(t1 = spin)%eq_itree] if + and only if [(t2 = spin)%eq_itree]. Note also that in that + case, the parameter [eutt] is irrelevant. + + This is the relation we will take a fixpoint of. *) +Inductive euttF (eutt : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| euttF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) + (EQV: forall ot1' ot2' + (UNTAUS1: unalltausF ot1 ot1') + (UNTAUS2: unalltausF ot2 ot2'), + eq_notauF eutt ot1' ot2') +. +Hint Constructors euttF. + +Definition eutt_ (eutt : itree E R1 -> itree E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := + euttF eutt (observe t1) (observe t2). +Hint Unfold eutt_. + +(* Paco takes the greatest fixpoints of monotone relations. *) + +Lemma monotone_eq_notauF : forall I J (r r' : I -> J -> Prop) x1 x2 + (IN: eq_notauF r x1 x2) + (LE: r <2= r'), + eq_notauF r' x1 x2. +Proof. pmonauto. Qed. +Hint Resolve monotone_eq_notauF. + +(* [eutt_] is monotone. *) +Lemma monotone_eutt_ : monotone2 eutt_. +Proof. pmonauto. Qed. +Hint Resolve monotone_eutt_ : paco. + +(* We now take the greatest fixpoint of [eutt_]. *) + +(* Equivalence Up To Taus. + + [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) +Definition eutt : itree E R1 -> itree E R2 -> Prop := paco2 eutt_ bot2. + +Global Arguments eutt t1%itree t2%itree. + +Infix "~~" := eutt (at level 70) : itree_scope. + +(* Lemmas about the auxiliary relations. *) + +(* Many have a name [X_Y] to represent an implication + [X _ -> Y _] (possibly with more arguments on either side). *) + +(**) Lemma euttF_tau r t1 t2 t1' t2' (OBS1: TauF t1' = observe t1) @@ -394,7 +391,7 @@ Proof. econstructor; eauto. Qed. -Lemma euttF_vis {u} (r : relation (itree E R)) t1 t2 (e : _ u) k1 k2 +Lemma euttF_vis {u} (r : _ -> _ -> Prop) t1 t2 (e : _ u) k1 k2 (OBS1: VisF e k1 = observe t1) (OBS2: VisF e k2 = observe t2) (REL: forall x, r (k1 x) (k2 x)): @@ -410,30 +407,107 @@ Qed. (**) -Lemma Reflexive_euttF (r : relation (itree E R)) : - Reflexive r -> Reflexive (euttF r). +Lemma eutt_strengthen : + forall r (t1 : itree E R1) (t2 : itree E R2) + (FIN: finite_taus t1 <-> finite_taus t2) + (EQV: forall t1' t2' + (UNT1: unalltaus t1 t1') + (UNT2: unalltaus t2 t2'), + paco2 (eutt_ ∘ gres2 eutt_) r t1' t2'), + paco2 (eutt_ ∘ gres2 eutt_) r t1 t2. +Proof. + intros. pfold. econstructor; eauto. + intros. + hexploit (EQV (go ot1') (go ot2')); eauto. + intros EQV'. punfold EQV'. destruct EQV'. + eapply EQV0; + repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. +Qed. + +End EUTT. + +Hint Constructors eq_notauF. +Hint Constructors euttF. +Hint Resolve monotone_eutt_ : paco. + +Delimit Scope eutt_scope with eutt. + +Section EUTT_eq. + +Context {E : Type -> Type} {R : Type}. + +Let eutt : itree E R -> itree E R -> Prop := eutt eq. + +Infix "~~" := eutt (at level 70). + +Lemma eq_unalltaus (t1 t2 : itree E R) ot1' + (FT: unalltausF (observe t1) ot1') + (EQV: t1 ≅ t2) : + exists ot2', unalltausF (observe t2) ot2'. +Proof. + genobs t1 ot1. revert t1 Heqot1 t2 EQV. + destruct FT as [Huntaus Hnotau]. + induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. + - eexists. constructor; eauto. inv EQV; simpl; eauto. + - inv EQV; simpobs; try inv Heqot1. + pclearbot. edestruct IHHuntaus as [? []]; eauto. +Qed. + +Lemma eq_unalltaus_eqF (t s : itree E R) ot' + (UNTAUS : unalltausF (observe t) ot') + (EQV: t ≅ s) : + exists os', unalltausF (observe s) os' /\ eq_itreeF' eq_itree ot' os'. +Proof. + destruct UNTAUS as [Huntaus Hnotau]. + remember (observe t) as ot. revert s t Heqot EQV. + induction Huntaus; intros; punfold EQV; unfold_eq_itree. + - eexists (observe s). split. + inv EQV; simpobs; eauto. + subst; eauto. + eapply eq_itreeF'_mono; eauto. + intros ? ? [| []]; eauto. + - inv EQV; rewrite <- H0 in Heqot; inversion Heqot; subst. + destruct REL as [| []]. + edestruct IHHuntaus as [? [[]]]; eauto 10. +Qed. + +Lemma eq_unalltaus_eq (t s : itree E R) t' + (UNTAUS : unalltausF (observe t) (observe t')) + (EQV: t ≅ s) : + exists s', unalltausF (observe s) (observe s') /\ t' ≅ s'. +Proof. + eapply eq_unalltaus_eqF in UNTAUS; try eassumption. + destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. + pfold. eapply eq_itreeF'_mono; eauto. +Qed. + +(* Reflexivity of [eq_notauF], modulo a few assumptions. *) +Lemma Reflexive_eq_notauF I (eq_ : I -> I -> Prop) (ot : itreeF E R I) : + Reflexive eq_ -> notauF ot -> eq_notauF eq eq_ ot ot. +Proof. + intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. +Qed. + +Instance Reflexive_euttF (r : itree E R -> itree E R -> Prop) : + Reflexive r -> Reflexive (euttF eq r). Proof. split. - reflexivity. - intros. erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply reflexive_euttF0; eauto using unalltaus_notau. + apply Reflexive_eq_notauF; eauto using unalltaus_notau. Qed. -Lemma eutt_refl r x : paco2 eutt_ r x x. +Instance Reflexive_eutt (r : itree E R -> itree E R -> Prop) : + Reflexive (paco2 (eutt_ eq) r). Proof. - revert x. pcofix CIH. + pcofix CIH. intros. pfold. apply Reflexive_euttF. eauto. Qed. -(* [eutt] is an equivalence relation. *) -Global Instance Reflexive_eutt: (Reflexive eutt). -Proof. - repeat intro. apply eutt_refl. -Qed. - -Global Instance Symmetric_eutt -: Symmetric eutt. +Instance Symmetric_eutt (r : itree E R -> itree E R -> Prop) + (Sr : Symmetric r) : + Symmetric (paco2 (eutt_ eq) r). Proof. pcofix Symmetric_eutt. intros t1 t2 H12. @@ -444,7 +518,7 @@ Proof. - symmetry; assumption. - intros. hexploit H12; eauto. intros. inv H; eauto. - econstructor. intros. specialize (H0 x). pclearbot. eauto. + econstructor. intros. destruct (H0 x); eauto. Qed. Global Instance Transitive_eutt : Transitive eutt. @@ -463,10 +537,11 @@ Proof. destruct I1 as [n2' [t2' TAUS2]]; eauto. hexploit H12; eauto. intros REL1. hexploit H23; eauto. intros REL2. - destruct REL1; inversion REL2; clear REL2; eauto. - auto_inj_pair2; subst. - econstructor. intros. - specialize (H x); specialize (H6 x). pclearbot. eauto. + destruct REL1; inversion REL2; clear REL2. + + subst; eauto. + + auto_inj_pair2; subst. + econstructor; auto. intros. + specialize (H x); specialize (H6 x). pclearbot. eauto. Qed. (**) @@ -479,7 +554,7 @@ Proof. - intros t1' t2' H1 H2. eapply unalltaus_tau in H1; eauto. assert (X := unalltaus_injective _ _ _ H1 H2). - subst; apply reflexive_euttF0; eauto using unalltaus_notau. + subst; apply Reflexive_eq_notauF; eauto using unalltaus_notau. left. apply Reflexive_eutt. Qed. @@ -496,37 +571,25 @@ Proof. - eapply untaus_finite_taus; eauto. - induction H; intros. + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply reflexive_euttF0; eauto using unalltaus_notau. + apply Reflexive_eq_notauF; eauto using unalltaus_notau. left; apply Reflexive_eutt. + eapply unalltaus_tau in UNTAUS1; eauto. Qed. -End EUTT. +(* TODO: Send to paco *) +Global Instance Symmetric_bot2 (A : Type) : @Symmetric A bot2. +Proof. auto. Qed. -Hint Constructors eq_notauF. -Hint Constructors eq_notauF'. -Hint Constructors untausF. -Hint Unfold unalltausF. -Hint Unfold finite_tausF. -Hint Constructors euttF. -Hint Resolve monotone_eutt_ : paco. -Hint Resolve notau_ret. -Hint Resolve notau_vis. -Hint Resolve notau_tau. - -Delimit Scope eutt_scope with eutt. - -Infix "~~" := eutt (at level 70). - -Notation finite_taus t := (finite_tausF (observe t)). -Notation untaus t t' := (untausF (observe t) (observe t')). -Notation unalltaus t t' := (unalltausF (observe t) (observe t')). +Global Instance Transitive_bot2 (A : Type) : @Transitive A bot2. +Proof. auto. Qed. (* We can now rewrite with [eutt] equalities. *) -Instance Equivalence_eutt E R : @Equivalence (itree E R) eutt. +Global Instance Equivalence_eutt : @Equivalence (itree E R) eutt. Proof. constructor; typeclasses eauto. Qed. -Instance subrelation_eq_eutt {E R} : subrelation (@eq_itree E R) eutt. +(**) + +Instance subrelation_eq_eutt : subrelation (@eq_itree E R) eutt. Proof. pcofix CIH. intros. pfold. econstructor. @@ -538,25 +601,20 @@ Proof. eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. Qed. -Instance subrelation_go_sim_eq_eutt {E R} : subrelation (go_sim (@eq_itree E R)) (go_sim (@eutt E R)). +Instance subrelation_go_sim_eq_eutt : subrelation (go_sim (@eq_itree E R)) (go_sim eutt). Proof. repeat intro. red. red in H. rewrite H. reflexivity. Qed. -Instance eutt_go {E R} : - Proper (go_sim (@eutt E R) ==> @eutt E R) (@go E R). -Proof. - repeat intro. eauto. -Qed. +Instance eutt_go : Proper (go_sim eutt ==> eutt) go. +Proof. repeat intro; eauto. Qed. -Instance eutt_observe {E R} : - Proper (@eutt E R ==> go_sim (@eutt E R)) (@observe E R). +Instance eutt_observe : Proper (eutt ==> go_sim eutt) observe. Proof. repeat intro. punfold H. pfold. destruct H. econstructor; eauto. Qed. -Instance eutt_tauF {E R} : - Proper (@eutt E R ==> go_sim (@eutt E R)) (@TauF E R _). +Instance eutt_tauF : Proper (eutt ==> go_sim eutt) (fun t => TauF t). Proof. repeat intro. pfold. punfold H. destruct H. econstructor. @@ -566,8 +624,8 @@ Proof. - intros. eapply EQV; eapply unalltaus_tau; eauto. Qed. -Instance eutt_VisF {E R u} (e: E u) : - Proper (pointwise_relation _ eutt ==> go_sim (@eutt E R)) (VisF e). +Instance eutt_VisF {u} (e: E u) : + Proper (pointwise_relation _ eutt ==> go_sim eutt) (VisF e). Proof. repeat intro. red in H. pfold. econstructor. - repeat econstructor. @@ -579,20 +637,63 @@ Proof. econstructor; intros; left; apply H. Qed. -Instance eq_itree_notauF {E R} : - Proper (go_sim (@eq_itree E R) ==> flip impl) (@notauF E R _). +Instance eq_itree_notauF : + Proper (go_sim (@eq_itree E R) ==> flip impl) notauF. Proof. repeat intro. punfold H. inv H; simpl in *; subst; eauto. Qed. (* If [t1] and [t2] are equivalent, then either both start with finitely many taus, or both [spin]. *) -Instance eutt_finite_taus {E R} : - Proper (go_sim (@eutt E R) ==> flip impl) (@finite_tausF E R). +Instance eutt_finite_taus : + Proper (go_sim eutt ==> flip impl) finite_tausF. Proof. repeat intro. punfold H. eapply H. eauto. Qed. +Inductive eutt_trans_clo (r: itree E R -> itree E R -> Prop) : + itree E R -> itree E R -> Prop := +| eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) + (EQVl: t1 ~~ t2) + (EQVr: t4 ~~ t3) + (REL: r t2 t3) + : eutt_trans_clo r t1 t4 +. +Hint Constructors eutt_trans_clo. + +Lemma eutt_clo_trans : weak_respectful2 (eutt_ eq) eutt_trans_clo. +Proof. + econstructor; [pmonauto|]. + intros. inv PR. + punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. + { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } + + intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. + hexploit EQV; eauto. intros EUTT1. + apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. + hexploit EQV0; eauto. intros EUTT2. + apply GF in REL. destruct REL. + hexploit EQV1; eauto. intros EUTT3. + destruct EUTT1; destruct EUTT2; + try (solve [subst; inversion EUTT3; auto]). + remember (VisF _ _) as o2 in EUTT3. + remember (VisF _ _) as o3 in EUTT3. + inversion EUTT3; subst; try discriminate. + inversion H2; clear H2; inversion H3; clear H3. + subst; auto_inj_pair2; subst. + econstructor. intros. + specialize (H x); specialize (H0 x); specialize (H1 x). + pclearbot. eauto using rclo2. +Qed. + +End EUTT_eq. + +Arguments eutt_clo_trans : clear implicits. + +Hint Constructors eutt_trans_clo. + +Infix "~~" := (eutt eq) (at level 70). + (* Lemmas about [bind]. *) Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) @@ -640,79 +741,6 @@ Proof. - apply finite_taus_tau. eauto. Qed. -Lemma untaus_eq_idx E R: forall (ot1 ot2: itreeF E R _), - untausF ot1 ot2 -> untausF ot1 ot2. -Proof. intros; subst; eauto. Qed. - -Lemma untaus_untaus E R: forall (ot1 ot2 ot3: itreeF E R _), - untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. -Proof. - intros t1 t2 t3. induction 1; simpl; eauto. -Qed. - -Lemma untaus_unalltus_rev E R (ot1 ot2 ot3: itreeF E R _) : - untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. -Proof. - intros H. revert ot3. - induction H; intros. - - eauto using untaus_eq_idx with arith. - - destruct H0 as [Huntaus Hnotau]. - destruct Huntaus. - + exfalso; eauto. - + inv OBS0. inversion H0; subst; eauto. -Qed. - -Lemma eutt_strengthen {E R}: - forall r (t1 t2: itree E R) - (FIN: finite_taus t1 <-> finite_taus t2) - (EQV: forall t1' t2' - (UNT1: unalltaus t1 t1') - (UNT2: unalltaus t2 t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1' t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2. -Proof. - intros. pfold. econstructor; eauto. - intros. - hexploit (EQV (go ot1') (go ot2')); eauto. - intros EQV'. punfold EQV'. destruct EQV'. - eapply EQV0; - repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. -Qed. - -Inductive eutt_trans_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ~~ t2) - (EQVr: t4 ~~ t3) - (REL: r t2 t3) - : eutt_trans_clo r t1 t4 -. -Hint Constructors eutt_trans_clo. - -Lemma eutt_clo_trans E R: weak_respectful2 (@eutt_ E R) eutt_trans_clo. -Proof. - econstructor; [pmonauto|]. - intros. inv PR. - punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. - { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } - - intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. - hexploit EQV; eauto. intros EUTT1. - apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. - hexploit EQV0; eauto. intros EUTT2. - apply GF in REL. destruct REL. - hexploit EQV1; eauto. intros EUTT3. - destruct EUTT1; destruct EUTT2; - try (solve [inversion EUTT3; auto]). - remember (VisF _ _) as o2 in EUTT3. - remember (VisF _ _) as o3 in EUTT3. - inversion EUTT3; subst; try discriminate. - inversion H2; clear H2; inversion H3; clear H3. - subst; auto_inj_pair2; subst. - econstructor. intros. - specialize (H x); specialize (H0 x); specialize (H1 x). - pclearbot. eauto using rclo2. -Qed. - Inductive eutt_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := | eutt_bind_clo_intro U (t1 t2: itree E U) k1 k2 (EQV: t1 ~~ t2) @@ -741,7 +769,7 @@ Proof. eapply IHFT2; eauto using unalltaus_tau'. Qed. -Lemma eutt_clo_bind E R: weak_respectful2 (@eutt_ E R) eutt_bind_clo. +Lemma eutt_clo_bind E R: weak_respectful2 (@eutt_ E R _ eq) eutt_bind_clo. Proof. econstructor; [pmonauto|]. intros. destruct PR. split. @@ -757,8 +785,8 @@ Proof. destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. - hexploit untaus_unalltus_rev; [apply UT1| |]. eauto. intros UAT1. - hexploit untaus_unalltus_rev; [apply UT2| |]; eauto. intros UAT2. + hexploit @untaus_unalltaus_rev; [apply UT1| |]. eauto. intros UAT1. + hexploit @untaus_unalltaus_rev; [apply UT2| |]; eauto. intros UAT2. inv EQV. + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. eapply GF in REL. destruct REL. @@ -772,9 +800,9 @@ Qed. (* [eutt] is a congruence wrt. [bind] *) Instance eutt_bind {E R S} : - Proper (@eutt E R ==> - pointwise_relation _ eutt ==> - @eutt E S) ITree.bind. + Proper (eutt eq ==> + pointwise_relation _ (eutt eq) ==> + eutt eq) (@ITree.bind E R S). Proof. repeat intro. pupto2_init. pupto2 eutt_clo_bind. econstructor; eauto. @@ -782,39 +810,40 @@ Proof. Qed. Instance eutt_paco {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (paco2 (eutt_ ∘ gres2 eutt_) r). + Proper (eutt eq ==> eutt eq ==> flip impl) + (paco2 (@eutt_ E R _ eq ∘ gres2 (eutt_ eq)) r). Proof. repeat intro. pupto2 eutt_clo_trans. eauto. Qed. Instance eutt_gres {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (gres2 eutt_ r). + Proper (eutt eq ==> eutt eq ==> flip impl) + (gres2 (@eutt_ E R _ eq) r). Proof. repeat intro. pupto2 eutt_clo_trans. eauto. Qed. Instance eutt_map {E R S} : - Proper (pointwise_relation _ eq ==> @eutt E R ==> @eutt E S) ITree.map. + Proper (pointwise_relation _ eq ==> eutt eq ==> eutt eq) (@ITree.map E R S). Proof. Admitted. Instance eutt_forever {E R S} : - Proper (@eutt E R ==> @eutt E S) ITree.forever. + Proper (eutt eq ==> eutt eq) (@ITree.forever E R S). Proof. Admitted. + Instance eutt_when {E} (b : bool) : - Proper (@eutt E unit ==> @eutt E unit) (ITree.when b). + Proper (eutt eq ==> eutt eq) (@ITree.when E b). Proof. Admitted. Lemma eutt_map_map {E R S T} (f : R -> S) (g : S -> T) (t : itree E R) : - eutt (ITree.map g (ITree.map f t)) - (ITree.map (fun x => g (f x)) t). + eutt eq (ITree.map g (ITree.map f t)) + (ITree.map (fun x => g (f x)) t). Proof. - rewrite map_map. reflexivity. + apply subrelation_eq_eutt, map_map. Qed. Notation itree' E R := (itreeF E R (itree E R)). @@ -833,7 +862,7 @@ Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : euttF1' r t1 t2.(observe) -> euttF1' r t1 (TauF t2) | euttF1_euttF0 : forall t1 t2, - eq_notauF r t1 t2 -> + eq_notauF eq r t1 t2 -> euttF1' r t1 t2 . @@ -842,7 +871,7 @@ Definition euttF1 {E R} (r : relation (itree E R)) : Lemma euttF1_euttF {E R} (r : relation (itree E R)) : forall t1 t2, - euttF1 r t1 t2 -> eutt_ r t1 t2. + euttF1 r t1 t2 -> eutt_ eq r t1 t2. Proof. Admitted. @@ -888,7 +917,7 @@ Proof. red. eauto using euttF'_mon, paco2_mon_gen. Qed. Hint Resolve monotone_eutt'_ : paco. Lemma eutt__is_eutt'_ {E R} r (t1 t2: itree E R) : - eutt_ r t1 t2 <-> eutt'_ r t1 t2. + eutt_ eq r t1 t2 <-> eutt'_ r t1 t2. Proof. split; intros. { revert t1 t2 H. pcofix CIH'. intros. destruct H0. @@ -962,13 +991,13 @@ Proof. Qed. Lemma eutt_is_eutt' {E R} r (t1 t2: itree E R) : - paco2 eutt_ r t1 t2 <-> paco2 eutt'_ r t1 t2. + paco2 (eutt_ eq) r t1 t2 <-> paco2 eutt'_ r t1 t2. Proof. split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__is_eutt'_; eauto. Qed. Lemma eutt_is_eutt'_gres {E R} r (t1 t2: itree E R) : - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2 <-> paco2 (eutt'_ ∘ gres2 eutt'_) r t1 t2. + paco2 (eutt_ eq ∘ gres2 (eutt_ eq)) r t1 t2 <-> paco2 (eutt'_ ∘ gres2 eutt'_) r t1 t2. Proof. split; intros. - eapply paco2_mon_gen; eauto. intros. @@ -984,8 +1013,8 @@ Proof. Qed. Instance eutt'_paco {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (paco2 (eutt'_ ∘ gres2 eutt'_) r). + Proper (eutt eq ==> eutt eq ==> flip impl) + (paco2 (@eutt'_ E R ∘ gres2 eutt'_) r). Proof. repeat intro. rewrite <-eutt_is_eutt'_gres. @@ -994,8 +1023,8 @@ Proof. Qed. Instance eutt'_gres {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (gres2 eutt'_ r). + Proper (eutt eq ==> eutt eq ==> flip impl) + (gres2 (@eutt'_ E R) r). Proof. repeat intro. rewrite grespectful2_iff; [|intros; erewrite eutt__is_eutt'_; reflexivity]. diff --git a/theories/Eq/UpToTausH.v b/theories/Eq/UpToTausH.v deleted file mode 100644 index 45cc90b1..00000000 --- a/theories/Eq/UpToTausH.v +++ /dev/null @@ -1,1019 +0,0 @@ -(* Equivalence up to taus *) -(* We consider tau as an "internal step", that should not be - visible to the outside world, so adding or removing [Tau] - constructors from an itree should produce an equivalent itree. - - We must be careful because there may be infinite sequences of - taus (i.e., [spin]). Here we shall only allow inserting finitely - many taus between any two visible steps ([Ret] or [Vis]), so that - [spin] is only related to itself. The main consequence of this - choice is that equivalence up to taus is an equivalence relation. - *) - -(* TODO: - - relate to Eq.Eq.eq_itree - - prove monad laws (see [eutt_bind_bind_fail]) - - make [eutt] easier to work with ([eutt_bind] is already a mess) - *) - -Require Import Paco.paco. - -From Coq Require Import - Program - Lia - Classes.RelationClasses - Classes.Morphisms - Setoids.Setoid - Relations.Relations - Logic.JMeq Logic.EqdepFacts. - -From ITree Require Import Core Eq.Eq. - -Local Open Scope itree. - -(* [notau t] holds when [t] does not start with a [Tau]. *) -Definition notauF {E R I} (t : itreeF E R I) : Prop := - match t with - | TauF _ => False - | _ => True - end. -Arguments notauF [E R I] t. - -Notation notau t := (notauF (observe t)). - -Section EUTT. - -Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). - -(* Equivalence between visible steps of computation (i.e., [Vis] or - [Ret], parameterized by a relation [eutt] between continuations - in the [Vis] case. *) -Variant eq_notauF {I} (eutt : relation I) -: relation (itreeF E R I) := -| Eutt_ret : forall r r', RR r r' -> eq_notauF eutt (RetF r) (RetF r') -| Eutt_vis : forall u (e : E u) k1 k2, - (forall x, eutt (k1 x) (k2 x)) -> - eq_notauF eutt (VisF e k1) (VisF e k2). -Hint Constructors eq_notauF. - -(* -Variant eq_notauF' {I} (eutt : relation I) -: relation (itreeF E R I) := -| Eutt_ret' : forall r, eq_notauF' eutt (RetF r) (RetF r) -| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, - eq_dep _ E _ e1 _ e2 -> - (forall x1 x2, JMeq x1 x2 -> eutt (k1 x1) (k2 x2)) -> - eq_notauF' eutt (VisF e1 k1) (VisF e2 k2). -Hint Constructors eq_notauF'. - -Lemma eq_notauF_eq_eq_notauF': forall I (eutt : relation I) t s, - eq_notauF eutt t s <-> eq_notauF' eutt t s. -Proof. - split; intros EUTT; destruct EUTT; eauto. - - econstructor; intros; subst; eauto. - - assert (u1 = u2) by (inv H; eauto). - subst. apply eq_dep_eq in H. subst. eauto. -Qed. -*) - - -(* [untaus t' t] holds when [t = Tau (... Tau t' ...)]: - [t] steps to [t'] by "peeling off" a finite number of [Tau]. - "Peel off" means to remove only taus at the root of the tree, - not any behind a [Vis] step). *) -Inductive untausF : relation (itreeF E R _) := -| NoTau ot0 : untausF ot0 ot0 -| OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 -. -Hint Constructors untausF. - -Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. -Hint Unfold unalltausF. - - -(* [finite_taus t] holds when [t] has a finite number of taus - to peel. *) -Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. -Hint Unfold finite_tausF. - -(* [eutt_ eutt t1 t2] means that, if [t1] or [t2] ever takes a - visible step ([Vis] or [Ret]), then the other takes the same - step, and the subsequent continuations (in the [Vis] case) are - related by [eutt]. In particular, [(t1 = spin)%eq_itree] if - and only if [(t2 = spin)%eq_itree]. Note also that in that - case, the parameter [eutt] is irrelevant. - - This is the relation we will take a fixpoint of. *) -Inductive euttF (eutt : relation (itree E R)) (ot1 ot2: itreeF E R (itree E R)) : Prop := -| euttF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) - (EQV: forall ot1' ot2' - (UNTAUS1: unalltausF ot1 ot1') - (UNTAUS2: unalltausF ot2 ot2'), - eq_notauF eutt ot1' ot2') -. -Hint Constructors euttF. - -Definition eutt_ (eutt : relation (itree E R)) (t1 t2 : itree E R) : Prop := - euttF eutt (observe t1) (observe t2). -Hint Unfold eutt_. - -(* Paco takes the greatest fixpoints of monotone relations. *) - -Lemma monotone_eq_notauF : forall I (r r' : relation I) x1 x2 - (IN: eq_notauF r x1 x2) - (LE: r <2= r'), - eq_notauF r' x1 x2. -Proof. pmonauto. Qed. -Hint Resolve monotone_eq_notauF. - -(* [eutt_] is monotone. *) -Lemma monotone_eutt_ : monotone2 eutt_. -Proof. pmonauto. Qed. -Hint Resolve monotone_eutt_ : paco. - -(* We now take the greatest fixpoint of [eutt_]. *) - -(* Equivalence Up To Taus. - - [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) -Definition eutt : relation (itree E R) := paco2 eutt_ bot2. - -Global Arguments eutt t1%itree t2%itree. - -Infix "~~" := eutt (at level 70) : itree_scope. - -(* Lemmas about the auxiliary relations. *) - -(* Many have a name [X_Y] to represent an implication - [X _ -> Y _] (possibly with more arguments on either side). *) - -Lemma untaus_all ot ot' : - untausF ot ot' -> notauF ot' -> unalltausF ot ot'. -Proof. induction 1; eauto. Qed. - -Lemma unalltaus_notau ot ot' : unalltausF ot ot' -> notauF ot'. -Proof. intros. induction H; eauto. Qed. - -Lemma notau_tau I (ot : itreeF E R I) (t0 : I) - (NOTAU : notauF ot) - (OBS: TauF t0 = ot): False. -Proof. subst. auto. Qed. -Hint Resolve notau_tau. - -Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. -Proof. subst. red. eauto. Qed. -Hint Resolve notau_ret. - -Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : @notauF E R I ot. -Proof. intros. subst. red. eauto. Qed. -Hint Resolve notau_vis. - -(* If [t] does not start with [Tau], removing all [Tau] does - nothing. Can be thought of as [notau_unalltaus] composed with - [unalltaus_injective] (below). *) -Lemma unalltaus_notau_id ot ot' : - unalltausF ot ot' -> notauF ot -> ot = ot'. -Proof. - intros [[ | ]] ?; eauto. exfalso; eauto. -Qed. - -(* There is only one way to peel off all taus. *) -Lemma unalltaus_injective ot ot1 ot2 : - unalltausF ot ot1 -> unalltausF ot ot2 -> ot1 = ot2. -Proof. - intros [Huntaus Hnotau]. revert ot2 Hnotau. - induction Huntaus; intros; eauto using unalltaus_notau_id. - eapply IHHuntaus; eauto. - destruct H as [Huntaus' Hnotau']. - destruct Huntaus'. - + exfalso; eauto. - + subst. inversion OBS0; subst; eauto. -Qed. - -(* Adding a [Tau] to [t1] then peeling them all off produces - the same result as peeling them all off from [t1]. *) -Lemma unalltaus_tau t ot1 ot2 - (OBS: TauF t = ot1) - (TAUS: unalltausF ot1 ot2): - unalltausF (observe t) ot2. -Proof. - destruct TAUS as [Huntaus Hnotau]. - destruct Huntaus. - - exfalso; eauto. - - subst; inversion OBS0; subst; eauto. -Qed. - -Lemma unalltaus_tau' t ot1 ot2 - (OBS: TauF t = ot1) - (TAUS: unalltausF (observe t) ot2): - unalltausF ot1 ot2. -Proof. - destruct TAUS as [Huntaus Hnotau]. - subst. eauto. -Qed. - -Lemma notauF_untausF ot1 ot2 - (NOTAU : notauF ot1) - (UNTAUS : untausF ot1 ot2) : ot1 = ot2. -Proof. - destruct UNTAUS; eauto. - exfalso; eauto. -Qed. - -Definition untausF_shift (t1 t2 : itree E R) : - untausF (TauF t1) (TauF t2) -> untausF (observe t1) (observe t2). -Proof. - intros H. - inversion H; subst. - { constructor. } - clear H. - inversion OBS; subst; clear OBS. - remember (observe t1) as ot1. - remember (TauF t2) as tt2. - generalize dependent t1. - generalize dependent t2. - induction TAUS; intros; subst; econstructor; eauto. -Qed. - -Definition untausF_trans (t1 t2 t3 : itreeF E R _) : - untausF t1 t2 -> untausF t2 t3 -> untausF t1 t3. -Proof. - induction 1; auto. - subst; econstructor; auto. -Qed. - -Definition untausF_strong_ind - (P : itreeF E R _ -> Prop) - (ot1 ot2 : itreeF E R _) - (Huntaus : untausF ot1 ot2) - (Hnotau : notauF ot2) - (STEP : forall ot1 - (Huntaus : untausF ot1 ot2) - (IH: forall t1' oti - (NEXT: ot1 = TauF t1') - (UNTAUS: untausF (observe t1') oti), - P oti), - P ot1) - : P ot1. -Proof. - enough (H : forall oti, - untausF ot1 oti -> - untausF oti ot2 -> - P oti - ). - { apply H; eauto. } - revert STEP. - induction Huntaus; intros; subst. - - eapply STEP; eauto. - intros; subst. dependent destruction H; inv Hnotau. - - destruct H0; auto. - subst. apply STEP; eauto. - intros. inv NEXT. - apply IHHuntaus; eauto. - + clear -H UNTAUS. - remember (TauF t') as ott'. remember (TauF t1') as ott1'. - move H at top. revert_until H. induction H; intros; subst. - * inv Heqott1'. eauto. - * inv Heqott'. dependent destruction H; eauto. - + genobs t1' ot1'. revert UNTAUS. clear -Hnotau H0. induction H0; intros. - * dependent destruction UNTAUS; eauto. - subst. simpobs. inv Hnotau. - * subst. dependent destruction UNTAUS; eauto. -Qed. - -(* If [t] does not start with [Tau], then it starts with finitely - many [Tau]. *) -Lemma notau_finite_taus ot : notauF ot -> finite_tausF ot. -Proof. eauto. Qed. - -(* [Vis] and [Ret] start with no taus, of course. *) -Lemma finite_taus_ret ot (r : R) (OBS: RetF r = ot) : finite_tausF ot. -Proof. eauto 10. Qed. - -Lemma finite_taus_vis {u} ot (e : E u) (k : u -> itree E R) (OBS: VisF e k = ot): - finite_tausF ot. -Proof. eauto 10. Qed. - -(* [finite_taus] is preserved by removing or adding one [Tau]. *) -Lemma finite_taus_tau t': - finite_tausF (TauF t') <-> finite_tausF (observe t'). -Proof. - split; intros [? [Huntaus Hnotau]]; eauto 10. - inv Huntaus. - - contradiction. - - inv OBS; eauto. -Qed. - -(* (* [finite_taus] is preserved by removing or adding any finite *) -(* number of [Tau]. *) *) -Lemma untaus_finite_taus ot ot': - untausF ot ot' -> (finite_tausF ot <-> finite_tausF ot'). -Proof. - induction 1; intros; subst. - - reflexivity. - - erewrite finite_taus_tau; eauto. -Qed. - -(**) - -Lemma eq_unalltaus (t1 t2 : itree E R) ot1' - (FT: unalltausF (observe t1) ot1') - (EQV: t1 ≅ t2) : - exists ot2', unalltausF (observe t2) ot2'. -Proof. - genobs t1 ot1. revert t1 Heqot1 t2 EQV. - destruct FT as [Huntaus Hnotau]. - induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. - - eexists. constructor; eauto. inv EQV; simpl; eauto. - - inv EQV; simpobs; try inv Heqot1. - pclearbot. edestruct IHHuntaus as [? []]; eauto. -Qed. - -Lemma eq_unalltaus_eqF (t s : itree E R) ot' - (UNTAUS : unalltausF (observe t) ot') - (EQV: t ≅ s) : - exists os', unalltausF (observe s) os' /\ eq_itreeF' eq_itree ot' os'. -Proof. - destruct UNTAUS as [Huntaus Hnotau]. - remember (observe t) as ot. revert s t Heqot EQV. - induction Huntaus; intros; punfold EQV; unfold_eq_itree. - - eexists (observe s). split. - inv EQV; simpobs; eauto. - subst; eauto. - eapply eq_itreeF'_mono; eauto. - intros ? ? [| []]; eauto. - - inv EQV; rewrite <- H0 in Heqot; inversion Heqot; subst. - destruct REL as [| []]. - edestruct IHHuntaus as [? [[]]]; eauto 10. -Qed. - -Lemma eq_unalltaus_eq (t s : itree E R) t' - (UNTAUS : unalltausF (observe t) (observe t')) - (EQV: t ≅ s) : - exists s', unalltausF (observe s) (observe s') /\ t' ≅ s'. -Proof. - eapply eq_unalltaus_eqF in UNTAUS; try eassumption. - destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. - pfold. eapply eq_itreeF'_mono; eauto. -Qed. - -(* Reflexivity of [eutt_0], modulo a few assumptions. *) -Lemma reflexive_euttF0 I (eutt : relation I) ot : - Reflexive RR -> - Reflexive eutt -> notauF ot -> eq_notauF eutt ot ot. -Proof. - intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. -Qed. - -Lemma euttF_tau r t1 t2 t1' t2' - (OBS1: TauF t1' = observe t1) - (OBS2: TauF t2' = observe t2) - (REL: eutt_ r t1' t2'): - eutt_ r t1 t2. -Proof. - intros. destruct REL. econstructor. - - simpobs. rewrite !finite_taus_tau. eauto. - - intros. eapply EQV; eapply unalltaus_tau; eauto. -Qed. - -Lemma euttF_tau_left r t1 t2 t1' - (OBS: TauF t1 = observe t1') - (REL: eutt_ r t1' t2): - eutt_ r t1 t2. -Proof. - intros. destruct REL. econstructor. - - rewrite <- FIN. symmetry. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. - - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS1. constructor; auto. - econstructor; eauto. -Qed. - -Lemma euttF_tau_right r t1 t2 t2' - (OBS: TauF t2 = observe t2') - (REL: eutt_ r t1 t2'): - eutt_ r t1 t2. -Proof. - intros. destruct REL. econstructor. - - rewrite FIN. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. - - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. - econstructor; eauto. -Qed. - -Lemma euttF_vis {u} (r : relation (itree E R)) t1 t2 (e : _ u) k1 k2 - (OBS1: VisF e k1 = observe t1) - (OBS2: VisF e k2 = observe t2) - (REL: forall x, r (k1 x) (k2 x)): - eutt_ r t1 t2. -Proof. - intros. econstructor. - - split; intros; eapply notau_finite_taus; eauto. - - intros. - apply unalltaus_notau_id in UNTAUS1; eauto. - apply unalltaus_notau_id in UNTAUS2; eauto. - simpobs. subst. eauto. -Qed. - -(**) - -Lemma Reflexive_euttF (r : relation (itree E R)) : - Reflexive RR -> - Reflexive r -> Reflexive (euttF r). -Proof. - split. - - reflexivity. - - intros. - erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply reflexive_euttF0; eauto using unalltaus_notau. -Qed. - -Context {Reflexive_RR : Reflexive RR}. - -Lemma eutt_refl r x : paco2 eutt_ r x x. -Proof. - revert x. pcofix CIH. - intros. pfold. apply Reflexive_euttF. eauto. - right. eauto. -Qed. - -(* [eutt] is an equivalence relation. *) -Global Instance Reflexive_eutt: (Reflexive eutt). -Proof. - repeat intro. apply eutt_refl. -Qed. - -Global Instance Symmetric_eutt (SRR : Symmetric RR) -: Symmetric eutt. -Proof. - pcofix Symmetric_eutt. - intros t1 t2 H12. - punfold H12. - pfold. - destruct H12 as [I12 H12]. - split. - - symmetry; assumption. - - intros. hexploit H12; eauto. intros. - inv H; eauto. - econstructor. intros. specialize (H0 x). pclearbot. eauto. -Qed. - -Global Instance Transitive_eutt (TRR : Transitive RR) : Transitive eutt. -Proof. - pcofix Transitive_eutt. - intros t1 t2 t3 H12 H23. - punfold H12. - punfold H23. - pfold. - destruct H12 as [I12 H12]. - destruct H23 as [I23 H23]. - split. - - etransitivity; eauto. - - intros t1' t3' H1 H3. - destruct I12 as [I1 I2]. - destruct I1 as [n2' [t2' TAUS2]]; eauto. - hexploit H12; eauto. intros REL1. - hexploit H23; eauto. intros REL2. - destruct REL1; inversion REL2; clear REL2; eauto. - auto_inj_pair2; subst. - econstructor. intros. - specialize (H x); specialize (H6 x). pclearbot. eauto. -Qed. - -(**) - -(* [eutt] is preserved by removing one [Tau]. *) -Lemma tauF_eutt (t t': itree E R) (OBS: TauF t' = observe t): t ~~ t'. -Proof. - pfold. split. - - simpobs. rewrite finite_taus_tau. reflexivity. - - intros t1' t2' H1 H2. - eapply unalltaus_tau in H1; eauto. - assert (X := unalltaus_injective _ _ _ H1 H2). - subst; apply reflexive_euttF0; eauto using unalltaus_notau. - left. apply Reflexive_eutt. -Qed. - -Lemma tau_eutt (t: itree E R) : Tau t ~~ t. -Proof. - eapply tauF_eutt. eauto. -Qed. - -(* [eutt] is preserved by removing all [Tau]. *) -Lemma untaus_eutt (t t' : itree E R) : untausF (observe t) (observe t') -> t ~~ t'. -Proof. - intros H. - pfold. split. - - eapply untaus_finite_taus; eauto. - - induction H; intros. - + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply reflexive_euttF0; eauto using unalltaus_notau. - left; apply Reflexive_eutt. - + eapply unalltaus_tau in UNTAUS1; eauto. -Qed. - -End EUTT. - -Hint Constructors eq_notauF. -(* Hint Constructors eq_notauF'. *) -Hint Constructors untausF. -Hint Unfold unalltausF. -Hint Unfold finite_tausF. -Hint Constructors euttF. -Hint Resolve monotone_eutt_ : paco. -Hint Resolve notau_ret. -Hint Resolve notau_vis. -Hint Resolve notau_tau. - -Delimit Scope eutt_scope with eutt. - -Infix "~~" := (@eutt _ _ eq) (at level 70). -Infix "~[ RR ]~" := (@eutt _ _ RR) (at level 70). - -Notation finite_taus t := (finite_tausF (observe t)). -Notation untaus t t' := (untausF (observe t) (observe t')). -Notation unalltaus t t' := (unalltausF (observe t) (observe t')). - -(* We can now rewrite with [eutt] equalities. *) -Instance Equivalence_eutt E R RR (ERR : Equivalence RR) -: @Equivalence (itree E R) (eutt RR). -Proof. constructor; typeclasses eauto. Qed. - -Instance subrelation_eq_eutt {E R RR} (RRR : Reflexive RR) -: subrelation (@eq_itree E R) (eutt RR). -Proof. - pcofix CIH. intros. - pfold. econstructor. - { split; [|symmetry in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } - - intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. - hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. - inv EQV'; simpobs; eauto. - eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. -Qed. - -Instance subrelation_go_sim_eq_eutt {E R RR} {RRR : Reflexive RR} -: subrelation (go_sim (@eq_itree E R)) (go_sim (@eutt E R RR)). -Proof. - repeat intro. red. red in H. eapply subrelation_eq_eutt; eauto. -Qed. - -Instance eutt_go {E R RR} : - Proper (go_sim (@eutt E R RR) ==> @eutt E R RR) (@go E R). -Proof. - repeat intro. eauto. -Qed. - -Instance eutt_observe {E R RR} : - Proper (@eutt E R RR ==> go_sim (@eutt E R RR)) (@observe E R). -Proof. - repeat intro. punfold H. pfold. destruct H. econstructor; eauto. -Qed. - -Instance eutt_tauF {E R RR} : - Proper (@eutt E R RR ==> go_sim (@eutt E R RR)) (@TauF E R _). -Proof. - repeat intro. pfold. punfold H. - destruct H. econstructor. - - split; intros; simpl. - + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. - + rewrite finite_taus_tau, FIN, <-finite_taus_tau; eauto. - - intros. eapply EQV; eapply unalltaus_tau; eauto. -Qed. - -Instance eutt_VisF {E R RR u} (e: E u) : - Proper (pointwise_relation _ (eutt RR) ==> go_sim (@eutt E R RR)) (VisF e). -Proof. - repeat intro. red in H. pfold. econstructor. - - repeat econstructor. - - intros. - destruct UNTAUS1 as [UNTAUS1 Hnotau1]. - destruct UNTAUS2 as [UNTAUS2 Hnotau2]. - dependent destruction UNTAUS1. - dependent destruction UNTAUS2. simpobs. - econstructor; intros; left; apply H. -Qed. - -Instance eq_itree_notauF {E R} : - Proper (go_sim (@eq_itree E R) ==> flip impl) (@notauF E R _). -Proof. - repeat intro. punfold H. inv H; simpl in *; subst; eauto. -Qed. - -(* If [t1] and [t2] are equivalent, then either both start with - finitely many taus, or both [spin]. *) -Instance eutt_finite_taus {E R RR} : - Proper (go_sim (@eutt E R RR) ==> flip impl) (@finite_tausF E R). -Proof. - repeat intro. punfold H. eapply H. eauto. -Qed. - -(* Lemmas about [bind]. *) - -Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) (observe t')), - untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). -Proof. - intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. - induction UNTAUS; intros; subst. - - rewrite !bind_unfold; simpobs; eauto. - - rewrite bind_unfold. simpobs. cbn. eauto. -Qed. - -Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) t'), - untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). -Proof. - intros; eapply untaus_bind; eauto. -Qed. - -Lemma finite_taus_bind_fst {E R S} - (t : itree E R) (f : R -> itree E S) : - finite_taus (ITree.bind t f) -> finite_taus t. -Proof. - intros [tf' [TAUS PROP]]. - genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. - induction TAUS; intros; subst. - - rewrite bind_unfold in PROP. - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - rewrite bind_unfold in Heqobtf. simpobs. inv Heqobtf. unfold_bind. - eapply finite_taus_tau; eauto. -Qed. - -Lemma finite_taus_bind {E R S} - (t : itree E R) (f : R -> itree E S) - (FINt: finite_tausF (observe t)) - (FINk: forall v, finite_tausF (observe (f v))): - finite_tausF (observe (ITree.bind t f)). -Proof. - rewrite bind_unfold. - genobs t ot. clear Heqot t. - destruct FINt as [ot' [UNT NOTAU]]. - induction UNT; subst. - - destruct ot0; inv NOTAU; simpl; eauto 7. - - apply finite_taus_tau. eauto. -Qed. - -Lemma untaus_eq_idx E R: forall (ot1 ot2: itreeF E R _), - untausF ot1 ot2 -> untausF ot1 ot2. -Proof. intros; subst; eauto. Qed. - -Lemma untaus_untaus E R: forall (ot1 ot2 ot3: itreeF E R _), - untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. -Proof. - intros t1 t2 t3. induction 1; simpl; eauto. -Qed. - -Lemma untaus_unalltus_rev E R (ot1 ot2 ot3: itreeF E R _) : - untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. -Proof. - intros H. revert ot3. - induction H; intros. - - eauto using untaus_eq_idx with arith. - - destruct H0 as [Huntaus Hnotau]. - destruct Huntaus. - + exfalso; eauto. - + inv OBS0. inversion H0; subst; eauto. -Qed. - -Lemma eutt_strengthen {E R RR}: - forall r (t1 t2: itree E R) - (FIN: finite_taus t1 <-> finite_taus t2) - (EQV: forall t1' t2' - (UNT1: unalltaus t1 t1') - (UNT2: unalltaus t2 t2'), - paco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r t1' t2'), - paco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r t1 t2. -Proof. - intros. pfold. econstructor; eauto. - intros. - hexploit (EQV (go ot1') (go ot2')); eauto. - intros EQV'. punfold EQV'. destruct EQV'. - eapply EQV0; - repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. -Qed. - -Inductive eutt_trans_clo {E R} RR (r: relation (itree E R)) : relation (itree E R) := -| eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ~[RR]~ t2) - (EQVr: t4 ~[RR]~ t3) - (REL: r t2 t3) - : eutt_trans_clo RR r t1 t4 -. -Hint Constructors eutt_trans_clo. - -Lemma eutt_clo_trans {E R RR} {ERR : Equivalence RR} -: weak_respectful2 (@eutt_ E R RR) (eutt_trans_clo RR). -Proof. - econstructor; [pmonauto|]. - intros. inv PR. - punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. - { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } - - intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. - hexploit EQV; eauto. intros EUTT1. - apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. - hexploit EQV0; eauto. intros EUTT2. - apply GF in REL. destruct REL. - hexploit EQV1; eauto. intros EUTT3. - destruct EUTT1; destruct EUTT2; - try (solve [inversion EUTT3; auto]). - { constructor. inversion EUTT3. subst. - etransitivity; eauto. etransitivity; eauto. symmetry. eauto. } - remember (VisF _ _) as o2 in EUTT3. - remember (VisF _ _) as o3 in EUTT3. - inversion EUTT3; subst; try discriminate. - inversion H2; clear H2; inversion H3; clear H3. - subst; auto_inj_pair2; subst. - econstructor. intros. - specialize (H x); specialize (H0 x); specialize (H1 x). - pclearbot. eauto using rclo2. -Qed. - -Inductive eutt_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_bind_clo_intro U RU (t1 t2: itree E U) k1 k2 - (EQV: t1 ~[RU]~ t2) - (REL: forall v1 v2, RU v1 v2 -> r (k1 v1) (k2 v2)) - : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) -. -Hint Constructors eutt_bind_clo. - -Lemma bind_clo_finite_taus E U R (t1 t2: itree E U) (k1 k2: U -> itree E R) - (FT: finite_taus (ITree.bind t1 k1)) - (FTk: forall v, finite_taus (k1 v) -> finite_taus (k2 v)) - (EQV: t1 ~~ t2): - finite_taus (ITree.bind t2 k2). -Proof. - punfold EQV. destruct EQV as [[FTt _] EQV]. - assert (FT1 := FT). apply finite_taus_bind_fst in FT1. - assert (FT2 := FT1). apply FTt in FT2. - destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. - rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. - rewrite bind_unfold. genobs t2 ot2. clear Heqot2 t2. - induction FT2. - - destruct ot0; inv NT2; simpl; eauto 7. - hexploit EQV; eauto. intros EQV'. inv EQV'. - rewrite bind_unfold in FT. eauto. - - subst. eapply finite_taus_tau; eauto. - eapply IHFT2; eauto using unalltaus_tau'. -Qed. - -Lemma eutt_clo_bind E R {RR} {ERR : Equivalence RR} : weak_respectful2 (@eutt_ E R RR) eutt_bind_clo. -Proof. - econstructor; [pmonauto|]. - intros. destruct PR. split. - - assert (EQV':=EQV). symmetry in EQV'. - split; intros; eapply bind_clo_finite_taus; eauto; intros. - + edestruct GF; eauto. apply FIN. eauto. - + edestruct GF; eauto. apply FIN. eauto. - - punfold EQV. destruct EQV. - intros. - hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS1|]. intros [a FT1]. - hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS2|]. intros [b FT2]. - specialize (EQV _ _ FT1 FT2). - destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. - hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. - hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. - hexploit untaus_unalltus_rev; [apply UT1| |]. eauto. intros UAT1. - hexploit untaus_unalltus_rev; [apply UT2| |]; eauto. intros UAT2. - inv EQV. - + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. - eapply GF in REL. destruct REL. - eapply monotone_eq_notauF; eauto using rclo2. - + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. - destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. - dependent destruction UAT1. dependent destruction UAT2. simpobs. - econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. -Qed. - -(* [eutt] is a congruence wrt. [bind] *) - -Instance eutt_bind {E R S} : - Proper (@eutt E R ==> - pointwise_relation _ eutt ==> - @eutt E S) ITree.bind. -Proof. - repeat intro. pupto2_init. - pupto2 eutt_clo_bind. econstructor; eauto. - intros. pupto2_final. apply H0. -Qed. - -Instance eutt_paco {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (paco2 (eutt_ ∘ gres2 eutt_) r). -Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. -Qed. - -Instance eutt_gres {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (gres2 eutt_ r). -Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. -Qed. - -Instance eutt_map {E R S} : - Proper (pointwise_relation _ eq ==> @eutt E R ==> @eutt E S) ITree.map. -Proof. -Admitted. - -Instance eutt_forever {E R S} : - Proper (@eutt E R ==> @eutt E S) ITree.forever. -Proof. -Admitted. -Instance eutt_when {E} (b : bool) : - Proper (@eutt E unit ==> @eutt E unit) (ITree.when b). -Proof. -Admitted. - -Lemma eutt_map_map {E R S T} - (f : R -> S) (g : S -> T) (t : itree E R) : - eutt (ITree.map g (ITree.map f t)) - (ITree.map (fun x => g (f x)) t). -Proof. - rewrite map_map. reflexivity. -Qed. - -Notation itree' E R := (itreeF E R (itree E R)). - -Definition observing {E R} - (f : itree' E R -> itree' E R -> Prop) - (x y : itree E R) := - f x.(observe) y.(observe). - -Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : - itree' E R -> itree' E R -> Prop := -| euttF1_Tau_L : forall t1 t2, - euttF1' r t1.(observe) t2 -> - euttF1' r (TauF t1) t2 -| euttF1_Tau_R : forall t1 t2, - euttF1' r t1 t2.(observe) -> - euttF1' r t1 (TauF t2) -| euttF1_euttF0 : forall t1 t2, - eq_notauF r t1 t2 -> - euttF1' r t1 t2 -. - -Definition euttF1 {E R} (r : relation (itree E R)) : - relation (itree E R) := observing (euttF1' r). - -Lemma euttF1_euttF {E R} (r : relation (itree E R)) : - forall t1 t2, - euttF1 r t1 t2 -> eutt_ r t1 t2. -Proof. -Admitted. - -Inductive euttF' {E R} (eutt: relation (itree E R)) (eqtaus: relation (itreeF E R _)) - : relation (itreeF E R _) := -| euttF'_ret r : euttF' eutt eqtaus (RetF r) (RetF r) -| euttF'_vis u (e : E u) k1 k2 - (EUTTK: forall x, eutt (k1 x) (k2 x)): - euttF' eutt eqtaus (VisF e k1) (VisF e k2) -| euttF'_tau_tau t1 t2 - (EQTAUS: eqtaus (observe t1) (observe t2)): - euttF' eutt eqtaus (TauF t1) (TauF t2) -| euttF'_tau_left t1 ot2 - (EQTAUS: euttF' eutt eqtaus (observe t1) ot2): - euttF' eutt eqtaus (TauF t1) ot2 -| euttF'_right ot1 t2 - (EQTAUS: euttF' eutt eqtaus ot1 (observe t2)): - euttF' eutt eqtaus ot1 (TauF t2) -. -Hint Constructors euttF'. - -Definition eutt'_ {E R} eutt t1 t2 := paco2 (@euttF' E R eutt) bot2 (* (fun x y => eutt (go x) (go y)) *) (observe t1) (observe t2). -Hint Unfold eutt'_. - -Definition eutt' {E R} := paco2 (@eutt'_ E R) bot2. -Hint Unfold eutt'. - -Lemma euttF'_mon {E R} r r' s s' x y - (EUTT: @euttF' E R r s x y) - (LEr: r <2= r') - (LEs: s <2= s'): - euttF' r' s' x y. -Proof. - induction EUTT; eauto. -Qed. - -Lemma monotone_euttF' {E R} eutt : monotone2 (@euttF' E R eutt). -Proof. repeat intro. eauto using euttF'_mon. Qed. -Hint Resolve monotone_euttF' : paco. - -Lemma monotone_eutt'_ {E R} : monotone2 (@eutt'_ E R). -Proof. red. eauto using euttF'_mon, paco2_mon_gen. Qed. -Hint Resolve monotone_eutt'_ : paco. - -Lemma eutt__is_eutt'_ {E R} r (t1 t2: itree E R) : - eutt_ r t1 t2 <-> eutt'_ r t1 t2. -Proof. - split; intros. - { revert t1 t2 H. pcofix CIH'. intros. destruct H0. - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) - by (destruct ot1, ot2; simpl; tauto). - destruct EM as [EM|[EM|EM]]. - - destruct FIN as [FIN _]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS1. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct FIN as [_ FIN]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS2. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct ot1, ot2; simpl in *; try tauto. - pfold. econstructor. right. apply CIH'. - econstructor. - + rewrite !finite_taus_tau in FIN. eauto. - + eauto using unalltaus_tau'. - } - { punfold H. econstructor; intros. - - split; intros. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. - move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. - induction UNTAUS1. - + induction 1; intros. - * inv H; try contradiction; eauto. - * subst. inv H; try contradiction. eauto. - + induction 1; intros; subst. - * inv H; try contradiction; eauto. - * inv H; try contradiction; eauto. - pclearbot. eapply IHUNTAUS1; eauto. - punfold EQTAUS. - } -Qed. - -Lemma eutt_is_eutt' {E R} r (t1 t2: itree E R) : - paco2 eutt_ r t1 t2 <-> paco2 eutt'_ r t1 t2. -Proof. - split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__is_eutt'_; eauto. -Qed. - -Lemma eutt_is_eutt'_gres {E R} r (t1 t2: itree E R) : - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2 <-> paco2 (eutt'_ ∘ gres2 eutt'_) r t1 t2. -Proof. - split; intros. - - eapply paco2_mon_gen; eauto. intros. - red in PR|-*. rewrite <-eutt__is_eutt'_. - eapply monotone_eutt_; eauto. intros. - eapply grespectful2_impl; eauto. intros. - rewrite eutt__is_eutt'_. reflexivity. - - eapply paco2_mon_gen; eauto. intros. - red in PR|-*. rewrite eutt__is_eutt'_. - eapply monotone_eutt'_; eauto. intros. - eapply grespectful2_impl; eauto. intros. - rewrite eutt__is_eutt'_. reflexivity. -Qed. - -Instance eutt'_paco {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (paco2 (eutt'_ ∘ gres2 eutt'_) r). -Proof. - repeat intro. - rewrite <-eutt_is_eutt'_gres. - rewrite <-eutt_is_eutt'_gres in H1. - rewrite H, H0. eauto. -Qed. - -Instance eutt'_gres {E R} r: - Proper (@eutt E R ==> @eutt E R ==> flip impl) - (gres2 eutt'_ r). -Proof. - repeat intro. - rewrite grespectful2_iff; [|intros; erewrite eutt__is_eutt'_; reflexivity]. - rewrite grespectful2_iff in H1; [|intros; erewrite eutt__is_eutt'_; reflexivity]. - rewrite H, H0. eauto. -Qed. diff --git a/theories/Trace.v b/theories/Trace.v index d02c61dc..a89f6dfb 100644 --- a/theories/Trace.v +++ b/theories/Trace.v @@ -229,7 +229,7 @@ Proof. try solve [inv UNTAUS1; inv H0]; try solve [inv UNTAUS2; inv H0]. + assert (is_traceF (RetF r0 : itreeF E R (itree E R)) [] (Some r0)) by constructor. - rewrite Heq' in H. inv H. constructor. + rewrite Heq' in H. inv H. constructor; auto. + assert (is_traceF (RetF r0 : itreeF E R (itree E R)) [] (Some r0)) by constructor. rewrite Heq' in H. inv H. + assert (is_traceF (VisF e k) [EventOut e] None) by constructor. From b0d745993dcee7ba80b0e2928a68bfcb247920b9 Mon Sep 17 00:00:00 2001 From: Yannick Date: Sat, 16 Feb 2019 17:38:41 -0500 Subject: [PATCH 011/142] Making global instances that got pushed inside of a section --- theories/Eq/UpToTaus.v | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 99a6f273..3356f17e 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -589,7 +589,7 @@ Proof. constructor; typeclasses eauto. Qed. (**) -Instance subrelation_eq_eutt : subrelation (@eq_itree E R) eutt. +Global Instance subrelation_eq_eutt : subrelation (@eq_itree E R) eutt. Proof. pcofix CIH. intros. pfold. econstructor. @@ -601,20 +601,20 @@ Proof. eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. Qed. -Instance subrelation_go_sim_eq_eutt : subrelation (go_sim (@eq_itree E R)) (go_sim eutt). +Global Instance subrelation_go_sim_eq_eutt : subrelation (go_sim (@eq_itree E R)) (go_sim eutt). Proof. repeat intro. red. red in H. rewrite H. reflexivity. Qed. -Instance eutt_go : Proper (go_sim eutt ==> eutt) go. +Global Instance eutt_go : Proper (go_sim eutt ==> eutt) go. Proof. repeat intro; eauto. Qed. -Instance eutt_observe : Proper (eutt ==> go_sim eutt) observe. +Global Instance eutt_observe : Proper (eutt ==> go_sim eutt) observe. Proof. repeat intro. punfold H. pfold. destruct H. econstructor; eauto. Qed. -Instance eutt_tauF : Proper (eutt ==> go_sim eutt) (fun t => TauF t). +Global Instance eutt_tauF : Proper (eutt ==> go_sim eutt) (fun t => TauF t). Proof. repeat intro. pfold. punfold H. destruct H. econstructor. @@ -624,7 +624,7 @@ Proof. - intros. eapply EQV; eapply unalltaus_tau; eauto. Qed. -Instance eutt_VisF {u} (e: E u) : +Global Instance eutt_VisF {u} (e: E u) : Proper (pointwise_relation _ eutt ==> go_sim eutt) (VisF e). Proof. repeat intro. red in H. pfold. econstructor. @@ -637,7 +637,7 @@ Proof. econstructor; intros; left; apply H. Qed. -Instance eq_itree_notauF : +Global Instance eq_itree_notauF : Proper (go_sim (@eq_itree E R) ==> flip impl) notauF. Proof. repeat intro. punfold H. inv H; simpl in *; subst; eauto. @@ -645,7 +645,7 @@ Qed. (* If [t1] and [t2] are equivalent, then either both start with finitely many taus, or both [spin]. *) -Instance eutt_finite_taus : +Global Instance eutt_finite_taus : Proper (go_sim eutt ==> flip impl) finite_tausF. Proof. repeat intro. punfold H. eapply H. eauto. From f6c45990a8b5aed0f58cc744ba649b9e2149093c Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 17 Feb 2019 11:23:09 -0500 Subject: [PATCH 012/142] Make eq_itree a heterogeneous relation --- theories/Eq/Eq.v | 306 +++++++++++++++++++++----------------- theories/Eq/UpToTaus.v | 99 ++++++------ theories/Fix.v | 26 ++-- theories/MorphismsFacts.v | 16 +- 4 files changed, 237 insertions(+), 210 deletions(-) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index ee68fb40..8173bb5b 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -16,212 +16,240 @@ From Paco Require Import paco. From ITree Require Import Core. +(* TODO: Send to paco *) +Global Instance Symmetric_bot2 (A : Type) : @Symmetric A bot2. +Proof. auto. Qed. + +Global Instance Transitive_bot2 (A : Type) : @Transitive A bot2. +Proof. auto. Qed. + Ltac auto_inj_pair2 := repeat (match goal with | [ H : _ |- _ ] => apply inj_pair2 in H end). +Definition go_sim {E R1 R2} (r : itree E R1 -> itree E R2 -> Prop) : + itreeF E R1 (itree E R1) -> itreeF E R2 (itree E R2) -> Prop := + fun ot1 ot2 => r (go ot1) (go ot2). + +Global Instance Equivalence_go_sim E R sim + (Esim : @Equivalence (itree E R) sim) : + Equivalence (go_sim sim). +Proof. + constructor; red; unfold go_sim. + - reflexivity. + - symmetry; eauto. + - etransitivity; eauto. +Qed. + +Global Instance subrelation_go_sim E R sim sim' : + @subrelation (itree E R) sim sim' -> + subrelation (go_sim sim) (go_sim sim'). +Proof. cbv; eauto. Qed. + Lemma pointwise_relation_fold {A B} {r: relation B} f g: (forall v:A, r (f v) (g v)) -> pointwise_relation _ r f g. Proof. red. eauto. Qed. Section eq_itree. - Context {E : Type -> Type} {R : Type}. + Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). - Inductive eq_itreeF' (sim : relation (itree E R)) : relation (itreeF E R (itree E R)) := - | EqRet : forall x, eq_itreeF' sim (RetF x) (RetF x) + Inductive eq_itreeF {I J} (sim : I -> J -> Prop) : + itreeF E R1 I -> itreeF E R2 J -> Prop := + | EqRet : forall r1 r2, RR r1 r2 -> eq_itreeF sim (RetF r1) (RetF r2) | EqTau : forall m1 m2 - (REL: sim m1 m2), eq_itreeF' sim (TauF m1) (TauF m2) + (REL: sim m1 m2), eq_itreeF sim (TauF m1) (TauF m2) | EqVis : forall {u} (e : E u) k1 k2 (REL: forall v, sim (k1 v) (k2 v)), - eq_itreeF' sim (VisF e k1) (VisF e k2) + eq_itreeF sim (VisF e k1) (VisF e k2) . - Hint Constructors eq_itreeF'. - - Global Instance Reflexive_eq_itreeF' sim - : Reflexive sim -> Reflexive (eq_itreeF' sim). - Proof. - red. destruct x; eauto. - Qed. - - Global Instance Symmetric_eq_itreeF' sim - : Symmetric sim -> Symmetric (eq_itreeF' sim). - Proof. - red. inversion 2; eauto. - Qed. - - Global Instance Transitive_eq_itreeF' sim - : Transitive sim -> Transitive (eq_itreeF' sim). - Proof. - red. inversion 2; inversion 1; eauto. - subst. dependent destruction H6. dependent destruction H7. eauto. - Qed. - - Definition eq_itreeF (sim: relation (itree E R)) : relation (itree E R) := - fun t1 t2 => eq_itreeF' sim (observe t1) (observe t2). - Hint Unfold eq_itreeF. - - Lemma eq_itreeF'_mono : forall x0 x1 r r' - (IN: eq_itreeF' r x0 x1) (LE: forall x2 x3, (r x2 x3 : Prop) -> r' x2 x3 : Prop), eq_itreeF' r' x0 x1. + Hint Constructors eq_itreeF. + + Definition eq_itree_ (sim: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := + fun t1 t2 => eq_itreeF sim (observe t1) (observe t2). + Hint Unfold eq_itree_. + + Lemma eq_itreeF_mono I J x0 x1 (r r' : I -> J -> Prop) : + forall + (IN: eq_itreeF r x0 x1) + (LE: forall x2 x3, r x2 x3 -> r' x2 x3 : Prop), + eq_itreeF r' x0 x1. Proof. pmonauto. Qed. - Lemma eq_itreeF_mono : monotone2 eq_itreeF. + Lemma eq_itree__mono : monotone2 eq_itree_. Proof. do 2 red. pmonauto. Qed. - Definition eq_itree : relation (itree E R) := paco2 eq_itreeF bot2. + Definition eq_itree : itree E R1 -> itree E R2 -> Prop := + paco2 eq_itree_ bot2. End eq_itree. -Hint Constructors eq_itreeF'. -Hint Unfold eq_itreeF. -Hint Resolve eq_itreeF_mono : paco. +Hint Constructors eq_itreeF. +Hint Unfold eq_itree_. +Hint Resolve eq_itree__mono : paco. Hint Unfold eq_itree. -Definition go_sim {E R} (r: relation (itree E R)) : relation (itreeF E R (itree E R)) := - fun ot1 ot2 => r (go ot1) (go ot2). - Ltac unfold_eq_itree := - (try match goal with [|- eq_itreeF _ _ _ ] => red end); - (repeat match goal with [H: eq_itreeF _ _ _ |- _ ] => red in H end). - -Delimit Scope eq_itree_scope with eq_itree. -(* note(gmm): overriding `=` seems like a bad idea *) -Notation "t1 ≅ t2" := (eq_itree t1%itree t2%itree) (at level 70). -(* you can write ≅ using \cong in tex-mode *) + (try match goal with [|- eq_itree_ _ _ _ _ ] => red end); + (repeat match goal with [H: eq_itree_ _ _ _ _ |- _ ] => red in H end). -Lemma eq_itree_refl {E R} r x : paco2 (@eq_itreeF E R) r x x. +Lemma flip_eq_itree {E R1 R2} (RR : R1 -> R2 -> Prop) : + forall (u : itree E R1) (v : itree E R2), + eq_itree RR u v -> eq_itree (flip RR) v u. Proof. - revert x. pcofix CIH; intros. - pfold. unfold_eq_itree. destruct (observe x); eauto. + pcofix self. + intros u v euv. pfold. punfold euv. unfold_eq_itree. + destruct euv; pclearbot; auto 10. Qed. -Hint Resolve eq_itree_refl : refl. -Global Instance Reflexive_eq_itree {E R} : Reflexive (@eq_itree E R). +Section eq_itree_eq. + Context {E : Type -> Type} {R : Type}. + + Let eq_itreeF {I J} := @eq_itreeF E R _ eq I J. + Let eq_itree_ := @eq_itree_ E R _ eq. + Let eq_itree := @eq_itree E R _ eq. + + Global Instance Reflexive_eq_itreeF I (sim : I -> I -> Prop) + : Reflexive sim -> Reflexive (eq_itreeF sim). + Proof. + red. destruct x; constructor; eauto. + Qed. + + Global Instance Symmetric_eq_itreeF I (sim : I -> I -> Prop) + : Symmetric sim -> Symmetric (eq_itreeF sim). + Proof. + red. inversion 2; constructor; eauto. + Qed. + + Global Instance Transitive_eq_itreeF I (sim : I -> I -> Prop) + : Transitive sim -> Transitive (eq_itreeF sim). + Proof. + red. inversion 2; inversion 1; subst; repeat auto_inj_pair2; subst; constructor; eauto. + Qed. + +Global Instance Reflexive_eq_itree r : Reflexive (paco2 eq_itree_ r). Proof. - eauto with refl. + pcofix CIH; intros. + pfold. do 2 red. destruct (observe x); eauto. Qed. -Global Instance Symmetric_eq_itree {E R} : Symmetric (@eq_itree E R). +Global Instance Symmetric_eq_itree r (SYMr : Symmetric r) : + Symmetric (paco2 eq_itree_ r). Proof. pcofix CIH; intros. - pfold. unfold_eq_itree. punfold H0. inv H0; eauto. - - pclearbot. eauto. - - econstructor. intros. specialize (REL v). pclearbot. eauto. + pfold. do 2 red. punfold H0. inv H0; eauto. + - constructor; destruct REL; eauto. + - constructor. intros. destruct (REL v); eauto. Qed. -Global Instance Transitive_eq_itree {E R} : Transitive (@eq_itree E R). +Global Instance Transitive_eq_itree : Transitive eq_itree. Proof. pcofix CIH. intros. - pfold. punfold H0. punfold H1. unfold_eq_itree. - genobs x ox; genobs y oy; genobs z oz. - remember oy as oy' in H1. - destruct H0, H1; inversion Heqoy'; subst; auto. + pfold. red. + punfold H0; red in H0. + punfold H1; red in H1. + destruct H0; inversion H1; subst; eauto. - pclearbot; eauto. - - apply inj_pair2 in H1. - apply inj_pair2 in H2. + - auto_inj_pair2; subst. subst; econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto. Qed. -Global Instance Equivalence_eq_itree {E R} : - Equivalence (@eq_itree E R). +Global Instance Equivalence_eq_itree : Equivalence eq_itree. Proof. constructor; typeclasses eauto. Qed. -Global Instance Equivalence_go_eq_itree {E R} : - Equivalence (go_sim (@eq_itree E R)). -Proof. - constructor; repeat intro; red; eauto with refl. - - symmetry; eauto. - - etransitivity; eauto. -Qed. - -Instance eq_itree_go {E R} : - Proper (go_sim (@eq_itree E R) ==> @eq_itree E R) (@go E R). +Global Instance eq_itree_go : + Proper (go_sim eq_itree ==> eq_itree) (@go E R). Proof. repeat intro. eauto. Qed. -Instance eq_itree_observe {E R} : - Proper (@eq_itree E R ==> go_sim (@eq_itree E R)) (@observe E R). +Global Instance eq_itree_observe : + Proper (eq_itree ==> go_sim eq_itree) (@observe E R). Proof. repeat intro. punfold H. pfold. eapply eq_itreeF_mono; eauto. Qed. -Instance eq_itree_tauF {E R} : - Proper (@eq_itree E R ==> go_sim (@eq_itree E R)) (@TauF E R _). +Global Instance eq_itree_tauF : + Proper (eq_itree ==> go_sim eq_itree) (@TauF E R _). Proof. repeat intro. pfold. econstructor. eauto. Qed. -Instance eq_itree_VisF {E R u} (e: E u) : - Proper (pointwise_relation _ eq_itree ==> go_sim (@eq_itree E R)) (VisF e). +Global Instance eq_itree_VisF {u} (e: E u) : + Proper (pointwise_relation _ eq_itree ==> go_sim eq_itree) (VisF e). Proof. repeat intro. red in H. pfold. econstructor. left. apply H. Qed. -Lemma itree_eta {E R} (t: itree E R): t ≅ go (observe t). -Proof. - pfold. red. cbn. eapply Reflexive_eq_itreeF'; eauto with refl. -Qed. - -Lemma bind_unfold {E R S} - (t : itree E R) (k : R -> itree E S) : - observe (ITree.bind t k) = observe (ITree.bind_match k (ITree.bind' k) (observe t)). -Proof. eauto with refl. Qed. - -Lemma unfold_bind {E R S} - (t : itree E R) (k : R -> itree E S) : - ITree.bind t k ≅ ITree.bind_match k (ITree.bind' k) (observe t). -Proof. rewrite itree_eta, bind_unfold, <-itree_eta. eauto with refl. Qed. - -Lemma ret_bind {E R S} (r : R) : - forall k : R -> itree E S, - ITree.bind (Ret r) k ≅ (k r). -Proof. - intros. rewrite unfold_bind. eauto with refl. -Qed. - -Lemma tau_bind {E R} U t (k: U -> itree E R) : - ITree.bind (Tau t) k ≅ Tau (ITree.bind t k). -Proof. - setoid_rewrite unfold_bind at 1. eauto with refl. -Qed. - -Lemma vis_bind {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : - ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). +Lemma itree_eta (t: itree E R): eq_itree t (go (observe t)). Proof. - setoid_rewrite unfold_bind at 1. eauto with refl. + pfold. red. cbn. apply Reflexive_eq_itreeF. + auto using reflexivity. Qed. -Inductive eq_itree_trans_clo {E R} (r: relation (itree E R)) : relation (itree E R) := +Inductive eq_itree_trans_clo (r : itree E R -> itree E R -> Prop) : + itree E R -> itree E R -> Prop := | eq_itree_trans_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ≅ t2) - (EQVr: t4 ≅ t3) + (EQVl: eq_itree t1 t2) + (EQVr: eq_itree t4 t3) (RELATED: r t2 t3) : eq_itree_trans_clo r t1 t4 . Hint Constructors eq_itree_trans_clo. -Lemma eq_itree_clo_trans E R: weak_respectful2 eq_itreeF (@eq_itree_trans_clo E R). +Lemma eq_itree_clo_trans : weak_respectful2 eq_itree_ eq_itree_trans_clo. Proof. econstructor; [pmonauto|]. intros. dependent destruction PR. apply GF in RELATED. - punfold EQVl. punfold EQVr. unfold_eq_itree. - genobs t1 ot1; genobs t2 ot2; genobs t3 ot3; genobs t4 ot4. - destruct EQVl; + punfold EQVl. punfold EQVr. red in RELATED. red. unfold_eq_itree. + inversion EQVl; clear EQVl; inversion EQVr; clear EQVr; inversion RELATED; clear RELATED; subst; simpobs; try discriminate. - - inversion H0; auto. - - inversion H0; subst; pclearbot; eauto using rclo2. + - inversion H0; inversion H3; auto. + - inversion H; inversion H3; subst; pclearbot; eauto using rclo2. - - inversion H0; subst; auto_inj_pair2; subst. + - inversion H; inversion H3; subst; auto_inj_pair2; subst. pclearbot. econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto using rclo2. Qed. +End eq_itree_eq. + +Arguments eq_itree_clo_trans : clear implicits. + +Hint Constructors eq_itree_trans_clo. + +Delimit Scope eq_itree_scope with eq_itree. +(* note(gmm): overriding `=` seems like a bad idea *) +Notation "t1 ≅ t2" := (eq_itree eq t1%itree t2%itree) (at level 70). +(* you can write ≅ using \cong in tex-mode *) + +Lemma bind_unfold {E R S} + (t : itree E R) (k : R -> itree E S) : + observe (ITree.bind t k) = observe (ITree.bind_match k (ITree.bind' k) (observe t)). +Proof. eauto. Qed. + +Lemma unfold_bind {E R S} + (t : itree E R) (k : R -> itree E S) : + ITree.bind t k ≅ ITree.bind_match k (ITree.bind' k) (observe t). +Proof. rewrite itree_eta, bind_unfold, <-itree_eta. reflexivity. Qed. + +Lemma ret_bind {E R S} (r : R) (k : R -> itree E S) : + ITree.bind (Ret r) k ≅ (k r). +Proof. apply unfold_bind. Qed. + +Lemma tau_bind {E R} U t (k: U -> itree E R) : + ITree.bind (Tau t) k ≅ Tau (ITree.bind t k). +Proof. apply @unfold_bind. Qed. + +Lemma vis_bind {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : + ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). +Proof. apply @unfold_bind. Qed. Inductive eq_itree_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := | pbc_intro U t1 t2 (k1 k2: U -> _) @@ -231,22 +259,22 @@ Inductive eq_itree_bind_clo {E R} (r: relation (itree E R)) : relation (itree E . Hint Constructors eq_itree_bind_clo. -Lemma eq_itree_clo_bind E R: weak_respectful2 eq_itreeF (@eq_itree_bind_clo E R). +Lemma eq_itree_clo_bind E R: weak_respectful2 (eq_itree_ eq) (@eq_itree_bind_clo E R). Proof. econstructor; try pmonauto. intros. dependent destruction PR. punfold EQV. unfold_eq_itree. rewrite !bind_unfold; inv EQV; simpobs. - - eapply eq_itreeF_mono; eauto using rclo2. + - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. - simpl. fold_bind. pclearbot. eauto 7 using rclo2. - econstructor. intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. Qed. Instance eq_itree_bind {E R S} : - Proper (@eq_itree E R ==> - pointwise_relation _ eq_itree ==> - @eq_itree E S) ITree.bind. + Proper (eq_itree eq ==> + pointwise_relation _ (eq_itree eq) ==> + eq_itree eq) (@ITree.bind E R S). Proof. repeat intro. pupto2_init. pupto2 eq_itree_clo_bind. econstructor; eauto. @@ -254,8 +282,8 @@ Proof. Qed. Instance eq_itree_paco {E R} r: - Proper (@eq_itree E R ==> @eq_itree E R ==> flip impl) - (paco2 (eq_itreeF ∘ gres2 eq_itreeF) r). + Proper (eq_itree eq ==> eq_itree eq ==> flip impl) + (paco2 (@eq_itree_ E R _ eq ∘ gres2 (eq_itree_ eq)) r). Proof. repeat intro. pupto2 eq_itree_clo_trans. eauto. Qed. @@ -276,7 +304,7 @@ Proof. revert R S. pcofix CIH. intros. pfold. unfold_eq_itree. rewrite !bind_unfold. genobs s os; destruct os; unfold_bind; simpl; eauto. - eapply Reflexive_eq_itreeF'. eauto with refl. + eapply Reflexive_eq_itreeF. auto using reflexivity. Qed. Lemma map_map {E R S T}: forall (f : R -> S) (g : S -> T) (t : itree E R), @@ -284,9 +312,11 @@ Lemma map_map {E R S T}: forall (f : R -> S) (g : S -> T) (t : itree E R), Proof. unfold ITree.map. intros. pupto2_init. rewrite bind_bind. - pupto2 eq_itree_clo_bind. econstructor; eauto with refl. - intros. rewrite ret_bind. - pupto2_final. eauto with refl. + pupto2 eq_itree_clo_bind. + econstructor. + - reflexivity. + - intros. rewrite ret_bind. + pupto2_final. apply reflexivity. Qed. Lemma map_bind {E R S T}: forall (f : R -> S) (k: S -> itree E T) (t : itree E R), @@ -294,9 +324,11 @@ Lemma map_bind {E R S T}: forall (f : R -> S) (k: S -> itree E T) (t : itree E R Proof. unfold ITree.map. intros. pupto2_init. rewrite bind_bind. - pupto2 eq_itree_clo_bind. econstructor; eauto with refl. - intros. rewrite ret_bind. - pupto2_final. eauto with refl. + pupto2 eq_itree_clo_bind. + econstructor. + - reflexivity. + - intros. rewrite ret_bind. + pupto2_final. apply reflexivity. Qed. (* diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 3356f17e..73fc61a7 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -424,25 +424,11 @@ Proof. repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. Qed. -End EUTT. - -Hint Constructors eq_notauF. -Hint Constructors euttF. -Hint Resolve monotone_eutt_ : paco. - -Delimit Scope eutt_scope with eutt. - -Section EUTT_eq. - -Context {E : Type -> Type} {R : Type}. - -Let eutt : itree E R -> itree E R -> Prop := eutt eq. - -Infix "~~" := eutt (at level 70). +(**) -Lemma eq_unalltaus (t1 t2 : itree E R) ot1' +Lemma eq_unalltaus (t1 : itree E R1) (t2 : itree E R2) ot1' (FT: unalltausF (observe t1) ot1') - (EQV: t1 ≅ t2) : + (EQV: eq_itree RR t1 t2) : exists ot2', unalltausF (observe t2) ot2'. Proof. genobs t1 ot1. revert t1 Heqot1 t2 EQV. @@ -453,10 +439,10 @@ Proof. pclearbot. edestruct IHHuntaus as [? []]; eauto. Qed. -Lemma eq_unalltaus_eqF (t s : itree E R) ot' +Lemma eq_unalltaus_eqF (t : itree E R1) (s : itree E R2) ot' (UNTAUS : unalltausF (observe t) ot') - (EQV: t ≅ s) : - exists os', unalltausF (observe s) os' /\ eq_itreeF' eq_itree ot' os'. + (EQV: eq_itree RR t s) : + exists os', unalltausF (observe s) os' /\ eq_itreeF RR (eq_itree RR) ot' os'. Proof. destruct UNTAUS as [Huntaus Hnotau]. remember (observe t) as ot. revert s t Heqot EQV. @@ -464,23 +450,35 @@ Proof. - eexists (observe s). split. inv EQV; simpobs; eauto. subst; eauto. - eapply eq_itreeF'_mono; eauto. + eapply eq_itreeF_mono; eauto. intros ? ? [| []]; eauto. - - inv EQV; rewrite <- H0 in Heqot; inversion Heqot; subst. + - inv EQV; simpobs; inversion Heqot; subst. destruct REL as [| []]. edestruct IHHuntaus as [? [[]]]; eauto 10. Qed. -Lemma eq_unalltaus_eq (t s : itree E R) t' +Lemma eq_unalltaus_eq (t : itree E R1) (s : itree E R2) t' (UNTAUS : unalltausF (observe t) (observe t')) - (EQV: t ≅ s) : - exists s', unalltausF (observe s) (observe s') /\ t' ≅ s'. + (EQV: eq_itree RR t s) : + exists s', unalltausF (observe s) (observe s') /\ eq_itree RR t' s'. Proof. eapply eq_unalltaus_eqF in UNTAUS; try eassumption. destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. - pfold. eapply eq_itreeF'_mono; eauto. + pfold. eapply eq_itreeF_mono; eauto. Qed. +End EUTT. + +Hint Constructors eq_notauF. +Hint Constructors euttF. +Hint Resolve monotone_eutt_ : paco. + +Delimit Scope eutt_scope with eutt. + +Section EUTT_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + (* Reflexivity of [eq_notauF], modulo a few assumptions. *) Lemma Reflexive_eq_notauF I (eq_ : I -> I -> Prop) (ot : itreeF E R I) : Reflexive eq_ -> notauF ot -> eq_notauF eq eq_ ot ot. @@ -488,6 +486,29 @@ Proof. intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. Qed. +Global Instance subrelation_eq_eutt : + @subrelation (itree E R) (eq_itree RR) (eutt RR). +Proof. + pcofix CIH. intros. + pfold. econstructor. + { split; [|apply flip_eq_itree in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } + + intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. + hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. + inv EQV'; simpobs; eauto. + eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. +Qed. + +End EUTT_rel. + +Section EUTT_eq. + +Context {E : Type -> Type} {R : Type}. + +Let eutt : itree E R -> itree E R -> Prop := eutt eq. + +Infix "~~" := eutt (at level 70). + Instance Reflexive_euttF (r : itree E R -> itree E R -> Prop) : Reflexive r -> Reflexive (euttF eq r). Proof. @@ -576,36 +597,12 @@ Proof. + eapply unalltaus_tau in UNTAUS1; eauto. Qed. -(* TODO: Send to paco *) -Global Instance Symmetric_bot2 (A : Type) : @Symmetric A bot2. -Proof. auto. Qed. - -Global Instance Transitive_bot2 (A : Type) : @Transitive A bot2. -Proof. auto. Qed. - (* We can now rewrite with [eutt] equalities. *) Global Instance Equivalence_eutt : @Equivalence (itree E R) eutt. Proof. constructor; typeclasses eauto. Qed. (**) -Global Instance subrelation_eq_eutt : subrelation (@eq_itree E R) eutt. -Proof. - pcofix CIH. intros. - pfold. econstructor. - { split; [|symmetry in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } - - intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. - hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. - inv EQV'; simpobs; eauto. - eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. -Qed. - -Global Instance subrelation_go_sim_eq_eutt : subrelation (go_sim (@eq_itree E R)) (go_sim eutt). -Proof. - repeat intro. red. red in H. rewrite H. reflexivity. -Qed. - Global Instance eutt_go : Proper (go_sim eutt ==> eutt) go. Proof. repeat intro; eauto. Qed. @@ -638,7 +635,7 @@ Proof. Qed. Global Instance eq_itree_notauF : - Proper (go_sim (@eq_itree E R) ==> flip impl) notauF. + Proper (go_sim (@eq_itree E R _ eq) ==> flip impl) notauF. Proof. repeat intro. punfold H. inv H; simpl in *; subst; eauto. Qed. diff --git a/theories/Fix.v b/theories/Fix.v index 83ed66b4..7d3d2dff 100644 --- a/theories/Fix.v +++ b/theories/Fix.v @@ -112,8 +112,8 @@ Lemma unfold_interp_mrecF R (t : itree (D +' E) R) : Proof. reflexivity. Qed. Lemma unfold_interp_mrec R (t : itree (D +' E) R) : - eq_itree (interp_mrec ctx _ t) - (interp_mrecF _ (observe t)). + eq_itree eq (interp_mrec ctx _ t) + (interp_mrecF _ (observe t)). Proof. rewrite itree_eta, unfold_interp_mrecF, <-itree_eta. reflexivity. @@ -143,14 +143,14 @@ Hint Rewrite @vis_mrec_right : itree. Hint Rewrite @tau_mrec : itree. Instance eq_itree_mrec {R} : - Proper (@eq_itree _ R ==> @eq_itree _ R) (interp_mrec ctx R). + Proper (eq_itree eq ==> eq_itree eq) (interp_mrec ctx R). Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. rewrite !unfold_interp_mrec. pupto2_final. punfold H0. inv H0; pclearbot; [| |destruct e]. - - eapply eq_itree_refl. + - apply reflexivity. - pfold. econstructor. eauto. - pfold. econstructor. apply pointwise_relation_fold in REL. right. eapply CIH. rewrite REL. reflexivity. @@ -169,18 +169,18 @@ Proof. autorewrite with itree; try rewrite <- bind_bind; pupto2_final. - 1: { apply eq_itree_refl. } + 1: { apply reflexivity. } all: try (pfold; econstructor; eauto). Qed. Let h_mrec : D ~> itree E := mrec ctx. Inductive mrec_invariant {U} : relation (itree _ U) := -| mrec_main (d1 d2 : _ U) (Ed : eq_itree d1 d2) : +| mrec_main (d1 d2 : _ U) (Ed : eq_itree eq d1 d2) : mrec_invariant (interp_mrec ctx _ d1) (interp1 (mrec ctx) _ d2) | mrec_bind T (d : _ T) (k1 k2 : T -> itree _ U) - (Ek : forall x, eq_itree (k1 x) (k2 x)) : + (Ek : forall x, eq_itree eq (k1 x) (k2 x)) : mrec_invariant (interp_mrec ctx _ (d >>= k1)) (interp_mrec ctx _ d >>= fun x => interp1 h_mrec _ (k2 x)) @@ -189,20 +189,20 @@ Inductive mrec_invariant {U} : relation (itree _ U) := Notation mi_holds r := (forall c1 c2 d1 d2, mrec_invariant d1 d2 -> - eq_itree c1 d1 -> eq_itree c2 d2 -> r c1 c2). + eq_itree eq c1 d1 -> eq_itree eq c2 d2 -> r c1 c2). Lemma mrec_invariant_init {U} (r : relation (itree _ U)) (INV : mi_holds r) (c1 c2 : itree _ U) - (Ec : eq_itree c1 c2) : - paco2 (compose eq_itreeF (gres2 eq_itreeF)) r + (Ec : eq_itree eq c1 c2) : + paco2 (compose (eq_itree_ eq) (gres2 (eq_itree_ eq))) r (interp_mrec ctx _ c1) (interp1 h_mrec _ c2). Proof. rewrite unfold_interp_mrec, unfold_interp1. punfold Ec. inversion Ec; cbn; pclearbot; pupto2_final. - + eapply eq_itree_refl. (* This should be reflexivity. *) + + subst r1; apply reflexivity. + pfold; constructor. right; eapply INV. 1: apply mrec_main; eassumption. all: reflexivity. @@ -218,7 +218,7 @@ Proof. } Qed. -Lemma mrec_invariant_eq {U} : mi_holds (@eq_itree _ U). +Lemma mrec_invariant_eq {U} : mi_holds (@eq_itree _ U _ eq). Proof. intros d1 d2 c1 c2 Ec1 Ec2 H. pupto2_init; revert d1 d2 c1 c2 Ec1 Ec2 H; pcofix self. @@ -249,7 +249,7 @@ Proof. Qed. Theorem interp_mrec_is_interp : forall {T} (c : itree _ T), - eq_itree (interp_mrec ctx _ c) (interp1 h_mrec _ c). + eq_itree eq (interp_mrec ctx _ c) (interp1 h_mrec _ c). Proof. intros; eapply mrec_invariant_eq; try eapply mrec_main; reflexivity. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 08007267..7acf5e48 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -80,9 +80,8 @@ Lemma vis_interp {E F R} {f : E ~> itree F} U (e: E U) (k: U -> itree E R) : interp f _ (Vis e k) ≅ Tau (ITree.bind (f _ e) (fun x => interp f _ (k x))). Proof. rewrite unfold_interp. reflexivity. Qed. -Instance eq_itree_interp {E F R} f : - Proper (@eq_itree E R ==> - @eq_itree F R) (interp f _). +Instance eq_itree_interp {E F R} (f : E ~> itree F) : + Proper (eq_itree eq ==> eq_itree eq) (interp f R). Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. @@ -97,13 +96,12 @@ Proof. + eauto. intros; pupto2_final; right; eauto. Qed. -Instance eq_itree_interp1 {E F R} f : - Proper (@eq_itree (E +' F) R ==> - @eq_itree F R) (interp1 f _). +Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. - rewrite itree_eta, (itree_eta (interp1 f _ y)), !interp1_unfold. + rewrite !unfold_interp1. punfold H0; red in H0. destruct H0; pclearbot. - pupto2_final. pfold. red. cbn. eauto. @@ -124,10 +122,10 @@ Proof. revert R t k. pcofix CIH. intros. rewrite (itree_eta t). destruct (observe t). - - rewrite ret_interp, !ret_bind. pupto2_final. apply eq_itree_refl. + - rewrite ret_interp, !ret_bind. pupto2_final. apply reflexivity. - rewrite tau_interp, !tau_bind, tau_interp. pupto2_final. pfold. econstructor. eauto. - - rewrite vis_interp, tau_bind, bind_bind. + - rewrite vis_interp, tau_bind. rewrite bind_bind. pfold. do 2 red; cbn. constructor. pupto2 (eq_itree_clo_bind F S). econstructor. + reflexivity. From 717859790eb312191a0cf38e80d2543c13717591 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 17 Feb 2019 11:27:46 -0500 Subject: [PATCH 013/142] Fix example with new heterogeneous eutt --- examples/Nimp.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/Nimp.v b/examples/Nimp.v index c2d4aa2d..15a3286d 100644 --- a/examples/Nimp.v +++ b/examples/Nimp.v @@ -145,7 +145,7 @@ Definition one_loop_tree : itree nd unit := Import Coq.Classes.Morphisms. (* SAZ: the [~] notation for eutt wasn't working here. *) -Lemma eval_one_loop : eutt (eval one_loop) (one_loop_tree). +Lemma eval_one_loop : eutt eq (eval one_loop) (one_loop_tree). Proof. (* pupto2_init. From eb67983900e6a265bd218c32dddf9910579a9e28 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 17 Feb 2019 12:13:51 -0500 Subject: [PATCH 014/142] Simplify some Eq proofs --- theories/Eq/Eq.v | 20 +++++--------------- 1 file changed, 5 insertions(+), 15 deletions(-) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 0709681d..0d664cc4 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -331,34 +331,24 @@ Lemma bind_bind {E R S T} : forall (s : itree E R) (k : R -> itree E S) (h : S -> itree E T), ITree.bind (ITree.bind s k) h ≅ ITree.bind s (fun r => ITree.bind (k r) h). Proof. - revert R S. pcofix CIH. intros. + pcofix CIH. intros. pfold. unfold_eq_itree. rewrite !bind_unfold. - genobs s os; destruct os; unfold_bind; simpl; eauto. - eapply Reflexive_eq_itreeF. auto using reflexivity. + genobs s os; destruct os; unfold_bind; simpl; auto. + apply Reflexive_eq_itreeF. auto using reflexivity. Qed. Lemma map_map {E R S T}: forall (f : R -> S) (g : S -> T) (t : itree E R), ITree.map g (ITree.map f t) ≅ ITree.map (fun x => g (f x)) t. Proof. unfold ITree.map. intros. - pupto2_init. rewrite bind_bind. - pupto2 eq_itree_clo_bind. - econstructor. - - reflexivity. - - intros. rewrite ret_bind. - pupto2_final. apply reflexivity. + rewrite bind_bind. setoid_rewrite ret_bind. reflexivity. Qed. Lemma map_bind {E R S T}: forall (f : R -> S) (k: S -> itree E T) (t : itree E R), ITree.bind (ITree.map f t) k ≅ ITree.bind t (fun x => k (f x)). Proof. unfold ITree.map. intros. - pupto2_init. rewrite bind_bind. - pupto2 eq_itree_clo_bind. - econstructor. - - reflexivity. - - intros. rewrite ret_bind. - pupto2_final. apply reflexivity. + rewrite bind_bind. setoid_rewrite ret_bind. reflexivity. Qed. (* From e078b5c2f24434d7f1b3d8f6328815e9a979d644 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 17 Feb 2019 12:33:15 -0500 Subject: [PATCH 015/142] Heterogeneous version of eq_itree_bind --- theories/Eq/Eq.v | 42 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 38 insertions(+), 4 deletions(-) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 0d664cc4..bd38e0e9 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -281,6 +281,29 @@ Lemma vis_bind {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). Proof. apply @unfold_bind. Qed. +Inductive eq_itree_bind_clo_h {E R1 R2} (RR : R1 -> R2 -> Prop) + (r : itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| pbc_intro_h U1 U2 (RU : U1 -> U2 -> Prop) t1 t2 k1 k2 + (EQV: eq_itree RU t1 t2) + (REL: forall u1 u2, RU u1 u2 -> r (k1 u1) (k2 u2)) + : eq_itree_bind_clo_h RR r (ITree.bind t1 k1) (ITree.bind t2 k2) +. +Hint Constructors eq_itree_bind_clo_h. + +Lemma eq_itree_clo_bind_h E R1 R2 (RR : R1 -> R2 -> Prop) : + weak_respectful2 (eq_itree_ RR) (@eq_itree_bind_clo_h E _ _ RR). +Proof. + econstructor; try pmonauto. + intros. dependent destruction PR. + punfold EQV. unfold_eq_itree. + rewrite !bind_unfold; inv EQV; simpobs. + - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. + - simpl. fold_bind. pclearbot. eauto 7 using rclo2. + - econstructor. + intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. +Qed. + Inductive eq_itree_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := | pbc_intro U t1 t2 (k1 k2: U -> _) (EQV: t1 ≅ t2) @@ -301,14 +324,25 @@ Proof. intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. Qed. -Instance eq_itree_bind {E R S} : +Lemma eq_itree_bind {E R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) + t1 t2 k1 k2 : + eq_itree RR t1 t2 -> + (forall r1 r2, RR r1 r2 -> eq_itree RS (k1 r1) (k2 r2)) -> + @eq_itree E _ _ RS (ITree.bind t1 k1) (ITree.bind t2 k2). +Proof. + repeat intro. pupto2_init. + pupto2 eq_itree_clo_bind_h. econstructor; eauto. + intros. pupto2_final; apply H0; auto. +Qed. + +Instance eq_itree_eq_bind {E R S} : Proper (eq_itree eq ==> pointwise_relation _ (eq_itree eq) ==> eq_itree eq) (@ITree.bind E R S). Proof. - repeat intro. pupto2_init. - pupto2 eq_itree_clo_bind. econstructor; eauto. - intros. pupto2_final. apply H0. + repeat intro; eapply eq_itree_bind; eauto. + intros; subst; auto. Qed. Instance eq_itree_paco {E R} r: From 936a083a96bdf818bb25d88701917636f05e6767 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 17 Feb 2019 16:21:07 -0500 Subject: [PATCH 016/142] Prove eutt_map --- theories/Eq/UpToTaus.v | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index ee95280f..cd5d06a4 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -822,7 +822,10 @@ Qed. Instance eutt_map {E R S} : Proper (pointwise_relation _ eq ==> eutt eq ==> eutt eq) (@ITree.map E R S). Proof. -Admitted. + unfold ITree.map. repeat red. + intros; eapply eutt_bind; eauto. + intro. rewrite H. reflexivity. +Qed. Instance eutt_forever {E R S} : Proper (eutt eq ==> eutt eq) (@ITree.forever E R S). From cb88698bcb73488464e6ea59c2928feba0151d83 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 17 Feb 2019 16:21:20 -0500 Subject: [PATCH 017/142] Add some automation for unalltaus_notau --- theories/Eq/UpToTaus.v | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index cd5d06a4..cf472ddc 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -57,6 +57,14 @@ Hint Constructors untausF. Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. Hint Unfold unalltausF. +Lemma unalltausF_untausF ot ot0 : unalltausF ot ot0 -> untausF ot ot0. +Proof. intros []; auto. Qed. +Hint Resolve unalltausF_untausF. + +Lemma unalltausF_notauF ot ot0 : unalltausF ot ot0 -> notauF ot0. +Proof. intros []; auto. Qed. +Hint Resolve unalltausF_notauF. + (* [finite_taus t] holds when [t] has a finite number of taus to peel. *) Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. @@ -253,6 +261,9 @@ End FiniteTaus. Arguments untaus_unalltaus_rev : clear implicits. +Hint Resolve unalltausF_notauF. +Hint Resolve unalltausF_untausF. + Hint Constructors untausF. Hint Unfold unalltausF. Hint Unfold finite_tausF. @@ -420,7 +431,7 @@ Proof. hexploit (EQV (go ot1') (go ot2')); eauto. intros EQV'. punfold EQV'. destruct EQV'. eapply EQV0; - repeat constructor; eauto. eapply UNTAUS1. eapply UNTAUS2. + repeat constructor; eauto. Qed. (**) @@ -495,7 +506,7 @@ Proof. intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. inv EQV'; simpobs; eauto. - eapply unalltaus_notau in UNTAUS1. simpobs. contradiction. + eapply unalltaus_notau in UNTAUS1. contradiction. Qed. End EUTT_rel. @@ -515,7 +526,7 @@ Proof. - reflexivity. - intros. erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply Reflexive_eq_notauF; eauto using unalltaus_notau. + apply Reflexive_eq_notauF; eauto. Qed. Instance Reflexive_eutt (r : itree E R -> itree E R -> Prop) : @@ -574,7 +585,7 @@ Proof. - intros t1' t2' H1 H2. eapply unalltaus_tau in H1; eauto. assert (X := unalltaus_injective _ _ _ H1 H2). - subst; apply Reflexive_eq_notauF; eauto using unalltaus_notau. + subst; apply Reflexive_eq_notauF; eauto. left. apply Reflexive_eutt. Qed. @@ -591,7 +602,7 @@ Proof. - eapply untaus_finite_taus; eauto. - induction H; intros. + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply Reflexive_eq_notauF; eauto using unalltaus_notau. + apply Reflexive_eq_notauF; eauto. left; apply Reflexive_eutt. + eapply unalltaus_tau in UNTAUS1; eauto. Qed. From b0ac5651e0514d6817cc4a767fc6755edce329fa Mon Sep 17 00:00:00 2001 From: Yannick Date: Sun, 17 Feb 2019 21:38:31 -0500 Subject: [PATCH 018/142] Progress in the proof of the compiler --- examples/Imp2Asm.v | 294 ++++++++++++++++++++++++++++++++--------- theories/Eq/UpToTaus.v | 22 +-- 2 files changed, 246 insertions(+), 70 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index aecbd738..e1eae307 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -1,6 +1,22 @@ Require Import Imp Asm. -Require Import Coq.Strings.String. +From Coq Require Import + Strings.String + Morphisms + Setoid + RelationClasses. + +From ITree Require Import + Effect.Env + ITree. + +From ExtLib Require Import + Core.RelDec + Structures.Monad + Structures.Maps + Data.Map.FMapAList. + + Import ListNotations. Section compile_assign. @@ -220,18 +236,13 @@ Section tests. End tests. -From ITree Require Import - ITree. - Require Import ExtLib.Structures.Monad. - From ITree Require Import - Effect.Env. - +Import MonadNotation. Section denote_list. Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := fix traverse__ l: M unit := match l with | [] => ret tt - | a::l => f a;; traverse__ l + | a::l => (f a;; traverse__ l)%monad end. Context {E} {EL : Locals -< E} {EM : Memory -< E}. @@ -240,12 +251,12 @@ From ITree Require Import Lemma denote_after_denote_list: forall {label: Type} instrs (b: block label), - denote_block E (after instrs b) ~~ (denote_list instrs ;; denote_block E b). + denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_block E b). Proof. induction instrs as [| i instrs IH]; intros b. - simpl; rewrite ret_bind; reflexivity. - simpl; rewrite bind_bind. - eapply eutt_bind; [reflexivity | intros []; apply IH]. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. Qed. End denote_list. @@ -270,80 +281,245 @@ Section Correctness. Lemma fmap_block_map: forall {L L'} b (f: L -> L'), - denote_block E (fmap_block f b) ~~ ITree.map (option_map f) (denote_block E b). + denote_block E (fmap_block f b) ≅ ITree.map (option_map f) (denote_block E b). Proof. induction b as [i b | br]; intros f. - simpl. unfold ITree.map; rewrite bind_bind. - eapply eutt_bind; [reflexivity | intros []; apply IHb]. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IHb]. - simpl. destruct br; simpl. + unfold ITree.map; rewrite ret_bind; reflexivity. + unfold ITree.map; rewrite bind_bind. - eapply eutt_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + unfold ITree.map; rewrite ret_bind; reflexivity. Qed. +Definition varOf (s : var) : var := "_local" ++ s. +Variant Rvar : var -> var -> Prop := +| Rvar_var v : Rvar (varOf v) v. +Definition Renv (g_asm g_imp : alist var value) : Prop := + forall k_asm k_imp, Rvar k_asm k_imp -> + forall v, In (k_imp,v) g_imp -> In (k_asm, v) g_asm. + +(* Let's not unfold this inside of the main proof *) +Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := + fun '(g_asm', _) '(g_imp',v) => + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + In (gen_local n, v) g_asm' /\ (* we get the right value *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + In (gen_local m, v) g_asm <-> In (gen_local m, v) g_asm'). + +End Correctness. - Lemma denote_compile_assign : - forall x e, - denote_list (compile_assign x e) ~~ ITree.bind (denoteExpr e) (fun v : Imp.value => lift (SetVar x v)). +Section TOMOVE. + + Context {E: Type -> Type}. + Lemma Vis_eutt: forall {R1 R2 RR} {U} (e: E U) k k', + (forall x, @eutt E R1 R2 RR (k x) (k' x)) -> eutt RR (Vis e k) (Vis e k'). + Admitted. + + Lemma Ret_eutt: forall {R1 R2} {RR: R1 -> R2 -> Prop} x y, + RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). + Admitted. + + + (* + This is sufficient to rewrite (eq_itree eq) under (eutt RR) through the fact that (eutt eq) is a subrelation of (eq_itree eq). + *) + + Global Instance eutt_eq_under_rr {R1 R2 : Type} (RR: R1 -> R2 -> Prop): + Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). + Admitted. + + Global Instance reflexive_eutt {R} RR `{Reflexive _ RR}: + Reflexive (@eutt E R R RR). + Admitted. + + Instance eq_itree_run_env {E R} {K V map} {Mmap: Maps.Map K V map}: + Proper (@eutt (envE K V +' E) R R eq ==> eq ==> @eutt E (prod map R) (prod map R) eq) + (run_env R). Proof. - (* induction e. - - simpl; rewrite bind_bind. - eapply eutt_bind; [reflexivity | intros ?]. *) - (** - YZ: This lemma is wrong. They are not eutt since of course the compiled program does more SetVar actions than -the source. - **) Admitted. - (* NB: I think that notations defined in Core are binding the monadic bind instead of the itree one, - hence why they do not show up here *) - (* Lemma denote_conditional: *) - (* forall i, *) - (* denote_block E (after (compile_assign "_jump_var" i) (bbb (Bbrz "_jump_var" (inl (inl None)) (inl (inr None))))) ~~ denoteExpr i. *) + (* Instance subrelation_eq_eutt {E R} {RR} {SRR: Reflexive RR}: subrelation (@eq_itree E R) (@eutt _ _ _ RR). *) + (* Proof. *) + (* Admitted. *) -From ExtLib Require Import - Core.RelDec - Structures.Maps - Data.Map.FMapAList. + Lemma interp1_eq_eutt {F: Type -> Type} (h: E ~> itree F) R: + @Proper (itree (E +' F) R -> itree F R) (eutt eq ==> eutt eq) (interp1 h R). + Admitted. -Definition varOf (s : var) : var := "_local" ++ s. +End TOMOVE. -Variant Rvar : var -> var -> Prop := -| Rvar_var v : Rvar (varOf v) v. +Section TOORG. -Definition Renv (g_asm g_imp : alist var value) : Prop := - forall k_asm k_imp, Rvar k_asm k_imp -> - forall v, In (k_imp,v) g_imp -> In (k_asm, v) g_asm. + Context {E: Type -> Type}. + Context {HasMemory: Memory -< E}. + Context {HasLocals: Locals -< E}. + + Lemma denote_list_app: + forall is1 is2, + @denote_list E _ _ (is1 ++ is2) ≅ + (@denote_list E _ _ is1;; denote_list is2). + Proof. + Admitted. + +End TOORG. + +Section Real_correctness. + + Context {E': Type -> Type}. + Context {HasMemory: Memory -< E'}. + Definition E := Locals +' E'. + + Definition interp_locals {R: Type} (t: itree E R) (s: alist var value): itree E' (alist var value * R) := + run_env _ (interp1 evalLocals _ t) s. + + Instance eq_itree_interp_locals {R}: + Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) + interp_locals. + Proof. + Admitted. + + Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), + @eutt E' _ _ eq + (interp_locals (ITree.bind t k) s) + (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). + Admitted. + Set Nested Proofs Allowed. -CoInductive euttG {a b : Type} (R : a -> b -> Prop) -: itree E a -> itree E b -> Prop := . + Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). + Admitted. +Typeclasses eauto := 5. Lemma compile_expr_correct : forall e g_imp g_asm n, Renv g_asm g_imp -> - euttG (fun '(g_asm', _) '(g_imp',v) => - Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) - In (gen_local n, v) g_asm' /\ (* we get the right value *) - (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) - In (gen_local m, v) g_asm <-> In (gen_local m, v) g_asm')) - (run_env unit (denote_list (compile_expr n e)) g_asm) - (run_env value (denoteExpr e) g_imp). + eutt (sim_rel g_asm n) + (interp_locals (denote_list (compile_expr n e)) g_asm) + (interp_locals (denoteExpr e) g_imp). Proof. induction e; simpl; intros. - { admit. } - { admit. } - { admit. (* obviously the most complex of them. *) } + { + Opaque gen_local. + rewrite itree_eta. + match goal with + | |- eutt _ _ ?x => + rewrite (itree_eta x) + end. + cbn. + do 2 rewrite tau_eutt. + rewrite itree_eta. + match goal with + | |- eutt _ _ ?x => + rewrite (itree_eta x) + end. + cbn. + rewrite itree_eta. + match goal with + | |- eutt _ _ ?x => + rewrite (itree_eta x) + end. + cbn. + rewrite tau_eutt. + rewrite tau_eutt. + rewrite itree_eta. + match goal with + | |- eutt _ _ ?x => + rewrite (itree_eta x) + end. + cbn. + rewrite tau_eutt. + rewrite itree_eta. + cbn. + rewrite tau_eutt. + rewrite itree_eta. + cbn. + apply Ret_eutt. + red. + split; [| split]. + { + red. + repeat intro. + admit. + } + { + admit. + } + { + repeat intro. + admit. + } + } + { + do 3 (rewrite itree_eta; + match goal with + | |- eutt _ _ ?x => + rewrite (itree_eta x) + end; + cbn; + repeat rewrite tau_eutt + ). + apply Ret_eutt. + split; [| split]. + { admit. } + { admit. } + { admit. } + } + { + eapply eutt_eq_under_rr. + eapply eq_itree_interp_locals. + rewrite denote_list_app. + setoid_rewrite denote_list_app. + reflexivity. + reflexivity. + rewrite interp_locals_bind. + setoid_rewrite interp_locals_bind. + reflexivity. + rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply IHe1. + auto. + intros. + rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply IHe2. + destruct r1, r2, H0 as (H1 & H2 & H3); auto. + intros. + rewrite itree_eta; + match goal with + | |- eutt _ _ ?x => + rewrite (itree_eta x) + end. + cbn. + rewrite tau_eutt. + rewrite itree_eta; cbn; rewrite tau_eutt. + (* Make a fairly pretty tactic(s) out of this *) + repeat (rewrite itree_eta; cbn; rewrite tau_eutt). + rewrite itree_eta; cbn. + apply Ret_eutt. + split; [| split]. + { + destruct r0, r3; simpl. + admit. + } + { + admit. + } + { + admit. + } Admitted. -Print stmt. - (* Seq a b a :: itree _ Empty_set @@ -396,19 +572,19 @@ Proof. (* This statement does not hold. We need to handle the environment. We want something closer to this kind: - - *) + + (* TODO: parameterize by REnv *) Lemma compile_correct_program: forall s L (b: block L) imports, - denote_main (compile s b) imports ~~ + denote_main (compile s b) imports ≈ (denoteStmt s;; ml <- denote_block b;; (match ml with | None => Ret tt | Some l => imports l end)). Proof. - simpl. +(* simpl. induction s; intros L b imports. - unfold denote_main; simpl. @@ -463,7 +639,7 @@ Proof. rewrite ret_bind, fmap_block_map, map_bind. eapply eutt_bind; [reflexivity |]. intros [? |]; simpl; reflexivity. - +*) Admitted. (* note: because local temporaries also modify the environment, they have to be @@ -471,7 +647,7 @@ Admitted. *) Theorem compile_correct: forall s, @denote_main _ _ _ Empty_set (compile s (bbb Bhalt)) - (fun x => match x with end) ~~ denoteStmt s. + (fun x => match x with end) ≈ denoteStmt s. Proof. (* intros stmt. unfold denote_main. @@ -483,7 +659,7 @@ Admitted. Admitted. -End Correctness. +End Real_correctness. (* diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index cf472ddc..199de129 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -519,7 +519,7 @@ Let eutt : itree E R -> itree E R -> Prop := eutt eq. Infix "≈" := eutt (at level 70) : itree_scope. -Instance Reflexive_euttF (r : itree E R -> itree E R -> Prop) : +Global Instance Reflexive_euttF (r : itree E R -> itree E R -> Prop) : Reflexive r -> Reflexive (euttF eq r). Proof. split. @@ -529,14 +529,14 @@ Proof. apply Reflexive_eq_notauF; eauto. Qed. -Instance Reflexive_eutt (r : itree E R -> itree E R -> Prop) : +Global Instance Reflexive_eutt (r : itree E R -> itree E R -> Prop) : Reflexive (paco2 (eutt_ eq) r). Proof. pcofix CIH. intros. pfold. apply Reflexive_euttF. eauto. Qed. -Instance Symmetric_eutt (r : itree E R -> itree E R -> Prop) +Global Instance Symmetric_eutt (r : itree E R -> itree E R -> Prop) (Sr : Symmetric r) : Symmetric (paco2 (eutt_ eq) r). Proof. @@ -806,7 +806,7 @@ Qed. (* [eutt] is a congruence wrt. [bind] *) -Instance eutt_bind {E R S} : +Global Instance eutt_bind {E R S} : Proper (eutt eq ==> pointwise_relation _ (eutt eq) ==> eutt eq) (@ITree.bind E R S). @@ -816,21 +816,21 @@ Proof. intros. pupto2_final. apply H0. Qed. -Instance eutt_paco {E R} r: +Global Instance eutt_paco {E R} r: Proper (eutt eq ==> eutt eq ==> flip impl) (paco2 (@eutt_ E R _ eq ∘ gres2 (eutt_ eq)) r). Proof. repeat intro. pupto2 eutt_clo_trans. eauto. Qed. -Instance eutt_gres {E R} r: +Global Instance eutt_gres {E R} r: Proper (eutt eq ==> eutt eq ==> flip impl) (gres2 (@eutt_ E R _ eq) r). Proof. repeat intro. pupto2 eutt_clo_trans. eauto. Qed. -Instance eutt_map {E R S} : +Global Instance eutt_map {E R S} : Proper (pointwise_relation _ eq ==> eutt eq ==> eutt eq) (@ITree.map E R S). Proof. unfold ITree.map. repeat red. @@ -838,12 +838,12 @@ Proof. intro. rewrite H. reflexivity. Qed. -Instance eutt_forever {E R S} : +Global Instance eutt_forever {E R S} : Proper (eutt eq ==> eutt eq) (@ITree.forever E R S). Proof. Admitted. -Instance eutt_when {E} (b : bool) : +Global Instance eutt_when {E} (b : bool) : Proper (eutt eq ==> eutt eq) (@ITree.when E b). Proof. Admitted. @@ -1028,7 +1028,7 @@ Proof. rewrite eutt__is_eutt'_. reflexivity. Qed. -Instance eutt'_paco {E R} r: +Global Instance eutt'_paco {E R} r: Proper (eutt eq ==> eutt eq ==> flip impl) (paco2 (@eutt'_ E R ∘ gres2 eutt'_) r). Proof. @@ -1038,7 +1038,7 @@ Proof. rewrite H, H0. eauto. Qed. -Instance eutt'_gres {E R} r: +Global Instance eutt'_gres {E R} r: Proper (eutt eq ==> eutt eq ==> flip impl) (gres2 (@eutt'_ E R) r). Proof. From 04262b7f1227fedda14409a1b6127c185d6722cb Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 18 Feb 2019 16:21:48 -0500 Subject: [PATCH 019/142] Some clean up and starting to fill up the admits, though admittedly through the introduction of new admitted lemma --- examples/Imp2Asm.v | 343 +++++++++++++++++++++++---------------------- 1 file changed, 175 insertions(+), 168 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index e1eae307..976132b6 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -1,5 +1,7 @@ Require Import Imp Asm. +Require Import Psatz. + From Coq Require Import Strings.String Morphisms @@ -14,37 +16,32 @@ From ExtLib Require Import Core.RelDec Structures.Monad Structures.Maps + Programming.Show Data.Map.FMapAList. - Import ListNotations. +Open Scope string_scope. Section compile_assign. - (* YZ: How to handle locals used to compute a composed expression? *) - (* - Simply reserve the prefix "local", carry how many have been created, and generate "local_n"? - Rough invariant: instrs = compile_expr_aux k e -> [instrs]σ = σ' -> σ'(gen_local k) = [e] - *) - - (* YZ: Ascii.ascii_of_nat is not what we want, unreadable *) - Definition gen_local (n: nat): string := - "local_" ++ (String (Ascii.ascii_of_nat n) ""). + Definition gen_tmp (n: nat): string := + "temp_" ++ to_string n. - (* Compiling mindlessly everything to the stack. Do we want to use asm's heap? *) + Definition varOf (s : var) : var := "local_" ++ s. + Fixpoint compile_expr (l: nat) (e: expr): list instr := match e with - | Var x => [Imov (gen_local l) (Ovar x)] - | Lit n => [Imov (gen_local l) (Oimm n)] + | Var x => [Imov (gen_tmp l) (Ovar (varOf x))] + | Lit n => [Imov (gen_tmp l) (Oimm n)] | Plus e1 e2 => let instrs1 := compile_expr l e1 in let instrs2 := compile_expr (S l) e2 in - instrs1 ++ instrs2 ++ [Iadd (gen_local l) (gen_local l) (Ovar (gen_local (S l)))] + instrs1 ++ instrs2 ++ [Iadd (gen_tmp l) (gen_tmp l) (Ovar (gen_tmp (S l)))] end. Definition compile_assign (x: Imp.var) (e: expr): list instr := let instrs := compile_expr 0 e in - instrs ++ [Imov x (Ovar (gen_local 0))]. + instrs ++ [Imov (varOf x) (Ovar (gen_tmp 0))]. End compile_assign. @@ -85,7 +82,7 @@ Variant WhileBlocks : Set := Though they should never be reused if I'm not mistaken, so a unique reserved id as currently is might actually simply do the trick. To double check. *) -Open Scope string_scope. + (* we could change this to `stmt -> program unit` and then compile the subterms * and then replace some of the jumps to do the actual linking. * @@ -236,14 +233,17 @@ Section tests. End tests. -Import MonadNotation. - Section denote_list. +Section denote_list. + + Import MonadNotation. + Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := fix traverse__ l: M unit := match l with | [] => ret tt | a::l => (f a;; traverse__ l)%monad end. + Context {E} {EL : Locals -< E} {EM : Memory -< E}. Definition denote_list: list instr -> itree E unit := @@ -259,7 +259,15 @@ Import MonadNotation. eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. Qed. - End denote_list. + Lemma denote_list_app: + forall is1 is2, + @denote_list (is1 ++ is2) ≅ + (@denote_list is1;; denote_list is2). + Proof. + Admitted. + +End denote_list. + Section Correctness. (* @@ -295,26 +303,24 @@ Section Correctness. + unfold ITree.map; rewrite ret_bind; reflexivity. Qed. -Definition varOf (s : var) : var := "_local" ++ s. - -Variant Rvar : var -> var -> Prop := -| Rvar_var v : Rvar (varOf v) v. + Variant Rvar : var -> var -> Prop := + | Rvar_var v : Rvar (varOf v) v. -Definition Renv (g_asm g_imp : alist var value) : Prop := - forall k_asm k_imp, Rvar k_asm k_imp -> - forall v, In (k_imp,v) g_imp -> In (k_asm, v) g_asm. + Definition Renv (g_asm g_imp : alist var value) : Prop := + forall k_asm k_imp, Rvar k_asm k_imp -> + forall v, In (k_imp,v) g_imp -> In (k_asm, v) g_asm. -(* Let's not unfold this inside of the main proof *) -Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := - fun '(g_asm', _) '(g_imp',v) => - Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) - In (gen_local n, v) g_asm' /\ (* we get the right value *) - (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) - In (gen_local m, v) g_asm <-> In (gen_local m, v) g_asm'). + (* Let's not unfold this inside of the main proof *) + Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := + fun '(g_asm', _) '(g_imp',v) => + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + In (gen_tmp n, v) g_asm' /\ (* we get the right value *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + In (gen_tmp m, v) g_asm <-> In (gen_tmp m, v) g_asm'). End Correctness. -Section TOMOVE. +Section EUTT. Context {E: Type -> Type}. Lemma Vis_eutt: forall {R1 R2 RR} {U} (e: E U) k k', @@ -325,11 +331,6 @@ Section TOMOVE. RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). Admitted. - - (* - This is sufficient to rewrite (eq_itree eq) under (eutt RR) through the fact that (eutt eq) is a subrelation of (eq_itree eq). - *) - Global Instance eutt_eq_under_rr {R1 R2 : Type} (RR: R1 -> R2 -> Prop): Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). Admitted. @@ -344,31 +345,27 @@ Section TOMOVE. Proof. Admitted. - - (* Instance subrelation_eq_eutt {E R} {RR} {SRR: Reflexive RR}: subrelation (@eq_itree E R) (@eutt _ _ _ RR). *) - (* Proof. *) - (* Admitted. *) - Lemma interp1_eq_eutt {F: Type -> Type} (h: E ~> itree F) R: @Proper (itree (E +' F) R -> itree F R) (eutt eq ==> eutt eq) (interp1 h R). Admitted. -End TOMOVE. +End EUTT. -Section TOORG. +Section GEN_TMP. - Context {E: Type -> Type}. - Context {HasMemory: Memory -< E}. - Context {HasLocals: Locals -< E}. + Lemma to_string_inj: forall (n m: nat), to_string n = to_string m -> n = m. + Admitted. - Lemma denote_list_app: - forall is1 is2, - @denote_list E _ _ (is1 ++ is2) ≅ - (@denote_list E _ _ is1;; denote_list is2). + Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. Proof. - Admitted. - -End TOORG. + intros n m ineq; intros abs; apply ineq. + apply to_string_inj; inversion abs; auto. + Qed. + +End GEN_TMP. + +Opaque gen_tmp. +Opaque varOf. Section Real_correctness. @@ -400,125 +397,135 @@ Section Real_correctness. @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). Admitted. - -Typeclasses eauto := 5. -Lemma compile_expr_correct : forall e g_imp g_asm n, - Renv g_asm g_imp -> - eutt (sim_rel g_asm n) - (interp_locals (denote_list (compile_expr n e)) g_asm) - (interp_locals (denoteExpr e) g_imp). -Proof. - induction e; simpl; intros. - { - Opaque gen_local. - rewrite itree_eta. - match goal with - | |- eutt _ _ ?x => - rewrite (itree_eta x) - end. - cbn. - do 2 rewrite tau_eutt. - rewrite itree_eta. + Ltac force_left := match goal with - | |- eutt _ _ ?x => - rewrite (itree_eta x) + | |- eutt _ ?x _ => rewrite (itree_eta x); cbn end. - cbn. - rewrite itree_eta. + + Ltac force_right := match goal with - | |- eutt _ _ ?x => - rewrite (itree_eta x) + | |- eutt _ _ ?x => rewrite (itree_eta x); cbn end. - cbn. - rewrite tau_eutt. - rewrite tau_eutt. - rewrite itree_eta. - match goal with - | |- eutt _ _ ?x => - rewrite (itree_eta x) - end. - cbn. - rewrite tau_eutt. - rewrite itree_eta. - cbn. - rewrite tau_eutt. - rewrite itree_eta. - cbn. - apply Ret_eutt. - red. - split; [| split]. - { - red. - repeat intro. - admit. - } - { - admit. - } - { - repeat intro. - admit. - } - } - { - do 3 (rewrite itree_eta; - match goal with - | |- eutt _ _ ?x => - rewrite (itree_eta x) - end; - cbn; - repeat rewrite tau_eutt - ). - apply Ret_eutt. - split; [| split]. - { admit. } - { admit. } - { admit. } - } - { - eapply eutt_eq_under_rr. - eapply eq_itree_interp_locals. - rewrite denote_list_app. - setoid_rewrite denote_list_app. - reflexivity. - reflexivity. - rewrite interp_locals_bind. - setoid_rewrite interp_locals_bind. - reflexivity. - rewrite interp_locals_bind. - eapply eutt_bind_gen. - eapply IHe1. - auto. + + Ltac untau_left := force_left; rewrite tau_eutt. + Ltac untau_right := force_right; rewrite tau_eutt. + + Arguments alist_add {_ _ _ _}. + Arguments alist_find {_ _ _ _}. + + Lemma Renv_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. + Admitted. + + Lemma In_alist_add {K V: Type} `{RelDec _ (@eq K)}: + forall k v (m: alist K V), + In (k,v) (alist_add k v m). + Admitted. + + Lemma alist_find_In_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: + forall k v (m: alist K V), + In (k,v) m <-> alist_find k m = Some v. + Admitted. + + Lemma alist_find_None {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: + forall k (m: alist K V), + (forall v, ~ In (k,v) m) <-> alist_find k m = None. + Admitted. + + Lemma In_add_ineq {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: + forall m (v v' : V) (k k' : K), + k <> k' -> + In (k, v) m <-> In (k, v) (alist_add k' v' m). + Proof. + Admitted. + + Lemma alist_unique_key {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: + forall k v v' (m: alist K V), + In (k,v) m -> In (k, v') m -> v = v'. + Proof. + Admitted. + + Lemma Renv_find: + forall g_asm g_imp x, + Renv g_asm g_imp -> + alist_find x g_imp = alist_find (varOf x) g_asm. + Proof. intros. - rewrite interp_locals_bind. - eapply eutt_bind_gen. - eapply IHe2. - destruct r1, r2, H0 as (H1 & H2 & H3); auto. + destruct (alist_find x g_imp) eqn:LUL, (alist_find (varOf x) g_asm) eqn:LUR; auto. + - rewrite <- alist_find_In_iff in LUL,LUR. + eapply H in LUL; [| constructor]. + f_equal; eapply alist_unique_key; eassumption. + - rewrite <- alist_find_In_iff in LUL. + eapply H in LUL; [| constructor]. + rewrite <- alist_find_None in LUR. + exfalso; eapply LUR; eauto. + - rewrite <- alist_find_None in LUL. + rewrite <- alist_find_In_iff in LUR. + (* YZ: does not hold, the invariant does not prevent the assembly stack to have more non temp variables defined than the source. + Reinforce the invariant, or weaken this lemma. + *) + Admitted. + + Lemma sim_rel_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> + sim_rel g_asm n (alist_add (gen_tmp n) v g_asm, tt) (g_imp, v). + Proof. intros. - rewrite itree_eta; - match goal with - | |- eutt _ _ ?x => - rewrite (itree_eta x) - end. - cbn. - rewrite tau_eutt. - rewrite itree_eta; cbn; rewrite tau_eutt. - (* Make a fairly pretty tactic(s) out of this *) - repeat (rewrite itree_eta; cbn; rewrite tau_eutt). - rewrite itree_eta; cbn. - apply Ret_eutt. split; [| split]. - { - destruct r0, r3; simpl. - admit. - } - { - admit. - } - { - admit. - } -Admitted. + - apply Renv_add; assumption. + - apply In_alist_add. + - intros m LT v'. + apply In_add_ineq, gen_tmp_inj; lia. + Qed. + + Lemma sim_rel_Renv: forall g_asm n sv1 sv2, + sim_rel g_asm n sv1 sv2 -> Renv (fst sv1) (fst sv2). + Proof. + intros ? ? ? ? H; destruct sv1, sv2; apply H. + Qed. + + Lemma compile_expr_correct : forall e g_imp g_asm n, + Renv g_asm g_imp -> + eutt (sim_rel g_asm n) + (interp_locals (denote_list (compile_expr n e)) g_asm) + (interp_locals (denoteExpr e) g_imp). + Proof. + induction e; simpl; intros. + - repeat untau_left. + repeat untau_right. + force_left; force_right. + apply Ret_eutt. + erewrite <- Renv_find; [| eassumption]. + apply sim_rel_add; assumption. + - repeat untau_left. + force_left. + force_right. + apply Ret_eutt. + apply sim_rel_add; assumption. + - do 2 setoid_rewrite denote_list_app. + do 2 setoid_rewrite interp_locals_bind. + eapply eutt_bind_gen. + + eapply IHe1; assumption. + + intros. + eapply eutt_bind_gen. + eapply IHe2. + eapply sim_rel_Renv; eassumption. + intros. + repeat untau_left. + force_left; force_right. + apply Ret_eutt. + split; [| split]. + { + destruct r0, r3; simpl. + admit. + } + { + admit. + } + { + admit. + } + Admitted. (* Seq a b From 7da6e67166f66f8a2df2f4adabc2b44fdacb5fbe Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 18 Feb 2019 16:58:04 -0500 Subject: [PATCH 020/142] Minor progress --- examples/Imp2Asm.v | 39 ++++++++++++++++++++++++++++++--------- 1 file changed, 30 insertions(+), 9 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 976132b6..73d9cd7b 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -478,12 +478,25 @@ Section Real_correctness. apply In_add_ineq, gen_tmp_inj; lia. Qed. - Lemma sim_rel_Renv: forall g_asm n sv1 sv2, - sim_rel g_asm n sv1 sv2 -> Renv (fst sv1) (fst sv2). + Lemma sim_rel_Renv: forall g_asm n s1 v1 s2 v2, + sim_rel g_asm n (s1,v1) (s2,v2) -> Renv s1 s2. Proof. - intros ? ? ? ? H; destruct sv1, sv2; apply H. + intros ? ? ? ? ? ? H; apply H. Qed. + Lemma sim_rel_find_tmp_n: + forall g_asm n g_asm' g_imp' v, + sim_rel g_asm n (g_asm', tt) (g_imp',v) -> + alist_find (gen_tmp n) g_asm' = Some v. + Admitted. + + Lemma sim_rel_find_tmp_lt_n: + forall g_asm n m g_asm' g_imp' v, + m < n -> + sim_rel g_asm n (g_asm', tt) (g_imp',v) -> + alist_find (gen_tmp m) g_asm = alist_find (gen_tmp m) g_asm'. + Admitted. + Lemma compile_expr_correct : forall e g_imp g_asm n, Renv g_asm g_imp -> eutt (sim_rel g_asm n) @@ -506,26 +519,34 @@ Section Real_correctness. do 2 setoid_rewrite interp_locals_bind. eapply eutt_bind_gen. + eapply IHe1; assumption. - + intros. + + intros [g_asm' []] [g_imp' v] HSIM. eapply eutt_bind_gen. eapply IHe2. eapply sim_rel_Renv; eassumption. - intros. + intros [g_asm'' []] [g_imp'' v'] HSIM'. repeat untau_left. force_left; force_right. apply Ret_eutt. split; [| split]. { - destruct r0, r3; simpl. - admit. + eapply Renv_add, sim_rel_Renv; eassumption. } { - admit. + generalize HSIM'; intros HSIM'2; apply sim_rel_find_tmp_n in HSIM'. + setoid_rewrite HSIM'; clear HSIM'. + eapply sim_rel_find_tmp_lt_n with (m := n) in HSIM'2; [simpl fst in HSIM'2| auto with arith]. + apply sim_rel_find_tmp_n in HSIM; rewrite HSIM'2 in HSIM. + setoid_rewrite HSIM. + apply In_alist_add. } { + simpl fst in *. + intros m LT v''. + rewrite <- In_add_ineq; [| apply gen_tmp_inj; lia]. admit. } - Admitted. + Admitted. + (* Seq a b From 3d692d2ada0ea689ba5a962755f19cc45c06e572 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 18 Feb 2019 20:12:26 -0500 Subject: [PATCH 021/142] we learned a lot, but we aren't done. --- examples/Imp2Asm.v | 524 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 487 insertions(+), 37 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 73d9cd7b..ba48fc2e 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -28,7 +28,7 @@ Section compile_assign. "temp_" ++ to_string n. Definition varOf (s : var) : var := "local_" ++ s. - + Fixpoint compile_expr (l: nat) (e: expr): list instr := match e with | Var x => [Imov (gen_tmp l) (Ovar (varOf x))] @@ -83,6 +83,188 @@ Variant WhileBlocks : Set := To double check. *) +(* this is what we need for seq *) +Definition link_seq (p1 : program unit) (p2 : program unit) : program unit. +refine + (let transL l := + match l with + | inl l => inl (inl l) + | inr tt => inl (inr None) (* *) + end + in + let transR l := + match l with + | inl l => inl (inr (Some l)) + | inr tt => inr tt + end + in + {| label := p1.(label) + option p2.(label) + ; main := fmap_block transL p1.(main) + ; blocks l := + match l with + | inl l => fmap_block transL (p1.(blocks) l) + | inr None => fmap_block transR p2.(main) + | inr (Some l) => fmap_block transR (p2.(blocks) l) + end + |}). +Defined. + + + + + +Definition link_if (b : block bool) (p1 : program unit) (p2 : program unit) +: program unit. +refine + (let to_right x := + match x with + | inl y => inl (inr (Some y)) + | inr y => inr y + end + in + let to_left x := + match x with + | inl y => inl (inl (Some y)) + | inr y => inr y + end + in + let lc := p1 in + let rc := p2 in + + {| label := option lc.(label) + option rc.(label) + ; blocks := fun x => + match x with + | inl None => + fmap_block to_left lc.(main) + | inl (Some x) => + fmap_block to_left (lc.(blocks) x) + | inr None => + fmap_block to_right rc.(main) + | inr (Some x) => + fmap_block to_right (rc.(blocks) x) + end + ; main := + fmap_block (fun l => + match l with + | true => inl (inl None) + | false => inl (inr None) + end) b + |}). + +Admitted. + +Definition link_while (b : block bool) (p1 : program unit) +: program unit. +Admitted. + + +(* +Record program2 (exports imports : Type) : Type := + { internal2 : Type + ; names : exports -> internal2 + ; blocks2 : internal2 -> block (internal2 + imports) }. + +Definition link2 {A B C} (p1 : program2 A (B + C)) (p2 : program2 B (A + C)) +: program2 (A + B) C. + +rec : program2 a (a + b) -> program a b +*) + +(* we could change this to `stmt -> program unit` and then compile the subterms + * and then replace some of the jumps to do the actual linking. + * + * the type of `program` can not be printed because the type of labels is + * exitentially quantified. it could be replaced with a finite map. + *) +Fixpoint compile2 (s : stmt) {struct s} : program unit. + refine + match s with + + | Skip => + + {| label := Empty_set + ; blocks := fun x => match x with end + ; main := bbb (Bjmp (inr tt)) |} + + | Assign x e => + + {| label := Empty_set + ; blocks := fun x => match x with end + ; main := after (compile_assign x e) + (bbb (Bjmp (inr tt))) |} + + | Seq l r => + + link_seq (compile2 l) (compile2 r) + + | If e l r => + + let to_right x := + match x with + | inl y => inl (inr (Some y)) + | inr y => inr y + end + in + let to_left x := + match x with + | inl y => inl (inl (Some y)) + | inr y => inr y + end + in + let lc := compile2 l in + let rc := compile2 r in + + {| label := option lc.(label) + option rc.(label) + ; blocks := fun x => + match x with + | inl None => + fmap_block to_left lc.(main) + | inl (Some x) => + fmap_block to_left (lc.(blocks) x) + | inr None => + fmap_block to_right rc.(main) + | inr (Some x) => + fmap_block to_right (rc.(blocks) x) + end + ; main := + after (compile_expr 0 e) + (bbb (Bbrz (gen_tmp 0) + (inl (inl None)) + (inl (inr None)))) + |} + + | While e b => + let bc := compile2 b in + {| label := WhileBlocks + + option bc.(label) + ; blocks := + let convert x := + match x with + | inl x => inl (inr (Some x)) + | inr x => inl (inl WhileTop) + end + in fun x => + match x with + | inl WhileTop => (* before evaluating e *) + after (compile_expr 0 e) + (bbb (Bbrz (gen_tmp 0) + (inl (inr None)) + (inl (inl WhileBottom)))) + | inl WhileBottom => (* after the loop exits *) + bbb (Bjmp (inr tt)) + | inr None => + fmap_block convert bc.(main) + | inr (Some x) => + fmap_block convert (bc.(blocks) x) + end + ; main := bbb (Bjmp (inl (inl WhileTop))) + |} + + end. +Defined. + + + (* we could change this to `stmt -> program unit` and then compile the subterms * and then replace some of the jumps to do the actual linking. * @@ -138,12 +320,12 @@ Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. let lc := @compile l unit (bbb (Bjmp tt)) in let rc := @compile r L k in - {| label := option (lc.(label) + rc.(label)) + {| label := lc.(label) + option rc.(label) ; blocks := fun x => match x with - | None => fmap_block _ rc.(main) - | Some (inl x) => fmap_block _ (lc.(blocks) x) - | Some (inr x) => fmap_block _ (rc.(blocks) x) + | inr None => fmap_block _ rc.(main) + | inl x => fmap_block _ (lc.(blocks) x) + | inr (Some x) => fmap_block _ (rc.(blocks) x) end ; main := fmap_block _ lc.(main) |} @@ -265,7 +447,7 @@ Section denote_list. (@denote_list is1;; denote_list is2). Proof. Admitted. - + End denote_list. Section Correctness. @@ -327,7 +509,7 @@ Section EUTT. (forall x, @eutt E R1 R2 RR (k x) (k' x)) -> eutt RR (Vis e k) (Vis e k'). Admitted. - Lemma Ret_eutt: forall {R1 R2} {RR: R1 -> R2 -> Prop} x y, + Lemma Ret_eutt: forall {R1 R2} {RR: R1 -> R2 -> Prop} x y, RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). Admitted. @@ -359,8 +541,8 @@ Section GEN_TMP. Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. Proof. intros n m ineq; intros abs; apply ineq. - apply to_string_inj; inversion abs; auto. - Qed. + apply to_string_inj; inversion abs; auto. + Qed. End GEN_TMP. @@ -374,7 +556,7 @@ Section Real_correctness. Definition E := Locals +' E'. Definition interp_locals {R: Type} (t: itree E R) (s: alist var value): itree E' (alist var value * R) := - run_env _ (interp1 evalLocals _ t) s. + run_env _ (interp1 evalLocals _ t) s. Instance eq_itree_interp_locals {R}: Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) @@ -401,7 +583,7 @@ Section Real_correctness. match goal with | |- eutt _ ?x _ => rewrite (itree_eta x); cbn end. - + Ltac force_right := match goal with | |- eutt _ _ ?x => rewrite (itree_eta x); cbn @@ -412,7 +594,7 @@ Section Real_correctness. Arguments alist_add {_ _ _ _}. Arguments alist_find {_ _ _ _}. - + Lemma Renv_add: forall g_asm g_imp n v, Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. Admitted. @@ -473,17 +655,17 @@ Section Real_correctness. intros. split; [| split]. - apply Renv_add; assumption. - - apply In_alist_add. + - apply In_alist_add. - intros m LT v'. apply In_add_ineq, gen_tmp_inj; lia. - Qed. + Qed. Lemma sim_rel_Renv: forall g_asm n s1 v1 s2 v2, sim_rel g_asm n (s1,v1) (s2,v2) -> Renv s1 s2. Proof. intros ? ? ? ? ? ? H; apply H. Qed. - + Lemma sim_rel_find_tmp_n: forall g_asm n g_asm' g_imp' v, sim_rel g_asm n (g_asm', tt) (g_imp',v) -> @@ -496,7 +678,7 @@ Section Real_correctness. sim_rel g_asm n (g_asm', tt) (g_imp',v) -> alist_find (gen_tmp m) g_asm = alist_find (gen_tmp m) g_asm'. Admitted. - + Lemma compile_expr_correct : forall e g_imp g_asm n, Renv g_asm g_imp -> eutt (sim_rel g_asm n) @@ -518,7 +700,7 @@ Section Real_correctness. - do 2 setoid_rewrite denote_list_app. do 2 setoid_rewrite interp_locals_bind. eapply eutt_bind_gen. - + eapply IHe1; assumption. + + eapply IHe1; assumption. + intros [g_asm' []] [g_imp' v] HSIM. eapply eutt_bind_gen. eapply IHe2. @@ -545,8 +727,40 @@ Section Real_correctness. rewrite <- In_add_ineq; [| apply gen_tmp_inj; lia]. admit. } - Admitted. + Admitted. + + Lemma Renv_write_local: + forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), + Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). + Proof. + intros x a a0 v H0. + red in H0. red. + intros. + (* this should mostly come from ExtLib *) + Admitted. + Lemma compile_assign_correct : forall e g_imp g_asm x, + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b)) + (interp_locals (denote_list (compile_assign x e)) g_asm) + (interp_locals (v <- denoteExpr e ;; lift (SetVar x v)) g_imp). + Proof. + simpl; intros. + unfold compile_assign. + rewrite denote_list_app. + do 2 rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply compile_expr_correct; eauto. + intros. + repeat untau_left. + force_left. + repeat untau_right; force_right. + eapply Ret_eutt; simpl. + destruct r1, r2. + erewrite sim_rel_find_tmp_n; eauto; simpl. + destruct H0. + eapply Renv_write_local; eauto. + Qed. (* Seq a b @@ -559,7 +773,7 @@ a :: itree _ Empty_set [[a]] :: itree _ L (* if closed *) *) -(* + Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} (p : program L) : p.(label) -> itree e (option L) := rec (fun lbl : p.(label) => @@ -570,6 +784,40 @@ Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} | Some (inr next) => ret (Some next) end). + Require Import ITree.MorphismsFacts. + Require Import ITree.FixFacts. + + Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) + : rec f x ≈ interp (fun _ e => match e with + | inl1 e => + match e in callE _ _ t return _ with + | Call x => rec f x + end + | inr1 e => lift e + end) _ (f x). + Proof. + unfold rec. unfold mrec. + rewrite interp_mrec_is_interp. + repeat rewrite <- MorphismsFacts.interp_is_interp1. + unfold MorphismsFacts.interp_match. + unfold mrec. + SearchAbout interp Proper. + Definition Rhom {E F : Type -> Type} : relation (E ~> F) := + fun l r => + forall x (e : E x), l _ e = r _ e. + Lemma eq_itree_interp: + forall (E F : Type -> Type) (R : Type), + Proper (@Rhom E (itree F) ==> eutt eq ==> eutt eq) + (fun f => interp f R). + Proof. Admitted. + eapply eq_itree_interp. + { red. destruct e; try reflexivity. + destruct c. + reflexivity. } + reflexivity. + Qed. + + Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} (p : program L) : itree e (option L) := next <- denote_block e p.(main) ;; @@ -579,19 +827,218 @@ Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} | Some (inr next) => ret (Some next) end. -Lemma true_compile_correct_program: +Arguments denote_block {_ _ _ _} _. +Arguments interp {_ _} _ {_} _. +Lemma interp_match_option : forall {T U} (x : option T) {E F} (h : E ~> itree F) (Z : itree _ U) Y, + interp h match x with + | None => Z + | Some y => Y y + end = +match x with +| None => interp h Z +| Some y => interp h (Y y) +end. +Proof. destruct x; reflexivity. Qed. +Lemma interp_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> itree F) (Z : _ -> itree _ U) Y, + interp h match x with + | inl x => Z x + | inr x => Y x + end = +match x with +| inl x => interp h (Z x) +| inr x => interp h (Y x) +end. +Proof. destruct x; reflexivity. Qed. + +(* +Proper (.. ==> eutt _) (rec _) + +let rec F := ... in +let rec G := ... in + +let rec F := let G := ... in ... in +*) + +(* +Lemma link_ok : forall p1 p2 l, + denote_program (link_seq p1 p2) l ≈ + rec (fun l => + match l with + | inl l => + l' <- denote_program p1 l ;; + match l' with + | None => Ret None + | Some _ => denote_main p2 + end + | inr None => denote_main p2 + | inr (Some l) => denote_program p2 l + end) l. +*) + +(* things to do? + * 1. change the compiler to not compress basic blocks. + * - ideally we would write a separate pass that does that + * - split out each of the structures as separate definitions and lemmas + * 2. need to prove `interp F (denote_block ...) = denote_block ...` + * 3. link_seq_ok should be a proof by co-induction. + * 4. clean up this file *a lot* + * bonus: block fusion + * bonus: break & continue + *) + + + +Lemma link_seq_ok : forall p1 p2 l, + denote_program (link_seq p1 p2) l ≈ + match l with + | inl l => + l' <- denote_program p1 l ;; + match l' with + | None => Ret None + | Some _ => denote_main p2 + end + | inr None => denote_main p2 + | inr (Some l) => denote_program p2 l + end. +Proof. + intros. + destruct l. + { (* in the left *) + unfold denote_program. + rewrite rec_unfold at 1. + repeat rewrite interp_bind. + match goal with + | |- ITree.bind ?X _ ≈ _ => + assert (X = (denote_block (blocks (link_seq p1 p2) (inl l)))) + end. + admit. + rewrite H. + rewrite rec_unfold. + repeat rewrite interp_bind. + repeat rewrite bind_bind. + match goal with + | |- _ ≈ ITree.bind ?X _ => + assert (X = (denote_block (blocks p1 l))) + end. + admit. + rewrite H0. + simpl. + rewrite fmap_block_map. + unfold ITree.map. + rewrite bind_bind. + setoid_rewrite ret_bind. + eapply eutt_bind_gen. + { instantiate (1:=eq). reflexivity. } + intros; subst. + repeat rewrite interp_match_option. + unfold option_map. + destruct r2. + { destruct s. + - admit. + - destruct u. admit. } + { admit. } } + { unfold denote_program. + simpl. + +} + + + + Lemma denote_block_no_calls : + interp (hBoth L id) (liftR id) = interp id e. + + Print denote_program. + Print denote_block. + simpl denote_block. + Eval simpl in (denote_block (blocks (link_seq p1 p2) (inl l))). + simpl. + + simpl. + unfold denote_block at 2. + simpl. +About denote_block. +setoid_rewrite interp_match_option. + + eapply eutt_bind_gen. + Show Existentials. + eapply eq_itree_interp. + + + + + + + + do 2 rewrite rec_unfold. + +Admitted. + + Lemma true_compile_correct_program: + forall s (g_imp g_asm : alist var value), + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) + (interp_locals (denote_main (compile s)) g_asm) + (interp_locals (denoteStmt s;; Ret (Some tt)) g_imp). + + + + + + + + + Lemma true_compile_correct_program: forall s L (b: block L) (g_imp g_asm : alist var value), Renv g_asm g_imp -> - euttG (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) - (run_env _ (denote_main (compile s b)) g_asm) - (run_env _ (denoteStmt s;; denote_block _ b) g_imp). -Proof. - induction s. - { admit. } - { simpl. - unfold denote_main. simpl. - intros. -*) + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) + (interp_locals (denote_main (compile s b)) g_asm) + (interp_locals (denoteStmt s;; denote_block _ b) g_imp). + Proof. + induction s; intros. + { (* assign *) + simpl. + unfold denote_main. simpl. unfold denote_program. + simpl. + rewrite denote_after_denote_list. + rewrite bind_bind. + rewrite interp_locals_bind. + rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply compile_assign_correct; eauto. + simpl; intros. + clear - H0. + rewrite fmap_block_map. + unfold ITree.map. + rewrite bind_bind. + setoid_rewrite ret_bind. + rewrite <- (bind_ret (interp_locals _ (fst r2))). + rewrite interp_locals_bind. + eapply eutt_bind_gen. + { SearchAbout denote_block. + instantiate (1 := fun a b => Renv (fst a) (fst b) /\ snd a = snd b). + admit. } + { simpl. + intros. + destruct r0, r3; simpl in *. + destruct H; subst. + destruct o0; simpl. + { force_left. + eapply Ret_eutt. + simpl. tauto. } + { force_left. eapply Ret_eutt; simpl. tauto. } } } + { (* seq *) + simpl. + specialize (IHs1 _ (main (compile s2 b)) _ _ H). + rewrite bind_bind. + unfold denote_main; simpl. + unfold denote_main in IHs1. + rewrite fmap_block_map. + unfold ITree.map. rewrite bind_bind. + setoid_rewrite ret_bind. + + + + Arguments denote_program {_ _ _ _} _ _. Arguments denote_block {_ _ _ _} _. @@ -604,13 +1051,16 @@ Proof. (* TODO: parameterize by REnv *) Lemma compile_correct_program: - forall s L (b: block L) imports, - denote_main (compile s b) imports ≈ - (denoteStmt s;; ml <- denote_block b;; - (match ml with - | None => Ret tt - | Some l => imports l - end)). + forall s L (b: block L) imports g_asm g_imp, + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b)) + (interp_locals (denote_main (compile s b) imports) g_asm) + (interp_locals (denoteStmt s;; + ml <- denote_block b;; + match ml with + | None => Ret tt + | Some l => imports l + end) g_imp). Proof. (* simpl. induction s; intros L b imports. From d6b181d5085948dc50d839a99a7616a5e7097b65 Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 18 Feb 2019 22:43:13 -0500 Subject: [PATCH 022/142] Proving a few lemmas that should go to ExtLib and that we need. Proving easy lemmas is a good catharsis after this afternoon hard stuff --- examples/Imp2Asm.v | 164 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 142 insertions(+), 22 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index ba48fc2e..6b9ce099 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -595,38 +595,158 @@ Section Real_correctness. Arguments alist_add {_ _ _ _}. Arguments alist_find {_ _ _ _}. - Lemma Renv_add: forall g_asm g_imp n v, - Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. - Admitted. - - Lemma In_alist_add {K V: Type} `{RelDec _ (@eq K)}: + Lemma In_add_eq {K V: Type} `{RelDec _ (@eq K)}: forall k v (m: alist K V), In (k,v) (alist_add k v m). - Admitted. + Proof. + intros; left; reflexivity. + Qed. - Lemma alist_find_In_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: - forall k v (m: alist K V), - In (k,v) m <-> alist_find k m = Some v. - Admitted. + Ltac flatten_goal := + match goal with + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. - Lemma alist_find_None {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: - forall k (m: alist K V), - (forall v, ~ In (k,v) m) <-> alist_find k m = None. - Admitted. + Ltac flatten_hyp h := + match type of h with + | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + + Ltac flatten_all := + match goal with + | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + + Ltac inv h := inversion h; subst; clear h. + + (* A removed key is not contained in the resulting map *) + Lemma not_In_remove_ineq: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v: V), + ~ In (k, v) (alist_remove _ k m). + Proof. + induction m as [| [k1 v1] m IH]; intros; auto. + simpl. + flatten_goal. + - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. + intros [EQ | IN]; [inv EQ; easy | eapply IH; eauto]. + - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + intros abs; eapply IH; eauto. + Qed. + + (* Removing a key does not alter other keys *) + Lemma In_In_remove_ineq: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v : V) (k' : K), + k <> k' -> + In (k,v) m -> + In (k, v) (alist_remove _ k' m). + Proof. + induction m as [| [? ?] m IH]; intros ?k ?v ?k' ineq IN; [inversion IN |]. + simpl. + flatten_goal. + - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. + destruct IN as [EQ | IN]; [inv EQ; left; auto | right; eapply IH; eauto]. + - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + destruct IN as [EQ | IN]; [inv EQ; tauto | eapply IH; eauto]. + Qed. + + Lemma In_remove_In_ineq: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v : V) (k' : K), + In (k, v) (alist_remove _ k' m) -> + In (k,v) m. + Proof. + induction m as [| [? ?] m IH]; intros ?k ?v ?k' IN; [inversion IN |]. + simpl in IN; flatten_hyp IN. + - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. + destruct IN as [EQ | IN]; [inv EQ; left; auto | right; eapply IH; eauto]. + - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + right; eapply IH; eauto. + Qed. + + Lemma In_remove_In_ineq_iff: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v : V) (k' : K), + k <> k' -> + In (k, v) (alist_remove _ k' m) <-> + In (k,v) m. + Proof. + intros; split; eauto using In_In_remove_ineq, In_remove_In_ineq. + Qed. + + (* Adding a value to a key does not alter other keys *) + Lemma In_In_add_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: + forall k v k' v' (m: alist K V), + k <> k' -> + In (k,v) m -> + In (k,v) (alist_add k' v' m). + Proof. + intros; right. + apply In_In_remove_ineq; auto. + Qed. - Lemma In_add_ineq {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: + Lemma In_add_In_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: + forall k v k' v' (m: alist K V), + k <> k' -> + In (k,v) (alist_add k' v' m) -> + In (k,v) m. + Proof. + intros k v k' v' m ineq [EQ | IN]; [inv EQ; tauto |]. + eapply In_remove_In_ineq; eauto. + Qed. + + Lemma In_add_ineq_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: forall m (v v' : V) (k k' : K), k <> k' -> In (k, v) m <-> In (k, v) (alist_add k' v' m). + Proof. + intros; split; eauto using In_In_add_ineq, In_add_In_ineq. + Qed. + + (* alist_find fails iff no value is associated to the key in the map *) + Lemma alist_find_None {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + forall k (m: alist K V), + (forall v, ~ In (k,v) m) <-> alist_find k m = None. + Proof. + induction m as [| [k1 v1] m IH]; [simpl; easy |]. + simpl; split; intros H. + - flatten_goal; [rewrite rel_dec_correct in Heq; subst; exfalso | rewrite <- neg_rel_dec_correct in Heq]. + apply (H v1); left; reflexivity. + apply IH; intros v abs; apply (H v); right; assumption. + - intros v; flatten_hyp H; [inv H | rewrite <- IH in H]. + intros [EQ | abs]; [inv EQ; rewrite <- neg_rel_dec_correct in Heq; tauto | apply (H v); assumption]. + Qed. + + (* A key is stored at most once in the map *) + (* Oopsy daisy, though all alist operations preserve this invariant, its type does not state so *) + (* To avoid using if possible *) + Lemma alist_unique_key {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + forall k (m: alist K V) v v', + In (k,v) m -> In (k,v') m -> v = v'. Proof. Admitted. - Lemma alist_unique_key {K V: Type} `{RR: RelDec _ (@eq K)} `{@RelDec_Correct _ _ RR}: - forall k v v' (m: alist K V), - In (k,v) m -> In (k, v') m -> v = v'. + (* alist_find succeeds iff the same value is associated to the key in the map *) + (* Same here, the value found is always the same only with respect to a global invariant over alist *) + Lemma alist_find_In_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + forall k v (m: alist K V), + In (k,v) m <-> alist_find k m = Some v. Proof. Admitted. + Lemma Renv_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. + Proof. + repeat intro. + destruct (k_asm ?[ eq ] (gen_tmp n)) eqn:EQ. + rewrite rel_dec_correct in EQ; subst; inv H0. + rewrite <- neg_rel_dec_correct in EQ. + eapply H in H1; [| eassumption]. + apply In_add_ineq_iff; auto. + Qed. + Lemma Renv_find: forall g_asm g_imp x, Renv g_asm g_imp -> @@ -655,9 +775,9 @@ Section Real_correctness. intros. split; [| split]. - apply Renv_add; assumption. - - apply In_alist_add. + - apply In_add_eq. - intros m LT v'. - apply In_add_ineq, gen_tmp_inj; lia. + apply In_add_ineq_iff, gen_tmp_inj; lia. Qed. Lemma sim_rel_Renv: forall g_asm n s1 v1 s2 v2, @@ -719,12 +839,12 @@ Section Real_correctness. eapply sim_rel_find_tmp_lt_n with (m := n) in HSIM'2; [simpl fst in HSIM'2| auto with arith]. apply sim_rel_find_tmp_n in HSIM; rewrite HSIM'2 in HSIM. setoid_rewrite HSIM. - apply In_alist_add. + apply In_add_eq. } { simpl fst in *. intros m LT v''. - rewrite <- In_add_ineq; [| apply gen_tmp_inj; lia]. + rewrite <- In_add_ineq_iff; [| apply gen_tmp_inj; lia]. admit. } Admitted. From 7d814765a51508bfc0bdcc0ca027a7a8d3bac3ab Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 19 Feb 2019 11:08:09 -0500 Subject: [PATCH 023/142] Fixing a couple of easy lemmas about eutt --- examples/Imp2Asm.v | 47 +++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 42 insertions(+), 5 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 6b9ce099..672d0183 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -446,7 +446,9 @@ Section denote_list. @denote_list (is1 ++ is2) ≅ (@denote_list is1;; denote_list is2). Proof. - Admitted. + intros is1 is2; induction is1 as [| i is1 IH]; simpl; intros; [rewrite ret_bind; reflexivity |]. + rewrite bind_bind; setoid_rewrite IH; reflexivity. + Qed. End denote_list. @@ -504,14 +506,49 @@ End Correctness. Section EUTT. + Require Import Paco.paco. + Context {E: Type -> Type}. - Lemma Vis_eutt: forall {R1 R2 RR} {U} (e: E U) k k', - (forall x, @eutt E R1 R2 RR (k x) (k' x)) -> eutt RR (Vis e k) (Vis e k'). - Admitted. + + Lemma unalltausF_ret {R}: forall x (t: itree' E R), + unalltausF (RetF x) t -> t = RetF x. + Proof. + intros x t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. + Qed. + + Lemma unalltausF_vis {R S}: forall e (k: S -> itree E R) (t: itree' E R), + unalltausF (VisF e k) t -> t = VisF e k. + Proof. + intros e k t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. + Qed. Lemma Ret_eutt: forall {R1 R2} {RR: R1 -> R2 -> Prop} x y, RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). - Admitted. + Proof. + intros. + pfold. + constructor. + split; intros; eapply finite_taus_ret; reflexivity. + intros. + apply unalltausF_ret in UNTAUS1. + apply unalltausF_ret in UNTAUS2. + subst; constructor; assumption. + Qed. + + Lemma Vis_eutt: forall {R1 R2 RR} {U} (e: E U) k k', + (forall x, @eutt E R1 R2 RR (k x) (k' x)) -> eutt RR (Vis e k) (Vis e k'). + Proof. + intros. + pfold; constructor. + split; intros; eapply finite_taus_vis; reflexivity. + intros. + cbn in *. + apply unalltausF_vis in UNTAUS1. + apply unalltausF_vis in UNTAUS2. + subst; constructor. + intros x; specialize (H x). + punfold H. + Qed. Global Instance eutt_eq_under_rr {R1 R2 : Type} (RR: R1 -> R2 -> Prop): Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). From b98342ad710b85fe6c03feae0d85725da748404b Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 19 Feb 2019 12:07:06 -0500 Subject: [PATCH 024/142] Moving from In to alist_In in the simulation relation and fixing the lemmas accordingly --- examples/Imp2Asm.v | 129 ++++++++++++++++++++++++--------------------- 1 file changed, 69 insertions(+), 60 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 672d0183..fe2f4b1a 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -490,17 +490,21 @@ Section Correctness. Variant Rvar : var -> var -> Prop := | Rvar_var v : Rvar (varOf v) v. + Arguments alist_find {_ _ _ _}. + + Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. + Definition Renv (g_asm g_imp : alist var value) : Prop := forall k_asm k_imp, Rvar k_asm k_imp -> - forall v, In (k_imp,v) g_imp -> In (k_asm, v) g_asm. + forall v, alist_In k_imp g_imp v -> alist_In k_asm g_asm v. (* Let's not unfold this inside of the main proof *) Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := fun '(g_asm', _) '(g_imp',v) => Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) - In (gen_tmp n, v) g_asm' /\ (* we get the right value *) + alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) - In (gen_tmp m, v) g_asm <-> In (gen_tmp m, v) g_asm'). + alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). End Correctness. @@ -632,13 +636,6 @@ Section Real_correctness. Arguments alist_add {_ _ _ _}. Arguments alist_find {_ _ _ _}. - Lemma In_add_eq {K V: Type} `{RelDec _ (@eq K)}: - forall k v (m: alist K V), - In (k,v) (alist_add k v m). - Proof. - intros; left; reflexivity. - Qed. - Ltac flatten_goal := match goal with | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq @@ -656,20 +653,29 @@ Section Real_correctness. end. Ltac inv h := inversion h; subst; clear h. + Arguments alist_remove {_ _ _ _}. + + Lemma In_add_eq {K V: Type} {RR:RelDec eq} {RRC:@RelDec_Correct _ _ RR}: + forall k v (m: alist K V), + alist_In k (alist_add k v m) v. + Proof. + intros; unfold alist_add, alist_In; simpl; flatten_goal; [reflexivity | rewrite <- neg_rel_dec_correct in Heq; tauto]. + Qed. (* A removed key is not contained in the resulting map *) - Lemma not_In_remove_ineq: + Lemma not_In_remove: forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} (m : alist K V) (k : K) (v: V), - ~ In (k, v) (alist_remove _ k m). + ~ alist_In k (alist_remove k m) v. Proof. - induction m as [| [k1 v1] m IH]; intros; auto. - simpl. - flatten_goal. - - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. - intros [EQ | IN]; [inv EQ; easy | eapply IH; eauto]. - - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. - intros abs; eapply IH; eauto. + induction m as [| [k1 v1] m IH]; intros. + - simpl; intros abs; inv abs. + - simpl; flatten_goal. + + unfold alist_In; simpl. + rewrite Bool.negb_true_iff in Heq; rewrite Heq. + intros abs; eapply IH; eassumption. + + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + intros abs; eapply IH; eauto. Qed. (* Removing a key does not alter other keys *) @@ -677,38 +683,44 @@ Section Real_correctness. forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} (m : alist K V) (k : K) (v : V) (k' : K), k <> k' -> - In (k,v) m -> - In (k, v) (alist_remove _ k' m). + alist_In k m v -> + alist_In k (alist_remove k' m) v. Proof. induction m as [| [? ?] m IH]; intros ?k ?v ?k' ineq IN; [inversion IN |]. simpl. flatten_goal. - - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. - destruct IN as [EQ | IN]; [inv EQ; left; auto | right; eapply IH; eauto]. - - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. - destruct IN as [EQ | IN]; [inv EQ; tauto | eapply IH; eauto]. + - unfold alist_In in *; simpl in *. + rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. + flatten_goal; auto. + - unfold alist_In in *; simpl in *. + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto | eapply IH; eauto]. Qed. Lemma In_remove_In_ineq: forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} (m : alist K V) (k : K) (v : V) (k' : K), - In (k, v) (alist_remove _ k' m) -> - In (k,v) m. + alist_In k (alist_remove k' m) v -> + alist_In k m v. Proof. induction m as [| [? ?] m IH]; intros ?k ?v ?k' IN; [inversion IN |]. simpl in IN; flatten_hyp IN. - - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. - destruct IN as [EQ | IN]; [inv EQ; left; auto | right; eapply IH; eauto]. - - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. - right; eapply IH; eauto. + - unfold alist_In in *; simpl in *. + flatten_all; auto. + eapply IH; eauto. + -rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + unfold alist_In; simpl. + flatten_goal; [rewrite rel_dec_correct in Heq; subst |]. + exfalso; eapply not_In_remove; eauto. + eapply IH; eauto. Qed. Lemma In_remove_In_ineq_iff: forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} (m : alist K V) (k : K) (v : V) (k' : K), k <> k' -> - In (k, v) (alist_remove _ k' m) <-> - In (k,v) m. + alist_In k (alist_remove k' m) v <-> + alist_In k m v. Proof. intros; split; eauto using In_In_remove_ineq, In_remove_In_ineq. Qed. @@ -717,27 +729,29 @@ Section Real_correctness. Lemma In_In_add_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: forall k v k' v' (m: alist K V), k <> k' -> - In (k,v) m -> - In (k,v) (alist_add k' v' m). + alist_In k m v -> + alist_In k (alist_add k' v' m) v. Proof. - intros; right. + intros. + unfold alist_In; simpl; flatten_goal; [rewrite rel_dec_correct in Heq; subst; tauto |]. apply In_In_remove_ineq; auto. Qed. Lemma In_add_In_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: forall k v k' v' (m: alist K V), k <> k' -> - In (k,v) (alist_add k' v' m) -> - In (k,v) m. + alist_In k (alist_add k' v' m) v -> + alist_In k m v. Proof. - intros k v k' v' m ineq [EQ | IN]; [inv EQ; tauto |]. + intros k v k' v' m ineq IN. + unfold alist_In in IN; simpl in IN; flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto |]. eapply In_remove_In_ineq; eauto. Qed. Lemma In_add_ineq_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: forall m (v v' : V) (k k' : K), k <> k' -> - In (k, v) m <-> In (k, v) (alist_add k' v' m). + alist_In k m v <-> alist_In k (alist_add k' v' m) v. Proof. intros; split; eauto using In_In_add_ineq, In_add_In_ineq. Qed. @@ -759,19 +773,19 @@ Section Real_correctness. (* A key is stored at most once in the map *) (* Oopsy daisy, though all alist operations preserve this invariant, its type does not state so *) (* To avoid using if possible *) - Lemma alist_unique_key {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: - forall k (m: alist K V) v v', - In (k,v) m -> In (k,v') m -> v = v'. - Proof. - Admitted. + (* Lemma alist_unique_key {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: *) + (* forall k (m: alist K V) v v', *) + (* In (k,v) m -> In (k,v') m -> v = v'. *) + (* Proof. *) + (* Admitted. *) (* alist_find succeeds iff the same value is associated to the key in the map *) (* Same here, the value found is always the same only with respect to a global invariant over alist *) - Lemma alist_find_In_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: - forall k v (m: alist K V), - In (k,v) m <-> alist_find k m = Some v. - Proof. - Admitted. + (* Lemma alist_find_In_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: *) + (* forall k v (m: alist K V), *) + (* alist_In k m v <-> alist_find k m = Some v. *) + (* Proof. *) + (* Admitted. *) Lemma Renv_add: forall g_asm g_imp n v, Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. @@ -791,16 +805,11 @@ Section Real_correctness. Proof. intros. destruct (alist_find x g_imp) eqn:LUL, (alist_find (varOf x) g_asm) eqn:LUR; auto. - - rewrite <- alist_find_In_iff in LUL,LUR. - eapply H in LUL; [| constructor]. - f_equal; eapply alist_unique_key; eassumption. - - rewrite <- alist_find_In_iff in LUL. - eapply H in LUL; [| constructor]. - rewrite <- alist_find_None in LUR. - exfalso; eapply LUR; eauto. - - rewrite <- alist_find_None in LUL. - rewrite <- alist_find_In_iff in LUR. - (* YZ: does not hold, the invariant does not prevent the assembly stack to have more non temp variables defined than the source. + - eapply H in LUL; [| constructor]. + rewrite LUL in LUR; auto. + - eapply H in LUL; [| constructor]. + rewrite LUL in LUR; auto. + - (* YZ: does not hold, the invariant does not prevent the assembly stack to have more non temp variables defined than the source. Reinforce the invariant, or weaken this lemma. *) Admitted. From 02b8f1512390eb206a0842a63ba80cac209f2b33 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 19 Feb 2019 13:10:53 -0500 Subject: [PATCH 025/142] Move lemmas from Imp2Asm example to UpToTaus --- Makefile | 5 ++- examples/Imp2Asm.v | 65 +++------------------------------ theories/Core.v | 2 ++ theories/Eq/UpToTaus.v | 81 +++++++++++++++++++++++++++++++++++------- 4 files changed, 79 insertions(+), 74 deletions(-) diff --git a/Makefile b/Makefile index e2443313..934f4254 100644 --- a/Makefile +++ b/Makefile @@ -35,10 +35,13 @@ example-io: examples/IO.v coqc -Q ../theories/ ITree IO.v && \ ocamlbuild io.native && ./io.native -example-asm: examples/Asm.v +example-asm: example-imp examples/Asm.v cd examples && \ coqc -Q ../theories/ ITree Asm.v +example-imp2asm: example-asm examples/Imp2Asm.v + cd examples && \ + coqc -Q ../theories/ ITree Imp2Asm.v THREADSV=examples/MultiThreadedPrinting.v examples/ExtractThreadsExample.v THREADSML=examples/runthread.ml diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index fe2f4b1a..801c7eec 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -514,54 +514,6 @@ Section EUTT. Context {E: Type -> Type}. - Lemma unalltausF_ret {R}: forall x (t: itree' E R), - unalltausF (RetF x) t -> t = RetF x. - Proof. - intros x t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. - Qed. - - Lemma unalltausF_vis {R S}: forall e (k: S -> itree E R) (t: itree' E R), - unalltausF (VisF e k) t -> t = VisF e k. - Proof. - intros e k t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. - Qed. - - Lemma Ret_eutt: forall {R1 R2} {RR: R1 -> R2 -> Prop} x y, - RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). - Proof. - intros. - pfold. - constructor. - split; intros; eapply finite_taus_ret; reflexivity. - intros. - apply unalltausF_ret in UNTAUS1. - apply unalltausF_ret in UNTAUS2. - subst; constructor; assumption. - Qed. - - Lemma Vis_eutt: forall {R1 R2 RR} {U} (e: E U) k k', - (forall x, @eutt E R1 R2 RR (k x) (k' x)) -> eutt RR (Vis e k) (Vis e k'). - Proof. - intros. - pfold; constructor. - split; intros; eapply finite_taus_vis; reflexivity. - intros. - cbn in *. - apply unalltausF_vis in UNTAUS1. - apply unalltausF_vis in UNTAUS2. - subst; constructor. - intros x; specialize (H x). - punfold H. - Qed. - - Global Instance eutt_eq_under_rr {R1 R2 : Type} (RR: R1 -> R2 -> Prop): - Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). - Admitted. - - Global Instance reflexive_eutt {R} RR `{Reflexive _ RR}: - Reflexive (@eutt E R R RR). - Admitted. - Instance eq_itree_run_env {E R} {K V map} {Mmap: Maps.Map K V map}: Proper (@eutt (envE K V +' E) R R eq ==> eq ==> @eutt E (prod map R) (prod map R) eq) (run_env R). @@ -613,13 +565,6 @@ Section Real_correctness. Set Nested Proofs Allowed. - Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: - forall t1 t2, - eutt RR t1 t2 -> - forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> - @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). - Admitted. - Ltac force_left := match goal with | |- eutt _ ?x _ => rewrite (itree_eta x); cbn @@ -855,13 +800,13 @@ Section Real_correctness. - repeat untau_left. repeat untau_right. force_left; force_right. - apply Ret_eutt. + apply eutt_Ret. erewrite <- Renv_find; [| eassumption]. apply sim_rel_add; assumption. - repeat untau_left. force_left. force_right. - apply Ret_eutt. + apply eutt_Ret. apply sim_rel_add; assumption. - do 2 setoid_rewrite denote_list_app. do 2 setoid_rewrite interp_locals_bind. @@ -874,7 +819,7 @@ Section Real_correctness. intros [g_asm'' []] [g_imp'' v'] HSIM'. repeat untau_left. force_left; force_right. - apply Ret_eutt. + apply eutt_Ret. split; [| split]. { eapply Renv_add, sim_rel_Renv; eassumption. @@ -921,7 +866,7 @@ Section Real_correctness. repeat untau_left. force_left. repeat untau_right; force_right. - eapply Ret_eutt; simpl. + eapply eutt_Ret; simpl. destruct r1, r2. erewrite sim_rel_find_tmp_n; eauto; simpl. destruct H0. @@ -1315,4 +1260,4 @@ l: [x] .... l1: ...; jmp[a] l2: ...; jmp[b] -*) \ No newline at end of file +*) diff --git a/theories/Core.v b/theories/Core.v index 029077b2..f00bd104 100644 --- a/theories/Core.v +++ b/theories/Core.v @@ -65,6 +65,8 @@ End itree. Arguments itree _ _ : clear implicits. Arguments itreeF _ _ : clear implicits. +Notation itree' E R := (itreeF E R (itree E R)). + Definition observe {E R} := @_observe E R. Ltac fold_observe := change @_observe with @observe in *. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 199de129..1884b357 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -257,6 +257,18 @@ Proof. + inv OBS0. inversion H0; subst; eauto. Qed. +Lemma unalltausF_ret : forall x (t: itree' E R), + unalltausF (RetF x) t -> t = RetF x. +Proof. + intros x t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. +Qed. + +Lemma unalltausF_vis {S}: forall e (k: S -> itree E R) (t: itree' E R), + unalltausF (VisF e k) t -> t = VisF e k. +Proof. + intros e k t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. +Qed. + End FiniteTaus. Arguments untaus_unalltaus_rev : clear implicits. @@ -477,6 +489,34 @@ Proof. pfold. eapply eq_itreeF_mono; eauto. Qed. +Lemma eutt_Ret x y : + RR x y -> eutt (Ret x) (Ret y). +Proof. + intros; pfold. + constructor. + split; intros; eapply finite_taus_ret; reflexivity. + intros. + apply unalltausF_ret in UNTAUS1. + apply unalltausF_ret in UNTAUS2. + subst; constructor; assumption. +Qed. + +Lemma eutt_Vis {U} (e: E U) k k' : + (forall x, eutt (k x) (k' x)) -> + eutt (Vis e k) (Vis e k'). +Proof. + intros. + pfold; constructor. + split; intros; eapply finite_taus_vis; reflexivity. + intros. + cbn in *. + apply unalltausF_vis in UNTAUS1. + apply unalltausF_vis in UNTAUS2. + subst; constructor. + intros x; specialize (H x). + punfold H. +Qed. + End EUTT. Hint Constructors eq_notauF. @@ -490,8 +530,8 @@ Section EUTT_rel. Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). (* Reflexivity of [eq_notauF], modulo a few assumptions. *) -Lemma Reflexive_eq_notauF I (eq_ : I -> I -> Prop) (ot : itreeF E R I) : - Reflexive eq_ -> notauF ot -> eq_notauF eq eq_ ot ot. +Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) (ot : itreeF E R I) : + Reflexive eq_ -> notauF ot -> eq_notauF RR eq_ ot ot. Proof. intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. Qed. @@ -515,12 +555,10 @@ Section EUTT_eq. Context {E : Type -> Type} {R : Type}. -Let eutt : itree E R -> itree E R -> Prop := eutt eq. - -Infix "≈" := eutt (at level 70) : itree_scope. - -Global Instance Reflexive_euttF (r : itree E R -> itree E R -> Prop) : - Reflexive r -> Reflexive (euttF eq r). +Global Instance Reflexive_euttF + {RR : R -> R -> Prop} `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive r -> Reflexive (euttF RR r). Proof. split. - reflexivity. @@ -529,13 +567,19 @@ Proof. apply Reflexive_eq_notauF; eauto. Qed. -Global Instance Reflexive_eutt (r : itree E R -> itree E R -> Prop) : - Reflexive (paco2 (eutt_ eq) r). +Global Instance Reflexive_eutt + {RR : R -> R -> Prop} `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive (paco2 (eutt_ RR) r). Proof. pcofix CIH. - intros. pfold. apply Reflexive_euttF. eauto. + intros. pfold. red. apply Reflexive_euttF; eauto. Qed. +Let eutt : itree E R -> itree E R -> Prop := eutt eq. + +Infix "≈" := eutt (at level 70) : itree_scope. + Global Instance Symmetric_eutt (r : itree E R -> itree E R -> Prop) (Sr : Symmetric r) : Symmetric (paco2 (eutt_ eq) r). @@ -856,8 +900,6 @@ Proof. apply subrelation_eq_eutt, map_map. Qed. -Notation itree' E R := (itreeF E R (itree E R)). - Definition observing {E R} (f : itree' E R -> itree' E R -> Prop) (x y : itree E R) := @@ -1047,3 +1089,16 @@ Proof. rewrite grespectful2_iff in H1; [|intros; erewrite eutt__is_eutt'_; reflexivity]. rewrite H, H0. eauto. Qed. + +Global Instance eutt_eq_under_rr {E : Type -> Type} + {R1 R2 : Type} (RR: R1 -> R2 -> Prop): + Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). +Admitted. + +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). +Admitted. From ac6731eb098c1e13054a379b64edec568ecc83e7 Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 19 Feb 2019 13:48:28 -0500 Subject: [PATCH 026/142] Fixing a typo in untaus' description --- theories/Eq/UpToTaus.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 1884b357..d16a829a 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -43,7 +43,7 @@ Definition notauF {I} (t : itreeF E R I) : Prop := Notation notau t := (notauF (observe t)). -(* [untaus t' t] holds when [t = Tau (... Tau t' ...)]: +(* [untaus t t'] holds when [t = Tau (... Tau t' ...)]: [t] steps to [t'] by "peeling off" a finite number of [Tau]. "Peel off" means to remove only taus at the root of the tree, not any behind a [Vis] step). *) From e543b03ca657e426d6f2da59523508158f4ddbcc Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 19 Feb 2019 15:26:34 -0500 Subject: [PATCH 027/142] Finished fixing lemmas related to alist, Renv and sim_rel --- examples/Imp.v | 12 ++++- examples/Imp2Asm.v | 126 +++++++++++++++++++++++++-------------------- 2 files changed, 81 insertions(+), 57 deletions(-) diff --git a/examples/Imp.v b/examples/Imp.v index c0fa9793..17b831de 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -3,6 +3,7 @@ *) Require Import Coq.Lists.List. Require Import Coq.Strings.String. +Require Import ExtLib.Data.String. Require Import ExtLib.Structures.Monad. Require Import ExtLib.Structures.Traversable. Require Import ExtLib.Data.List. @@ -155,7 +156,16 @@ Definition env := alist var value. (* Enable typeclass instances for Maps keyed by strings and values *) Instance RelDec_string : RelDec (@eq string) := - { rel_dec := fun s1 s2 => if String.string_dec s1 s2 then true else false}. + { rel_dec := fun s1 s2 => if string_dec s1 s2 then true else false}. + +Instance RelDec_string_Correct: RelDec_Correct RelDec_string. +Proof. + constructor; intros x y. + split. + - unfold rel_dec; simpl. + destruct (string_dec x y) eqn:EQ; [intros _; apply string_dec_sound; assumption | intros abs; inversion abs]. + - intros EQ; apply string_dec_sound in EQ; unfold rel_dec; simpl; rewrite EQ; reflexivity. +Qed. Definition ImpEval (s: stmt): itree emptyE (env * unit) := let p := interp evalLocals _ (denoteStmt s) in diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 801c7eec..63ae0760 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -109,10 +109,6 @@ refine |}). Defined. - - - - Definition link_if (b : block bool) (p1 : program unit) (p2 : program unit) : program unit. refine @@ -496,14 +492,14 @@ Section Correctness. Definition Renv (g_asm g_imp : alist var value) : Prop := forall k_asm k_imp, Rvar k_asm k_imp -> - forall v, alist_In k_imp g_imp v -> alist_In k_asm g_asm v. + forall v, alist_In k_imp g_imp v <-> alist_In k_asm g_asm v. (* Let's not unfold this inside of the main proof *) Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := fun '(g_asm', _) '(g_imp',v) => - Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) - (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). End Correctness. @@ -528,13 +524,18 @@ End EUTT. Section GEN_TMP. - Lemma to_string_inj: forall (n m: nat), to_string n = to_string m -> n = m. + Lemma to_string_inj: forall (n m: nat), n <> m -> to_string n <> to_string m. Admitted. Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. Proof. intros n m ineq; intros abs; apply ineq. - apply to_string_inj; inversion abs; auto. + apply to_string_inj in ineq; inversion abs; easy. + Qed. + + Lemma varOf_inj: forall n m, m <> n -> varOf m <> varOf n. + Proof. + intros n m ineq abs; inv abs; easy. Qed. End GEN_TMP. @@ -715,23 +716,6 @@ Section Real_correctness. intros [EQ | abs]; [inv EQ; rewrite <- neg_rel_dec_correct in Heq; tauto | apply (H v); assumption]. Qed. - (* A key is stored at most once in the map *) - (* Oopsy daisy, though all alist operations preserve this invariant, its type does not state so *) - (* To avoid using if possible *) - (* Lemma alist_unique_key {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: *) - (* forall k (m: alist K V) v v', *) - (* In (k,v) m -> In (k,v') m -> v = v'. *) - (* Proof. *) - (* Admitted. *) - - (* alist_find succeeds iff the same value is associated to the key in the map *) - (* Same here, the value found is always the same only with respect to a global invariant over alist *) - (* Lemma alist_find_In_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: *) - (* forall k v (m: alist K V), *) - (* alist_In k m v <-> alist_find k m = Some v. *) - (* Proof. *) - (* Admitted. *) - Lemma Renv_add: forall g_asm g_imp n v, Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. Proof. @@ -739,7 +723,7 @@ Section Real_correctness. destruct (k_asm ?[ eq ] (gen_tmp n)) eqn:EQ. rewrite rel_dec_correct in EQ; subst; inv H0. rewrite <- neg_rel_dec_correct in EQ. - eapply H in H1; [| eassumption]. + rewrite (H _ _ H0). apply In_add_ineq_iff; auto. Qed. @@ -754,10 +738,9 @@ Section Real_correctness. rewrite LUL in LUR; auto. - eapply H in LUL; [| constructor]. rewrite LUL in LUR; auto. - - (* YZ: does not hold, the invariant does not prevent the assembly stack to have more non temp variables defined than the source. - Reinforce the invariant, or weaken this lemma. - *) - Admitted. + - erewrite <- (H (varOf x) x (Rvar_var x) v) in LUR. + rewrite LUR in LUL; inv LUL. + Qed. Lemma sim_rel_add: forall g_asm g_imp n v, Renv g_asm g_imp -> @@ -780,15 +763,30 @@ Section Real_correctness. Lemma sim_rel_find_tmp_n: forall g_asm n g_asm' g_imp' v, sim_rel g_asm n (g_asm', tt) (g_imp',v) -> - alist_find (gen_tmp n) g_asm' = Some v. - Admitted. + alist_In (gen_tmp n) g_asm' v. + Proof. + intros ? ? ? ? ? [_ [H _]]; exact H. + Qed. Lemma sim_rel_find_tmp_lt_n: forall g_asm n m g_asm' g_imp' v, m < n -> sim_rel g_asm n (g_asm', tt) (g_imp',v) -> alist_find (gen_tmp m) g_asm = alist_find (gen_tmp m) g_asm'. - Admitted. + Proof. + intros ? ? ? ? ? ? ineq [_ [_ H]]. + match goal with + | |- _ = ?x => destruct x eqn:EQ + end. + setoid_rewrite (H _ ineq); auto. + match goal with + | |- ?x = _ => destruct x eqn:EQ' + end; [| reflexivity]. + setoid_rewrite (H _ ineq) in EQ'. + rewrite EQ' in EQ; easy. + Qed. + + Notation "(% x )" := (gen_tmp x) (at level 1). Lemma compile_expr_correct : forall e g_imp g_asm n, Renv g_asm g_imp -> @@ -819,36 +817,52 @@ Section Real_correctness. intros [g_asm'' []] [g_imp'' v'] HSIM'. repeat untau_left. force_left; force_right. + simpl fst in *. apply eutt_Ret. - split; [| split]. - { - eapply Renv_add, sim_rel_Renv; eassumption. - } { - generalize HSIM'; intros HSIM'2; apply sim_rel_find_tmp_n in HSIM'. - setoid_rewrite HSIM'; clear HSIM'. - eapply sim_rel_find_tmp_lt_n with (m := n) in HSIM'2; [simpl fst in HSIM'2| auto with arith]. - apply sim_rel_find_tmp_n in HSIM; rewrite HSIM'2 in HSIM. - setoid_rewrite HSIM. - apply In_add_eq. + generalize HSIM; intros LU; apply sim_rel_find_tmp_n in LU. + unfold alist_In in LU; erewrite sim_rel_find_tmp_lt_n in LU; eauto; fold (alist_In (%n) g_asm'' v) in LU. + generalize HSIM'; intros LU'; apply sim_rel_find_tmp_n in LU'. + rewrite LU,LU'. + split; [| split]. + { + eapply Renv_add, sim_rel_Renv; eassumption. + } + { + apply In_add_eq. + } + { + intros m LT v''. + rewrite <- In_add_ineq_iff; [| apply gen_tmp_inj; lia]. + destruct HSIM as [_ [_ HSIM]]. + destruct HSIM' as [_ [_ HSIM']]. + rewrite HSIM; [| auto with arith]. + rewrite HSIM'; [| auto with arith]. + reflexivity. + } } - { - simpl fst in *. - intros m LT v''. - rewrite <- In_add_ineq_iff; [| apply gen_tmp_inj; lia]. - admit. - } - Admitted. + Qed. Lemma Renv_write_local: forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). Proof. - intros x a a0 v H0. - red in H0. red. - intros. - (* this should mostly come from ExtLib *) - Admitted. + intros k m m' v. + repeat intro. + red in H. + specialize (H k_asm k_imp H0 v0). + inv H0. + unfold alist_add, alist_In; simpl. + do 2 flatten_goal; + repeat match goal with + | h: _ = true |- _ => rewrite rel_dec_correct in h + | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h + end; try subst. + - tauto. + - tauto. + - apply varOf_inj in Heq; easy. + - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_string_Correct. +Qed. Lemma compile_assign_correct : forall e g_imp g_asm x, Renv g_asm g_imp -> From cdde3abbca486e73796501c6434d89a3d5f2e30c Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 19 Feb 2019 17:55:41 -0500 Subject: [PATCH 028/142] trying to build a theory of linking. --- examples/Imp2Asm.v | 263 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 261 insertions(+), 2 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 63ae0760..fc9fc338 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -146,8 +146,7 @@ refine | false => inl (inr None) end) b |}). - -Admitted. +Defined. Definition link_while (b : block bool) (p1 : program unit) : program unit. @@ -975,6 +974,27 @@ match x with end. Proof. destruct x; reflexivity. Qed. +Lemma translate_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> F) (Z : _ -> itree _ U) Y, + translate h _ match x with + | inl x => Z x + | inr x => Y x + end = +match x with +| inl x => translate h _ (Z x) +| inr x => translate h _ (Y x) +end. +Proof. destruct x; reflexivity. Qed. +Lemma translate_match_option : forall {B U} (x : option B) {E F} (h : E ~> F) (Z : itree _ U) Y, + translate h _ match x with + | None => Z + | Some x => Y x + end = +match x with +| None => translate h _ Z +| Some x => translate h _ (Y x) +end. +Proof. destruct x; reflexivity. Qed. + (* Proper (.. ==> eutt _) (rec _) @@ -1011,7 +1031,217 @@ Lemma link_ok : forall p1 p2 l, * bonus: break & continue *) +About rec. + +Variant Fused {d1 d2 c1 c2 : Type} : Type -> Type := +| Entry : Fused c2 +| EnterL (_ : d1) : Fused c1 +| EnterR (_ : d2) : Fused c2. +Arguments Fused : clear implicits. + +Lemma rec_fuse : forall {E : Type -> Type} {dom1 codom1 dom2 codom2 : Type} + (f : dom1 -> itree (callE dom1 codom1 +' E) codom1) + (g : dom2 -> itree (callE dom2 codom2 +' E) codom2) + (x : dom1) (y : codom1 -> dom2), + (l <- rec f x ;; + rec g (y l)) + ≈ + @mrec (Fused dom1 dom2 codom1 codom2) E + (fun _ elr => + match elr with + | Entry => l <- lift (EnterL x) ;; lift (EnterR (y l)) + | EnterL x => + translate (fun Z x => + match x with + | inl1 x => + match x in callE _ _ z return (Fused _ _ _ _ +' _) z with + | Call x => inl1 (EnterL x) + end + | inr1 x => inr1 x + end) _ (f x) + | EnterR x => + translate (fun Z x => + match x with + | inl1 x => + match x in callE _ _ z return (Fused _ _ _ _ +' _) z with + | Call x => inl1 (EnterR x) + end + | inr1 x => inr1 x + end) _ (g x) + end) _ Entry. +Proof. +Admitted. + +Variant Incl {d1 c1 T : Type} : Type -> Type := +| EnterI : Incl T +| EnterF (_ : d1) : Incl c1. +Arguments Incl : clear implicits. + + +Lemma rec_fuse' : forall {E : Type -> Type} {dom1 codom1 T : Type} + (f : dom1 -> itree (callE dom1 codom1 +' E) codom1) + (k : codom1 -> itree E T) + (x : dom1), + (l <- rec f x ;; k l) + ≈ + @mrec (Incl dom1 codom1 T) E + (fun _ elr => + match elr with + | EnterI => l <- ITree.liftE (inl1 (EnterF x)) ;; + translate (fun _ x => inr1 x) _ (k l) + | EnterF x => + translate (fun Z x => + match x with + | inl1 x => + match x in callE _ _ z return (Incl _ _ _ +' _) z with + | Call x => inl1 (EnterF x) + end + | inr1 x => inr1 x + end) _ (f x) + end) _ EnterI. +Proof. +Admitted. + (* 1. push translate over a match-option + * 2. pull a rec from a continuation above the bind + * 3. pull translate over a match-Incl + * 4. fuse two adjacent mrec + *) + +(* +Lemma rec_k : forall {E : Type -> Type} {dom1 codom1 T : Type} + (f : dom1 -> itree (callE dom1 codom1 +' E) codom1) + (c : itree E T) + (k : T -> dom1), + (l <- c ;; rec f (k l)) + ≈ + @mrec (Incl dom1 codom1 T) E + (fun _ elr => + match elr with + | EnterI => l <- translate (fun _ x => inr1 x) _ c ;; + ITree.liftE (inl1 (EnterF (k l))) + | EnterF x => + translate (fun Z x => + match x with + | inl1 x => + match x in callE _ _ z return (Incl _ _ _ +' _) z with + | Call x => inl1 (EnterF x) + end + | inr1 x => inr1 x + end) _ (f x) + end) _ EnterI. +Proof. +Admitted. +*) +About translate. +About mrec. + + +Lemma lem : forall {E : Type -> Type} {dom1 codom1 U : Type} + (f : dom1 -> itree (Incl dom1 codom1 U +' E) codom1) + (Z : itree (callE dom1 codom1 +' E) U) + (l : dom1) + , + @mrec (callE dom1 codom1) _ + (fun _ x => + match x with + | Call x => + interp (E:=Incl dom1 codom1 U +' E) (F:=callE dom1 codom1 +' E) + (fun _ z => + match z with + | inl1 x => + match x with + | EnterI => Z + | EnterF x => ITree.liftE (inl1 (Call x)) + end + | inr1 x => ITree.liftE (inr1 x) + end) (f x) + end) _ (Call l) + ≈ + @mrec (Incl dom1 codom1 U) _ + (fun _ x => + match x with + | EnterI => translate (fun _ x => + match x with + | inl1 x => + match x in callE _ _ X return (Incl dom1 codom1 U +' E) X with + | Call x => inl1 (EnterF x) + end + | inr1 x => inr1 x + end) _ Z + | EnterF x => f x + end) _ (EnterF l). +Abort. + +(* rec_fuse' : `l <- rec ... ;; k` = rec ... *) +(* rec_k : `l <- c ;; rec ...` = rec ... *) + +(* +rec_rec : @rec T (fun x => @rec U ...) = @rec (T + U) (fun ...) +*) + +Lemma lift_sum_rec : forall {A B C : Type} {E} + (L : A -> itree E C) + (R : B -> itree E C) + (l : A + B), + match l with + | inl x => L x + | inr x => R x + end = + rec (A:=A + B)%type + (fun x => + match x with + | inl x => translate (fun _ x => inr1 x) _ (L x) + | inr x => translate (fun _ x => inr1 x) _ (R x) + end) l. +Proof. Admitted. + +Variant With (T : Type) (E : Type -> Type) (t : Type) : Type := +| WithIt (_ : T) (_ : E t) : With T E t. +Arguments WithIt {_ _ _} _ _. + +Lemma lift_sum_rec_left + : forall {B T u : Type} {D : Type -> Type} {E} + (L : T -> D ~> itree (D +' E)) + (R : B -> itree E u) + (f : T -> D u) + (l : T + B), + match l with + | inl x => mrec (L x) _ (f x) + | inr x => R x + end = + mrec (D:=(With T D +' callE B u))%type + (fun _ x => + match x with + | inl1 (WithIt t y) => + translate (fun _ x => + match x with + | inl1 x => inl1 (inl1 (WithIt t x)) + | inr1 x => inr1 x + end) _ (L t _ y) + | inr1 x => + match x with + | Call x => translate (fun _ x => inr1 x) _ (R x) + end + end) _ match l with + | inl x => inl1 (WithIt x (f x)) + | inr x => inr1 (Call x) + end. +Proof. Admitted. + +Lemma Proper_match : forall {T U V : Type} R (f f' : T -> V) (g g' : U -> V) x, + ((pointwise_relation _ R) f f') -> + ((pointwise_relation _ R) g g') -> + R + match x with + | inl x => f x + | inr x => g x + end + match x with + | inl x => f' x + | inr x => g' x + end. +Proof. destruct x; compute; eauto. Qed. Lemma link_seq_ok : forall p1 p2 l, denote_program (link_seq p1 p2) l ≈ @@ -1027,6 +1257,35 @@ Lemma link_seq_ok : forall p1 p2 l, end. Proof. intros. + unfold denote_program. + rewrite Proper_match. + 2:{ red; intros. + eapply rec_fuse'. } + 2:{ red. intros. + instantiate (1:=fun a => match a with + | Some l0 => + rec + (fun lbl : label p2 => + next <- denote_block (blocks p2 lbl);; + match next with + | Some (inl next0) => lift (Call next0) + | Some (inr next0) => ret (Some next0) + | None => ret None + end) l0 + | None => denote_main p2 + end). + reflexivity. } + simpl. + rewrite lift_sum_rec_left with (f:=fun _ => EnterI). + SearchAbout rec. + rewrite lift_sum_rec. + + + destruct l. + { setoid_rewrite rec_fuse'. + simpl. + setoid_rewrite translate_match_option. + destruct l. { (* in the left *) unfold denote_program. From 50b6489424babf248677d5ae05960fa2f747383d Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Tue, 19 Feb 2019 22:05:40 -0500 Subject: [PATCH 029/142] some work on defining the category of handlers --- theories/Morphisms.v | 109 +++++++++++++++++++++++++++++++++++- theories/MorphismsFacts.v | 115 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 221 insertions(+), 3 deletions(-) diff --git a/theories/Morphisms.v b/theories/Morphisms.v index e6c552a7..425c8a36 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -39,6 +39,59 @@ From ITree Require Import Open Scope itree_scope. +(* + +(* ------------------------------------------------------------------------- *) + +A Monad Transformer MT is given by: + MT : (type -> type) -> (type -> type) + lift : `{Monad m} {a}, m a -> MT m a + +such that: + Monad (MT m) + + lift o return = return + lift o (bind t1 k) = + +EXAMPLE: + stateT S m a := S -> m (S * a) + lift : m `{Monad m} {a}, fun (c: m a) (s:S) => y <- c ;; ret (s, y) + +operations + get : m `{Monad m} stateT S m S := fun s => ret_m (s, s) + put : m `{Monad m}, S -> stateT S m unit := fun s' => fun s => ret_m (s', tt) + +(* category *) +id : A ~> MT (itree A) +compose : (B ~> MT2 (itree C)) ~> (A ~> MT1 (itree B)) -> (A ~> (MT2 o MT1) (itree C)) + +(* co-cartesian *) +par : (A ~> MT1 (itree B)) -> (C ~> MT2 (itree D)) -> (A + C ~> (MT1 ** MT2) (itree (B + D))) +both : (A ~> MT (itree B)) -> (C ~> (MT itree B)) -> (A + C ~> MT (itree B)) + +swap : (A ~> MT1 (itree B)) -> (C ~> MT2 (itree D)) -> (A + C ~> (MT2 ** MT1) (itree (D + B))) + + +left : A ~> MT (itree (A + B)) +right : B ~> MT (itree (A + B)) + +left : (A ~> MT (itree B)) -> (A ~> MT (itree (B + C))) +right : (C ~> MT (itree D)) -> (C ~> MT (itree (A + D))) + + + +(* ------------------------------------------------------------------------- *) +Algebraic effects handlers + +Definition sig (E:Type -> Type) m `{Monad m} := forall X, E X -> m x + + + + + +*) + + (** [itreeF] eliminator, where the codomain is in the [itree] monad, a building block for itree monad morphisms. *) Definition handleF {E F : Type -> Type} {I R : Type} @@ -93,6 +146,12 @@ Definition interp {E F : Type -> Type} (h : E ~> itree F) : (fun _ e k => Tau (ITree.bind (h _ e) (fun x => interp_ (k x)))) (observe t). + + + + + + (* N.B.: the guardedness of this definition relies on implementation details of [bind]. *) @@ -126,19 +185,63 @@ Definition translate {E F : Type -> Type} (h : E ~> F) : (** Effects [E, F : Type -> Type] and itree [E ~> itree F] form a category. *) -(* TODO: check that [itree] is a monad, so that category is its - Kleisli category. *) - (* todo(gmm): it would be good to have notation for this. * - if there was a "category" class like in Haskell, then we could * get composition from something like that. *) + +(* +(* category *) + +eh_id : A ~> itree A +eh_compose : (B ~> itree C) ~> (A ~> itree B) -> (A ~> itree C) + +eh_par : (A ~> itree B) -> (C ~> itree D) -> (A + C ~> itree (B + D)) +eh_swap : (A ~> itree B) (C ~> itree D) -> (A + C ~> itree (D + B)) + +(* co-products *) +eh_both : (A ~> itree B) -> (C ~> itree B) -> (A + C ~> itree B) +eh_left : A ~> itree (A + B) +eh_right : B ~> itree (A + B) + +*) + Definition eh_compose {A B C} (g : B ~> itree C) (f : A ~> itree B) : A ~> itree C := fun _ e => interp g _ (f _ e). Definition eh_id {A} : A ~> itree A := @ITree.liftE A. +Definition eh_par {A B C D} (f : A ~> itree B) (g : C ~> itree D) : (A +' C) ~> itree (B +' D) := + fun _ e => + match e with + | inl1 e1 => translate (@inl1 _ _) _ (f _ e1) + | inr1 e2 => translate (@inr1 _ _) _ (g _ e2) + end. + +Definition eh_swap {A B C D} (f : A ~> itree B) (g : C ~> itree D) : (A +' C) ~> itree (D +' B) := + fun _ e => + match e with + | inl1 e1 => translate (@inr1 _ _) _ (f _ e1) + | inr1 e2 => translate (@inl1 _ _) _ (g _ e2) + end. + + +Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) : (A +' C) ~> itree B := + fun _ e => + match e with + | inl1 e1 => f _ e1 + | inr1 e2 => g _ e2 + end. + +Definition eh_left {A B} : A ~> itree (A +' B) := + fun _ e => Vis (inl1 e) (fun x => Ret x). + +Definition eh_right {A B} : B ~> itree (A +' B) := + fun _ e => Vis (inr1 e) (fun x => Ret x). + +Definition eh_eq {A B : Type -> Type} := forall X, pointwise_relation (A X) (@eutt B X). + (** Standard interpreters *) Import ITree.Basics.Monads. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index ef23ed3e..f3285549 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -121,6 +121,15 @@ Proof. + intros. pupto2_final. eauto. Qed. +Lemma interp_ret : forall {E F R} x + (f : E ~> itree F), + (interp f R (Ret x)) ≅ Ret x. +Proof. + intros. rewrite (itree_eta (Ret x)). + rewrite unfold_interp. unfold interp_u. unfold handleF. + cbn. reflexivity. +Qed. + Lemma interp_bind {E F R S} (f : E ~> itree F) (t : itree E R) (k : R -> itree E S) : (interp f _ (ITree.bind t k)) ≅ (ITree.bind (interp f _ t) (fun r => interp f _ (k r))). @@ -403,3 +412,109 @@ Proof. specialize (CIH _ (k0 v) k s). auto. Qed. +Lemma interp_liftE {E F : Type -> Type} {R : Type} + (f : E ~> (itree F)) + (e : E R) : + interp f _ (ITree.liftE e) ≅ Tau (f _ e). +Proof. + unfold ITree.liftE. rewrite vis_interp. + apply itree_eq_tau. + assert (pointwise_relation _ eq_itree (fun x : R => interp f R (Ret x)) (fun x => Ret x)). + {red. intros. apply ret_interp. } + rewrite H. rewrite bind_ret. + reflexivity. +Qed. + +(* Morphism Category -------------------------------------------------------- *) + +Definition eh_eq {A B : Type -> Type} f g := forall X, pointwise_relation (A X) (@eutt B X) (f X) (g X). + +Notation "f ≡ g" := (eh_eq f g) (at level 70). + + +Lemma eh_compose_id_left_strong : + forall A R (t : itree A R), interp eh_id R t ≈ t. +Proof. + intros A R. + intros t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite unfold_interp. unfold interp_u. unfold handleF. + rewrite eutt_is_eutt'_gres. + pfold. revert t. pcofix CIH'. + intros t. + destruct (observe t); cbn. + - pfold. econstructor. + - pfold. econstructor. + right. rewrite interp_unfold. unfold interp_u. unfold handleF. + apply CIH'. + - pfold. econstructor. cbn. econstructor. intros. + assert (ITree.bind' (fun x0 : u => interp eh_id R (k x0)) (Ret x) = (x0 <- Ret x ;; interp eh_id R (k x0))). + { intros; reflexivity. } + rewrite H. rewrite ret_bind. + pupto2_final. right. apply CIH. +Qed. + + + +Lemma eh_compose_id_left : + forall A B (f : A ~> itree B), eh_compose eh_id f ≡ f. +Proof. + intros A B f X e. + unfold eh_compose. apply eh_compose_id_left_strong. +Qed. + + +Lemma eh_compose_id_right : + forall A B (f : A ~> itree B), eh_compose f eh_id ≡ f. +Proof. + intros B A f X e. + unfold eh_compose. + unfold eh_id. unfold ITree.liftE. + rewrite unfold_interp. unfold interp_u. + unfold handleF. + cbn. eapply transitivity. apply tau_eutt. + assert (pointwise_relation _ eq_itree (fun x : X => interp f X (Ret x)) (fun x => Ret x)). + { red. intros. apply interp_ret. } + rewrite H. rewrite bind_ret. + reflexivity. +Qed. + +Lemma eh_both_left_right_id : forall A B X e, eh_both eh_left eh_right X e = (@eh_id (A +' B)) X e. +Proof. + intros A B X e. + unfold eh_both. + unfold eh_id. unfold ITree.liftE. + destruct e. + - unfold eh_left. reflexivity. + - unfold eh_right. reflexivity. +Qed. + +Lemma eh_compose_assoc : forall A B C D (h : C ~> itree D) (g : B ~> itree C) (f : A ~> itree B), + eh_compose h (eh_compose g f) ≡ (eh_compose (eh_compose h g) f). +Proof. +(* + intros A B C D h g f X e. + pupto2_init. + revert h g f. + pcofix CIH. + intros h g f. + rewrite eutt_is_eutt'_gres. + unfold eh_compose. + rewrite unfold_interp. unfold interp_u. unfold handleF. + rewrite interp_unfold. unfold interp_u. unfold handleF. + rewrite (itree_eta (interp (fun (T : Type) (e0 : B T) => interp h T (g T e0)) X (f X e))). + rewrite interp_unfold. unfold interp_u. unfold handleF. + pfold. + revert h g f. + pcofix CIH'. + intros h g f. + destruct (observe (f X e)); cbn. + - pfold. econstructor. + - pfold. econstructor. right. repeat rewrite interp_unfold. + unfold interp_u. unfold handleF. apply CIH'. + econstructor. + *) +Admitted. \ No newline at end of file From 4d697081e003c7cba13eb70925db54a2de58a9bc Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 19 Feb 2019 13:15:51 -0500 Subject: [PATCH 030/142] Reorganize MorphismsFacts a bit --- theories/MorphismsFacts.v | 93 ++++++++++++++++++++++----------------- 1 file changed, 52 insertions(+), 41 deletions(-) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index c047094a..eeb5914e 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -15,6 +15,8 @@ From ITree Require Import Eq.Eq Eq.UpToTaus. +(** * [interp] *) + (* Proof of [interp f (t >>= k) ~ (interp f t >>= fun r => interp f (k r))] @@ -49,29 +51,7 @@ Lemma unfold_interp {E F R} {f : E ~> itree F} (t : itree E R) : interp f _ t ≅ interp_u f _ (observe t). Proof. rewrite itree_eta, interp_unfold, <-itree_eta. reflexivity. Qed. -(* SAZ: If we need to introduce these auxilliar definitions to prove - properties about functions like interp1, I think that we shoul - _define_ interp1 in terms of its unfolding. I have experimented - with porting interp_state and interp1_state to this form. -*) -(* Unfolding of [interp1]. *) -Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : - itreeF (E +' F) R _ -> itree G R := - handleF (interp1 h _) - (fun _ ef k => - match ef with - | inl1 e => Tau (ITree.bind (h _ e) - (fun x => interp1 h _ (k x))) - | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) - end). - -Lemma interp1_unfold {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : - observe (interp1 f _ t) = observe (interp1_u f _ (observe t)). -Proof. eauto. Qed. - -Lemma unfold_interp1 {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : - interp1 f _ t ≅ interp1_u f _ (observe t). -Proof. rewrite itree_eta, interp1_unfold, <-itree_eta. reflexivity. Qed. +(** ** [interp] and constructors *) Lemma ret_interp {E F R} {f : E ~> itree F} (x: R): interp f _ (Ret x) ≅ Ret x. @@ -85,6 +65,8 @@ Lemma vis_interp {E F R} {f : E ~> itree F} U (e: E U) (k: U -> itree E R) : interp f _ (Vis e k) ≅ Tau (ITree.bind (f _ e) (fun x => interp f _ (k x))). Proof. rewrite unfold_interp. reflexivity. Qed. +(** ** [interp] properness *) + Instance eq_itree_interp {E F R} (f : E ~> itree F) : Proper (eq_itree eq ==> eq_itree eq) (interp f R). Proof. @@ -101,24 +83,6 @@ Proof. + eauto. intros; pupto2_final; right; eauto. Qed. -Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : - Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). -Proof. - repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros. - rewrite !unfold_interp1. - punfold H0; red in H0. - destruct H0; pclearbot. - - pupto2_final. pfold. red. cbn. eauto. - - pupto2_final. pfold. red. cbn. eauto. - - pfold. destruct e; cbn; econstructor. - + pupto2 (eq_itree_clo_bind F R). - constructor. - * reflexivity. - * intros; pupto2_final; eauto. - + intros. pupto2_final. eauto. -Qed. - Lemma interp_bind {E F R S} (f : E ~> itree F) (t : itree E R) (k : R -> itree E S) : (interp f _ (ITree.bind t k)) ≅ (ITree.bind (interp f _ t) (fun r => interp f _ (k r))). @@ -137,6 +101,34 @@ Proof. + intros; specialize (CIH _ (k0 v) k); auto. Qed. +(** * [interp1] *) + +(* SAZ: If we need to introduce these auxilliar definitions to prove + properties about functions like interp1, I think that we shoul + _define_ interp1 in terms of its unfolding. I have experimented + with porting interp_state and interp1_state to this form. +*) +(* Unfolding of [interp1]. *) +Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : + itreeF (E +' F) R _ -> itree G R := + handleF (interp1 h _) + (fun _ ef k => + match ef with + | inl1 e => Tau (ITree.bind (h _ e) + (fun x => interp1 h _ (k x))) + | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) + end). + +Lemma interp1_unfold {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : + observe (interp1 f _ t) = observe (interp1_u f _ (observe t)). +Proof. eauto. Qed. + +Lemma unfold_interp1 {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : + interp1 f _ t ≅ interp1_u f _ (observe t). +Proof. rewrite itree_eta, interp1_unfold, <-itree_eta. reflexivity. Qed. + +(** ** [interp1] is equivalent to [interp] *) + Definition interp_match {E F} (f: E ~> itree F) : (E +' F) ~> itree F := fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis e (fun r => Ret r) end. @@ -186,6 +178,25 @@ Proof. eapply (CIH' (go x2) (go x3)); eauto. Qed. +Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +Proof. + repeat intro. pupto2_init. revert_until R. + pcofix CIH. intros. + rewrite !unfold_interp1. + punfold H0; red in H0. + destruct H0; pclearbot. + - pupto2_final. pfold. red. cbn. eauto. + - pupto2_final. pfold. red. cbn. eauto. + - pfold. destruct e; cbn; econstructor. + + pupto2 (eq_itree_clo_bind F R). + constructor. + * reflexivity. + * intros; pupto2_final; eauto. + + intros. pupto2_final. eauto. +Qed. + +(** * [interp_state] *) Lemma unfold_interp_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, observe (interp_state h _ t s) = From 95d1be4f8eb67a4a87fb51ae1aefb79e129b0b02 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 19 Feb 2019 13:54:09 -0500 Subject: [PATCH 031/142] Move around some eutt lemmas --- theories/Eq/UpToTaus.v | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index d16a829a..d9adc161 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -900,6 +900,19 @@ Proof. apply subrelation_eq_eutt, map_map. Qed. +Global Instance eutt_eq_under_rr {E : Type -> Type} + {R1 R2 : Type} (RR: R1 -> R2 -> Prop): + Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). +Admitted. + +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). +Admitted. + Definition observing {E R} (f : itree' E R -> itree' E R -> Prop) (x y : itree E R) := @@ -1089,16 +1102,3 @@ Proof. rewrite grespectful2_iff in H1; [|intros; erewrite eutt__is_eutt'_; reflexivity]. rewrite H, H0. eauto. Qed. - -Global Instance eutt_eq_under_rr {E : Type -> Type} - {R1 R2 : Type} (RR: R1 -> R2 -> Prop): - Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). -Admitted. - -(** Generalized heterogeneous version of [eutt_bind] *) -Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: - forall t1 t2, - eutt RR t1 t2 -> - forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> - @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). -Admitted. From 03a55bef6df2f677f0cd99189bec324742bec39d Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 19 Feb 2019 23:23:06 -0500 Subject: [PATCH 032/142] interp_interp --- theories/MorphismsFacts.v | 50 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index eeb5914e..e6161545 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -101,6 +101,56 @@ Proof. + intros; specialize (CIH _ (k0 v) k); auto. Qed. +(** ** Composition of [interp] *) + +Inductive interp_inv0 {E F R} + (ff : itree E ~> itree F) (gg : itree E ~> itree F) : + relation (itree F R) := +| interp_inv_main t : interp_inv0 ff gg (ff _ t) (gg _ t) +| interp_inv_bind u t (k: u -> _) : + interp_inv0 ff gg + (ITree.bind t (fun x => ff _ (k x))) + (ITree.bind t (fun x => gg _ (k x))) +. +Hint Constructors interp_inv0. + +Inductive iinv {E F R} (ff gg : itree E ~> itree F) (t1 t2 : itree F R) : Prop := +| iinv_intros t1' t2' : + t1 ≈ t1' -> + t2 ≈ t2' -> + interp_inv0 ff gg t1' t2' -> + iinv ff gg t1 t2 +. +Hint Constructors iinv. + +Polymorphic Definition II_MAIN_STEP {E F R} (ff gg : itree E ~> itree F) : + Prop := + forall (t : itree _ R), + euttF' (iinv ff gg) (fun x y => iinv ff gg (go x) (go y)) + (observe (ff _ t)) (observe (gg _ t)). + +Theorem interp_interp {E F G R} (f : E ~> itree F) (g : F ~> itree G) : + forall t : itree E R, + interp g _ (interp f _ t) + ≈ interp (fun _ e => interp g _ (f _ e)) _ t. +Proof. + intros. + assert (H : @II_MAIN_STEP _ _ R + (fun _ t => interp g _ (interp f _ t)) + (fun _ t => interp (fun _ e => interp g _ (f _ e)) _ t)). + { red; intros. repeat rewrite interp_unfold; cbn. + destruct (observe t0); cbn. + - constructor. + - constructor. econstructor; + try eapply interp_inv_main; + (rewrite <- itree_eta; reflexivity). + - constructor. econstructor; + try eapply interp_inv_bind; + (rewrite <- itree_eta; try reflexivity). + rewrite interp_bind; reflexivity. } + eapply eutt_is_eutt'. +Admitted. + (** * [interp1] *) (* SAZ: If we need to introduce these auxilliar definitions to prove From 129d03f2b6667eb4f80e7984405f33232db0ff5c Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 07:35:46 -0500 Subject: [PATCH 033/142] Add loop and some convenience functions for rec --- theories/Fix.v | 40 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/theories/Fix.v b/theories/Fix.v index 9e5641bc..6e4737bb 100644 --- a/theories/Fix.v +++ b/theories/Fix.v @@ -85,11 +85,43 @@ Inductive callE (A B : Type) : Type -> Type := Arguments Call {A B}. +(** Get the [A] contained in a [callE A B]. *) +Definition unCall {A B T} (e : callE A B T) : A := + match e with + | Call a => a + end. + +(** Lift a function on [A] to a morphism on [callE]. *) +Definition calling {A B} {F : Type -> Type} + (f : A -> F B) : callE A B ~> F := + fun _ e => + match e with + | Call a => f a + end. + +(* This is identical to [callWith] but [rec] finds a universe + inconsistency with [callWith], and not with [callWith']. *) +Definition calling' {A B} {F : Type -> Type} + (f : A -> itree F B) : callE A B ~> itree F := + fun _ e => + match e with + | Call a => f a + end. + (* Interpret a single recursive definition. *) Definition rec {E : Type -> Type} {A B : Type} (body : A -> itree (callE A B +' E) B) : A -> itree E B := - fun a => mrec (fun _ call => - match call in callE _ _ T return itree (_ +' E) T with - | Call a => body a - end) _ (Call a). + fun a => mrec (calling' body) _ (Call a). + +(* Iterate a function updating an accumulator [A], + until it produces an output [B]. *) +Definition loop {E : Type -> Type} {A B : Type} + (body : A -> itree E (A + B)) : + A -> itree E B := + rec (fun a => + ac <- translate (fun _ x => inr1 x) _ (body a) ;; + match ac with + | inl a => ITree.liftE (inl1 (Call a)) + | inr b => Ret b + end). From 404432880afe7211a3884191944d833d64be5631 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 07:41:30 -0500 Subject: [PATCH 034/142] Fix type of Sum1.bimap --- theories/Effect/Sum.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Effect/Sum.v b/theories/Effect/Sum.v index 3be1b0cd..c6c59151 100644 --- a/theories/Effect/Sum.v +++ b/theories/Effect/Sum.v @@ -39,7 +39,7 @@ Definition swap {A B : Type -> Type} : A +' B ~> B +' A := (** [Sum1.bimap] *) Definition bimap {A B C D : Type -> Type} - (f : A ~> B) (g : B ~> D) : A +' B ~> B +' D := + (f : A ~> B) (g : C ~> D) : A +' C ~> B +' D := fun _ ab => match ab with | inl1 a => inl1 (f _ a) From 4f6043c90325380c4a8fb99550d63d5739105bc5 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 08:01:32 -0500 Subject: [PATCH 035/142] Move rec_unfold to library, add loop_unfold, interp_liftE, interp_translate --- examples/Imp2Asm.v | 31 ------------------------------- theories/FixFacts.v | 38 ++++++++++++++++++++++++++++++++++++++ theories/MorphismsFacts.v | 36 +++++++++++++++++++++++++++++++++++- 3 files changed, 73 insertions(+), 32 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index fc9fc338..2043d511 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -911,37 +911,6 @@ Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} Require Import ITree.MorphismsFacts. Require Import ITree.FixFacts. - Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) - : rec f x ≈ interp (fun _ e => match e with - | inl1 e => - match e in callE _ _ t return _ with - | Call x => rec f x - end - | inr1 e => lift e - end) _ (f x). - Proof. - unfold rec. unfold mrec. - rewrite interp_mrec_is_interp. - repeat rewrite <- MorphismsFacts.interp_is_interp1. - unfold MorphismsFacts.interp_match. - unfold mrec. - SearchAbout interp Proper. - Definition Rhom {E F : Type -> Type} : relation (E ~> F) := - fun l r => - forall x (e : E x), l _ e = r _ e. - Lemma eq_itree_interp: - forall (E F : Type -> Type) (R : Type), - Proper (@Rhom E (itree F) ==> eutt eq ==> eutt eq) - (fun f => interp f R). - Proof. Admitted. - eapply eq_itree_interp. - { red. destruct e; try reflexivity. - destruct c. - reflexivity. } - reflexivity. - Qed. - - Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} (p : program L) : itree e (option L) := next <- denote_block e p.(main) ;; diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 5556a857..547d15e1 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -178,3 +178,41 @@ Proof. Qed. End Facts. + +Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : + rec f x ≈ interp (fun _ e => match e with + | inl1 e => calling' (rec f) _ e + | inr1 e => ITree.liftE e + end) _ (f x). +Proof. + unfold rec. unfold mrec. + rewrite interp_mrec_is_interp. + repeat rewrite <- interp_is_interp1. + unfold interp_match. + unfold mrec. + eapply eutt_interp. + { red. destruct e; try reflexivity. + destruct c. + reflexivity. } + reflexivity. +Qed. + +Lemma loop_unfold {E A B} (f : A -> itree E (A + B)) (x : A) : + loop f x ≈ (ab <- f x ;; + match ab with + | inl a => loop f a + | inr b => Ret b + end). +Proof. + unfold loop at 1. + rewrite rec_unfold. + rewrite interp_bind. + rewrite interp_translate. + rewrite interp_id_liftE. + eapply eutt_bind; [ reflexivity |]. + intros [a | b]. + - rewrite interp_liftE; cbn. + reflexivity. + - rewrite ret_interp. + reflexivity. +Qed. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index e6161545..8972cca6 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -83,6 +83,17 @@ Proof. + eauto. intros; pupto2_final; right; eauto. Qed. +Definition Rhom {E F : Type -> Type} : relation (E ~> F) := + fun l r => + forall x (e : E x), l _ e = r _ e. + +(* Note that this allows rewriting of handlers. *) +Instance eutt_interp : + forall (E F : Type -> Type) (R : Type), + Proper (@Rhom E (itree F) ==> eutt eq ==> eutt eq) + (fun f => interp f R). +Proof. Admitted. + Lemma interp_bind {E F R S} (f : E ~> itree F) (t : itree E R) (k : R -> itree E S) : (interp f _ (ITree.bind t k)) ≅ (ITree.bind (interp f _ t) (fun r => interp f _ (k r))). @@ -101,8 +112,25 @@ Proof. + intros; specialize (CIH _ (k0 v) k); auto. Qed. +Lemma interp_liftE {E F} (f : E ~> itree F) {R} (e : E R) : + interp f _ (ITree.liftE e) ≈ f _ e. +Proof. + rewrite itree_eta; cbn. + rewrite tau_eutt. + rewrite <- (bind_ret (f _ e)) at 2. + eapply eutt_bind; [reflexivity | ]. + intro r. + rewrite ret_interp. + reflexivity. +Qed. + (** ** Composition of [interp] *) +Lemma interp_id_liftE {E R} (t : itree E R) : + interp (fun _ e => ITree.liftE e) _ t ≈ t. +Proof. +Admitted. + Inductive interp_inv0 {E F R} (ff : itree E ~> itree F) (gg : itree E ~> itree F) : relation (itree F R) := @@ -459,5 +487,11 @@ Proof. * rewrite interp1_state_vis2, !vis_bind. rewrite itree_eta. rewrite unfold_interp1_state. cbn. pfold. constructor. intros. specialize (CIH _ (k0 v) k s). auto. -Qed. +Qed. +(* Commuting interpreters *) + +Lemma interp_translate {E F G} (f : E ~> F) (g : F ~> itree G) {R} (t : itree E R) : + interp g _ (translate f _ t) ≅ interp (fun _ e => g _ (f _ e)) _ t. +Proof. +Admitted. From 6974c7bcb0c2e55e485aac21b086685bddffcb6f Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Wed, 20 Feb 2019 09:24:53 -0500 Subject: [PATCH 036/142] some more work --- theories/Morphisms.v | 2 -- 1 file changed, 2 deletions(-) diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 425c8a36..5ac2a942 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -240,8 +240,6 @@ Definition eh_left {A B} : A ~> itree (A +' B) := Definition eh_right {A B} : B ~> itree (A +' B) := fun _ e => Vis (inr1 e) (fun x => Ret x). -Definition eh_eq {A B : Type -> Type} := forall X, pointwise_relation (A X) (@eutt B X). - (** Standard interpreters *) Import ITree.Basics.Monads. From 1053cd9b77c2e927021539b40f93cd0201b77a1e Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 09:33:26 -0500 Subject: [PATCH 037/142] State bind_loop --- theories/FixFacts.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 547d15e1..ec50817e 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -216,3 +216,18 @@ Proof. - rewrite ret_interp. reflexivity. Qed. + +Definition sum_map1 {A B C} (f : A -> B) (ac : A + C) : B + C := + match ac with + | inl a => inl (f a) + | inr c => inr c + end. + +Lemma bind_loop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) (x : A) : + (loop f x >>= loop g) + ≈ loop (fun ab => + match ab with + | inl a => ITree.map inl (f a) + | inr b => ITree.map (sum_map1 inr) (g b) + end) (inl x). +Admitted. From 0a8043faa983d94e0d43b0d6d78cebeba02e78db Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 09:34:15 -0500 Subject: [PATCH 038/142] Sketch denotational semantics of asm using loop --- examples/Imp2AsmBis.v | 129 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 129 insertions(+) create mode 100644 examples/Imp2AsmBis.v diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v new file mode 100644 index 00000000..e607066d --- /dev/null +++ b/examples/Imp2AsmBis.v @@ -0,0 +1,129 @@ +From ITree Require Import ITree. + +Require Import Program.Basics. (* ∘ *) + +(* Diagramatic/categorical sum combinators. *) + +Definition id {A} (x : A) : A := x. + +Definition sum_bimap {A B C D} (f : A -> B) (g : C -> D) + (ac : A + C) : B + D := + match ac with + | inl a => inl (f a) + | inr c => inr (g c) + end. + +Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := + match abc with + | inl (inl a) => inl a + | inl (inr b) => inr (inl b) + | inr c => inr (inr c) + end. + +Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C. +Admitted. + +Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C. +Admitted. + +Definition sum_merge {A} : A + A -> A := sum_elim id id. + +(* ASM definition *) + +(* Blocks are indexed by type of jump labels. *) +Axiom block : Type -> Type. +(* Collection of blocks labeled by [A], with jumps in [B]. *) +Definition bks A B := A -> block B. +Axiom E0 : Type -> Type. + +Axiom cat_b : forall {A B C D}, + (bks A B) -> + (bks C D) -> + (bks (A + C) (B + D)). + +Axiom rewire_b : forall {A B C D}, + (C -> A) -> + (B -> D) -> + (bks A B) -> + (bks C D). + +(* ASM: linked blocks, can jump to themselves *) +Record asm A B : Type := { + internal : Type; + code : bks (A + internal) ((A + internal) + B) +}. +Arguments internal {A B}. +Arguments code {A B}. + +(* Denotations as itrees *) +Definition den A B : Type := A -> itree E0 B. +(* den can represent both blocks (A -> block B) and asm (asm A B). *) + +Notation eq_den d1 d2 := (forall a, eutt eq (d1 a) (d2 a)). + +(* Denotation of [bks] *) +Axiom denote_b : forall {A B}, bks A B -> den A B. + +(* Denotation of [asm] *) +Definition denote_asm {A B} : asm A B -> den A B := + fun s a => loop (denote_b (code s)) (inl a). + +(* Denotation of [cat_b] *) +Definition cat_den : forall {A B C D}, + (den A B) -> + (den C D) -> + (den (A + C) (B + D)). +Admitted. + +(* Denotation of [rewire_b] *) +Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) + (ab : den A B) : den C D := + fun a => ITree.map g (ab (f a)). + +(* Correctness of [cat_b] and [rewire_b] (easy) *) + +Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : + eq_den (denote_b (cat_b ab cd)) (cat_den (denote_b ab) (denote_b cd)). +Admitted. + +Lemma rewire_correct {A B C D} (f : C -> A) (g : B -> D) (ab : bks A B) : + eq_den (denote_b (rewire_b f g ab)) (rewire_den f g (denote_b ab)). +Admitted. + +(* +(* Sequential composition of bks. *) +Definition seq_bks {A B C} (ab : bks A (A + B)) (bc : bks B (B + C)) : bks (A + B) ((A + B) + C) := + let rw : (A + B) + (B + C) -> (A + B) + C := + sum_bimap + (sum_bimap id sum_merge ∘ sum_assoc_r : (A + B) + B -> A + B) + (id : C -> C) ∘ sum_assoc_l in + rewire_b rw (cat_b ab bc). +*) + +Definition rw {A I B J C} : ((A + I) + B) + ((B + J) + C) -> + ((A + (I + (B + J))) + C). +Admitted. + +Definition corw {A I B J} : (A + (I + (B + J))) -> (A + I) + (B + J). +Admitted. + +(* Sequential composition of bks. *) +Definition seq_bks {A I B J C} + (ab : bks (A + I) ((A + I) + B)) + (bc : bks (B + J) ((B + J) + C)) : + bks (A + (I + (B + J))) ((A + (I + (B + J))) + C) := + rewire_b corw rw (cat_b ab bc). + +(* Sequential composition of asm. *) +Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := + {| code := seq_bks (code ab) (code bc) |}. + +(* Sequential composition of den. *) +Definition seq_den {A B C} (ab : den A B) (bc : den B C) : den A C := + fun a => ab a >>= bc. + +Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : + eq_den (denote_asm (seq_asm ab bc)) + (seq_den (denote_asm ab) (denote_asm bc)). +Admitted. +(* Use FixFacts.bind_loop to prove this *) From f1933de478f46858fe191e7d24c975ab943114d7 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Wed, 20 Feb 2019 12:56:59 -0500 Subject: [PATCH 039/142] fix compile problem --- theories/FixFacts.v | 1 + theories/MorphismsFacts.v | 26 ++++---------------------- 2 files changed, 5 insertions(+), 22 deletions(-) diff --git a/theories/FixFacts.v b/theories/FixFacts.v index ec50817e..d5934f14 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -212,6 +212,7 @@ Proof. eapply eutt_bind; [ reflexivity |]. intros [a | b]. - rewrite interp_liftE; cbn. + rewrite tau_eutt. reflexivity. - rewrite ret_interp. reflexivity. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index f534fe9e..d0bcd7ed 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -582,27 +582,9 @@ Qed. Lemma eh_compose_assoc : forall A B C D (h : C ~> itree D) (g : B ~> itree C) (f : A ~> itree B), eh_compose h (eh_compose g f) ≡ (eh_compose (eh_compose h g) f). Proof. -(* intros A B C D h g f X e. - pupto2_init. - revert h g f. - pcofix CIH. - intros h g f. - rewrite eutt_is_eutt'_gres. - unfold eh_compose. - rewrite unfold_interp. unfold interp_u. unfold handleF. - rewrite interp_unfold. unfold interp_u. unfold handleF. - rewrite (itree_eta (interp (fun (T : Type) (e0 : B T) => interp h T (g T e0)) X (f X e))). - rewrite interp_unfold. unfold interp_u. unfold handleF. - pfold. - revert h g f. - pcofix CIH'. - intros h g f. - destruct (observe (f X e)); cbn. - - pfold. econstructor. - - pfold. econstructor. right. repeat rewrite interp_unfold. - unfold interp_u. unfold handleF. apply CIH'. - econstructor. - *) -Admitted. + unfold eh_compose. rewrite interp_interp. reflexivity. +Qed. + + From 5ef7deb3ecdc8da633d09b7e4388d16ed9ded46b Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 13:07:01 -0500 Subject: [PATCH 040/142] More diagramatic reasoning --- examples/Imp2AsmBis.v | 221 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 202 insertions(+), 19 deletions(-) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index e607066d..82e3e728 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -1,17 +1,38 @@ -From ITree Require Import ITree. + +From Coq Require Import + Program + Lia + Setoid + Morphisms + RelationClasses. + + +From ITree Require Import ITree FixFacts. Require Import Program.Basics. (* ∘ *) + Set Nested Proofs Allowed. + (* Diagramatic/categorical sum combinators. *) Definition id {A} (x : A) : A := x. -Definition sum_bimap {A B C D} (f : A -> B) (g : C -> D) - (ac : A + C) : B + D := - match ac with - | inl a => inl (f a) - | inr c => inr (g c) - end. +Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := + fun x => + match x with + | inl a => f a + | inr b => g b + end. + +Definition sum_bimap {A B C D} (f : A -> B) (g : C -> D) : + A + C -> B + D := + sum_elim (inl ∘ f) (inr ∘ g). + +Definition sum_map_l {A B C} (f : A -> B) : A + C -> B + C := + sum_bimap f id. + +Definition sum_map_r {A B C} (f : A -> B) : C + A -> C + B := + sum_bimap id f. Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := match abc with @@ -20,10 +41,10 @@ Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := | inr c => inr (inr c) end. -Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C. -Admitted. +Definition sum_comm {A B} : A + B -> B + A := + sum_elim inr inl. -Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C. +Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C. Admitted. Definition sum_merge {A} : A + A -> A := sum_elim id id. @@ -59,27 +80,72 @@ Arguments code {A B}. Definition den A B : Type := A -> itree E0 B. (* den can represent both blocks (A -> block B) and asm (asm A B). *) -Notation eq_den d1 d2 := (forall a, eutt eq (d1 a) (d2 a)). +Notation eq_den_ d1 d2 := (forall a, eutt eq (d1 a) (d2 a)). + +Definition eq_den {E A B} (d1 d2 : A -> itree E B) := + (forall a, eutt eq (d1 a) (d2 a)). + +(* Sequential composition of den. *) +Definition seq_den {A B C} (ab : den A B) (bc : den B C) : den A C := + fun a => ab a >>= bc. + +Infix ">=>" := seq_den (at level 40). + +Definition id_den {A} : den A A := fun a => Ret a. + +Definition lift_den {A B} (f : A -> B) : den A B := fun a => Ret (f a). + +Definition den_sum_map_r {A B C} (ab : den A B) : den (C + A) (C + B) := + sum_elim (lift_den inl) (ab >=> lift_den inr). + +Definition den_sum_bimap {A B C D} (ab : den A B) (cd : den C D) : + den (A + C) (B + D) := + sum_elim (ab >=> lift_den inl) (cd >=> lift_den inr). (* Denotation of [bks] *) Axiom denote_b : forall {A B}, bks A B -> den A B. (* Denotation of [asm] *) Definition denote_asm {A B} : asm A B -> den A B := - fun s a => loop (denote_b (code s)) (inl a). + fun s => seq_den (lift_den inl) (loop (denote_b (code s))). + +(* A denotation of an asm program can be viewed as a circuit/diagram + where wires correspond to jumps/program links. + + A [box : den A (A + B)] is a circuit, drawn below as ###, + with one input wire labeled by A, and two output wires labeled + by A and B. + + The [loop : den A (A + B) -> den A B] combinator closes the + circuit, linking the box with itself by plugging the A output + back into the output. + + +-----+ + | ### | + A--+-###-+ + ###----B + ### + + *) (* Denotation of [cat_b] *) -Definition cat_den : forall {A B C D}, +Definition cat_den {A B C D} : (den A B) -> (den C D) -> - (den (A + C) (B + D)). -Admitted. + (den (A + C) (B + D)) := den_sum_bimap. (* Denotation of [rewire_b] *) Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) (ab : den A B) : den C D := fun a => ITree.map g (ab (f a)). +Lemma unfold_rewire_den {A B C D} (f : C -> A) (g : B -> D) + (ab : den A B) : + eq_den (rewire_den f g ab) + (lift_den f >=> ab >=> lift_den g). +Proof. +Admitted. + (* Correctness of [cat_b] and [rewire_b] (easy) *) Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : @@ -118,12 +184,129 @@ Definition seq_bks {A I B J C} Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := {| code := seq_bks (code ab) (code bc) |}. -(* Sequential composition of den. *) -Definition seq_den {A B C} (ab : den A B) (bc : den B C) : den A C := - fun a => ab a >>= bc. +(* Unused but should go to FixFacts *) +Instance eutt_loop {E A B} : + Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B). +Proof. +Admitted. + +Instance eutt_loop' {E A B} : + Proper (eq_den ==> eq_den) (@loop E A B). +Proof. +Admitted. + +Instance eutt_rewire_den {A B C D} : + Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq_den ==> eq_den) + (@rewire_den A B C D). +Proof. +Admitted. + +Instance eutt_seq_den {A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@seq_den A B C). +Proof. +Admitted. + +Instance Equivalence_eq_den {E A B} : Equivalence (@eq_den E A B). +Proof. +Admitted. + +Lemma seq_den_assoc {A B C D} + (ab : den A B) (bc : den B C) (cd : den C D) : + eq_den ((ab >=> bc) >=> cd) + (ab >=> (bc >=> cd)). +Proof. +Admitted. + +Lemma seq_loop_l {A B C} + (ab : den A (A + B)) (bc : den B C) : + eq_den (loop ab >=> bc) + (lift_den inl >=> loop (den_sum_bimap ab bc)). +Proof. +Admitted. + +Lemma seq_loop_l_seq {A B C} + (ab : den A (A + B)) (bc : den B C) : + eq_den (loop ab >=> bc) + (loop (ab >=> den_sum_map_r bc)). +Proof. +Admitted. + +(* +Lemma seq_loop_r {A B C} + (ab : den A B) (bc : den B (B + C)) : + eq_den (ab >=> loop bc) + (loop ( +*) + +Instance eutt_elim {E A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@sum_elim A B (itree E C)). +Proof. + repeat intro. destruct a; unfold sum_elim; auto. +Qed. + +(* + +loop_loop (f : A -> B) (box : den B (B + (A + C))): + +These two loops (where wires represent jumps): + + +------------+ + | +-----+ | + | | ### | | + | f-+-###-+B | + A--+-+ ###----+A + ###-------C + ### + +Can be rewired as: + + +---------+ + | ### | + +-+-###--+--+B + A----+f ###--+f <- A + ###------C + ### + +*) +Lemma loop_loop {A B C} + (f : A -> B) (bc : den B (B + (A + C))) : + eq_den (loop (lift_den f >=> loop bc)) + (lift_den f + >=> loop (bc >=> lift_den (sum_elim inl (sum_elim (inl ∘ f) inr)))). +Proof. +Admitted. + +Lemma sum_elim_loop {A B C BD} + (f : B -> BD) + (ac : den A C) (bc : den BD (BD + C)) : + eq_den (sum_elim ac + (lift_den f >=> loop bc)) + (lift_den (sum_map_r f) + >=> loop (sum_elim (ac >=> lift_den inr) + (bc >=> lift_den (sum_map_l inr)))). +Proof. +Admitted. Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_den (denote_asm (seq_asm ab bc)) (seq_den (denote_asm ab) (denote_asm bc)). +Proof. + unfold denote_asm, seq_asm; simpl. + unfold seq_bks. + rewrite rewire_correct. + rewrite cat_correct. + unfold cat_den. + rewrite unfold_rewire_den. + rewrite (seq_den_assoc (_ inl)). + rewrite seq_loop_l. + unfold den_sum_bimap. + rewrite (seq_den_assoc (_ inl)). + rewrite seq_loop_l_seq. + unfold den_sum_map_r. + rewrite sum_elim_loop. + rewrite loop_loop. + +Arguments loop : clear implicits. + +Qed. Admitted. -(* Use FixFacts.bind_loop to prove this *) From 16ba87af28e964825698ef5458e77c821730ccf7 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Wed, 20 Feb 2019 14:03:06 -0500 Subject: [PATCH 041/142] remove eh_swap and adding a few more sum1 morphisms --- theories/Effect/Sum.v | 25 +++++++++++++++++++++ theories/Morphisms.v | 8 ------- theories/MorphismsFacts.v | 46 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 71 insertions(+), 8 deletions(-) diff --git a/theories/Effect/Sum.v b/theories/Effect/Sum.v index c6c59151..5f34d616 100644 --- a/theories/Effect/Sum.v +++ b/theories/Effect/Sum.v @@ -29,6 +29,16 @@ Module Sum1. (* Just for this section, [A B C D : Type -> Type] are more effect types. *) +Definition elim_emptyE {A} : emptyE ~> A := + fun X (e : emptyE X) => match e with end. + +Definition idE {A : Type -> Type} : A ~> A := + fun X (e : A X) => e. + +Definition cmpE {A B C : Type -> Type} : (B ~> C) -> (A ~> B) -> (A ~> C) := + fun g f X a => g X (f X a). + + (** [Sum1.swap] *) Definition swap {A B : Type -> Type} : A +' B ~> B +' A := fun _ ab => @@ -54,4 +64,19 @@ Definition elim {A B C : Type -> Type} | inr1 b => g _ b end. +(** [Sum1.assoc] *) +Definition assoc {A B C : Type -> Type} : A +' (B +' C) ~> (A +' B) +' C := + fun _ abc => + match abc with + | inl1 a => inl1 (inl1 a) + | inr1 (inl1 b) => inl1 (inr1 b) + | inr1 (inr1 c) => inr1 c + end. + +Definition emptyE_left {A : Type -> Type} : emptyE +' A ~> A := + elim elim_emptyE idE. + +Definition emptyE_right {A : Type -> Type} : A +' emptyE ~> A := + elim idE elim_emptyE. + End Sum1. diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 7102b982..151c59bf 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -205,14 +205,6 @@ Definition eh_par {A B C D} (f : A ~> itree B) (g : C ~> itree D) : (A +' C) ~> | inr1 e2 => translate (@inr1 _ _) _ (g _ e2) end. -Definition eh_swap {A B C D} (f : A ~> itree B) (g : C ~> itree D) : (A +' C) ~> itree (D +' B) := - fun _ e => - match e with - | inl1 e1 => translate (@inr1 _ _) _ (f _ e1) - | inr1 e2 => translate (@inl1 _ _) _ (g _ e2) - end. - - Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) : (A +' C) ~> itree B := fun _ e => match e with diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index d0bcd7ed..95600e52 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -510,9 +510,37 @@ Proof. Admitted. +(* Translate facts ---------------------------------------------------------- *) + +Instance translate_Proper : forall {A B R} (h : A ~> B), Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h _). +Proof. +Admitted. + +Lemma translate_ret : forall {A B R} (h : A ~> B) (r:R), + translate h _ (Ret r) ≅ Ret r. +Proof. + intros A B R h r. + rewrite itree_eta. + cbn. reflexivity. +Qed. +Lemma translate_tau : forall {A B R} (h : A ~> B) (t: itree A R), + translate h _ (Tau t) ≅ Tau (translate h _ t). +Proof. + intros A B R h t. + rewrite itree_eta. + cbn. reflexivity. +Qed. +Lemma translate_vis : forall {A B R} (h : A ~> B) X (e : A X) (k: X -> itree A R), + translate h _ (Vis e k) ≅ Vis (h _ e) (fun x => translate h _ (k x)). +Proof. + intros A B R h X e k. + rewrite itree_eta. + cbn. reflexivity. +Qed. + (* Morphism Category -------------------------------------------------------- *) Definition eh_eq {A B : Type -> Type} f g := forall X, pointwise_relation (A X) (@eutt B X _ (@eq X)) (f X) (g X). @@ -586,5 +614,23 @@ Proof. unfold eh_compose. rewrite interp_interp. reflexivity. Qed. +Lemma eh_par_id : forall A B, eh_par eh_id eh_id ≡ (@eh_id (A +' B)). +Proof. + intros A B X e. + unfold eh_par. + unfold eh_id. + destruct e. + - unfold ITree.liftE. + rewrite translate_vis. + assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inl1 (E2:=B)) X (Ret x)) (fun x : X => Ret x)). + { intros x. rewrite translate_ret. reflexivity. } + rewrite H. reflexivity. + - unfold ITree.liftE. + rewrite translate_vis. + assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inr1 (E2:=B)) X (Ret x)) (fun x : X => Ret x)). + { intros x. rewrite translate_ret. reflexivity. } + rewrite H. reflexivity. +Qed. + From 823b7be1c653ad8d94ca606c9428cc6bfca3457b Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 14:49:55 -0500 Subject: [PATCH 042/142] finish proof of seq_correct --- examples/Imp2AsmBis.v | 180 +++++++++++++++++++++++++++++++++++++++--- 1 file changed, 170 insertions(+), 10 deletions(-) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index 82e3e728..cac64212 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -44,8 +44,13 @@ Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := Definition sum_comm {A B} : A + B -> B + A := sum_elim inr inl. -Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C. -Admitted. +Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := + match abc with + | inl a => inl (inl a) + | inr (inl b) => inl (inr b) + | inr (inr c) => inr c + end. + Definition sum_merge {A} : A + A -> A := sum_elim id id. @@ -166,12 +171,31 @@ Definition seq_bks {A B C} (ab : bks A (A + B)) (bc : bks B (B + C)) : bks (A + rewire_b rw (cat_b ab bc). *) +Class ReSum (A B : Type) := + resum : A -> B. + +Instance ReSum_id A : ReSum A A := id. +Instance ReSum_sum A B C `{ReSum A C} `{ReSum B C} : ReSum (A + B) C := + sum_elim resum resum. +Instance ReSum_inl A B C `{ReSum A B} : ReSum A (B + C) := + inl ∘ resum. +Instance ReSum_inr A B C `{ReSum A B} : ReSum A (C + B) := + inr ∘ resum. + +Opaque compose. +Opaque id. +Opaque sum_elim. + Definition rw {A I B J C} : ((A + I) + B) + ((B + J) + C) -> - ((A + (I + (B + J))) + C). -Admitted. + ((A + (I + (B + J))) + C) := + Eval compute in resum. -Definition corw {A I B J} : (A + (I + (B + J))) -> (A + I) + (B + J). -Admitted. +Transparent compose. +Transparent id. +Transparent sum_elim. + +Definition corw {A I B J} : (A + (I + (B + J))) -> (A + I) + (B + J) := + sum_assoc_l. (* Sequential composition of bks. *) Definition seq_bks {A I B J C} @@ -287,6 +311,118 @@ Lemma sum_elim_loop {A B C BD} Proof. Admitted. +Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := + { iso_ff' : forall a, f' (f a) = a; + iso_f'f : forall b, f (f' b) = b; + }. + +Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. +Proof. + - destruct 0 as [| []]; auto. + - destruct 0 as [[] |]; auto. +Qed. + +Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. +Proof. + - destruct 0 as [[] |]; auto. + - destruct 0 as [| []]; auto. +Qed. + +Lemma loop_relabel {A B C} + (f : A -> B) {f' : B -> A} + {ISO_f : Iso f f'} + (ac : den A (A + C)) : + eq_den (loop ac) + (lift_den f >=> loop (lift_den f' >=> ac >=> lift_den (sum_map_l f))). +Proof. +Admitted. + +Lemma seq_lift_den {A B C} (ab : A -> B) (bc : B -> C) : + eq_den (lift_den ab >=> lift_den bc) + (lift_den (bc ∘ ab)). +Proof. +Admitted. + +Lemma compose_id_l {A B} (f : A -> B) : id ∘ f = f. +Proof. reflexivity. Qed. + +Lemma compose_id_r {A B} (f : A -> B) : f ∘ id = f. +Proof. reflexivity. Qed. + +Definition eqeq {A B} := (@eq A ==> @eq B)%signature. + +Instance Equivalence_eqeq {A B} : Equivalence (@eqeq A B). +Proof. + constructor; cbv; intros; subst; auto. + - symmetry; auto. + - etransitivity; auto. +Qed. + +Instance eq_lift_den {A B} : + Proper (eqeq ==> eq_den) (@lift_den A B). +Proof. +Admitted. + +Lemma seq_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : + eq_den (sum_elim ac bc >=> cd) + (sum_elim (ac >=> cd) (bc >=> cd)). +Proof. +Admitted. + +Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : + eqeq (cd ∘ sum_elim ac bc) + (sum_elim (cd ∘ ac) (cd ∘ bc)). +Proof. + intros [] ? []; auto. +Qed. + +Instance eq_compose {A B C} : + Proper (eqeq ==> eqeq ==> eqeq) + (@compose A B C). +Proof. cbv; auto. Qed. + +Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inl = f. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inr = g. +Proof. reflexivity. Qed. + +Lemma sum_elim_inl' {A B C D} (f : A -> C) (g : B -> C) (h : D -> A) : + sum_elim f g ∘ (inl ∘ h) = f ∘ h. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr' {A B C D} (f : A -> C) (g : B -> C) (h : D -> B) : + sum_elim f g ∘ (inr ∘ h) = g ∘ h. +Proof. reflexivity. Qed. + +Lemma unfold_sum_assoc_r {A B C} : + @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). +Proof. cbv; auto. Qed. + +Opaque eutt. + +Lemma lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : + eq_den (sum_elim (lift_den ac) (lift_den bc)) + (lift_den (sum_elim ac bc)). +Proof. intros []; reflexivity. Qed. + +Instance eqeq_sum_elim {A B C} : + Proper (eqeq ==> eqeq ==> eqeq) (@sum_elim A B C). +Proof. cbv; intros; subst; destruct _; auto. Qed. + +Hint Rewrite @compose_id_l : cat. +Hint Rewrite @compose_id_r : cat. + +Hint Rewrite @sum_elim_inl : sum_elim. +Hint Rewrite @sum_elim_inr : sum_elim. +Hint Rewrite @sum_elim_inl' : sum_elim. +Hint Rewrite @sum_elim_inr' : sum_elim. + +Hint Rewrite @lift_sum_elim : lift_den. +Hint Rewrite @seq_lift_den : lift_den. + Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_den (denote_asm (seq_asm ab bc)) (seq_den (denote_asm ab) (denote_asm bc)). @@ -305,8 +441,32 @@ Proof. unfold den_sum_map_r. rewrite sum_elim_loop. rewrite loop_loop. - -Arguments loop : clear implicits. - + rewrite (loop_relabel sum_assoc_r). + repeat (rewrite seq_lift_den + rewrite <- (seq_den_assoc (lift_den _) (lift_den _))). + apply eutt_seq_den. + { apply eq_lift_den. + cbv; congruence. } + apply eutt_loop'. + unfold corw. + repeat rewrite seq_den_assoc + rewrite seq_lift_den. + eapply eutt_seq_den. + { reflexivity. } + repeat rewrite seq_sum_elim. + repeat rewrite seq_den_assoc + rewrite seq_lift_den. + unfold sum_map_r, sum_map_l, sum_bimap. + rewrite unfold_sum_assoc_r. + unfold rw. + autorewrite with cat. + repeat rewrite compose_assoc. + autorewrite with sum_elim. + autorewrite with lift_den. + eapply eutt_elim. + - eapply eutt_seq_den. + + reflexivity. + + eapply eq_lift_den. + intros a ? []. destruct a as [[] | ]; auto. + - eapply eutt_seq_den. + + reflexivity. + + eapply eq_lift_den. + intros a ? []; destruct a as [[] | ]; auto. Qed. -Admitted. From e8bf2cc530a87e2424acdb67d41ff41dd699d065 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 15:12:38 -0500 Subject: [PATCH 043/142] Reorganize Imp2AsmBis --- examples/Imp2AsmBis.v | 214 ++++++++++++++++++++++-------------------- 1 file changed, 114 insertions(+), 100 deletions(-) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index cac64212..b1128201 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -13,9 +13,35 @@ Require Import Program.Basics. (* ∘ *) Set Nested Proofs Allowed. -(* Diagramatic/categorical sum combinators. *) +(** * The Category of Functions *) -Definition id {A} (x : A) : A := x. +(* id : A -> A + compose : (B -> C) -> (A -> B) -> (A -> C) + Infix "∘" = compose + + compose_id_right : f ∘ id = f + compose_id_left : id ∘ f = f + compose_assoc : (f ∘ g) ∘ h = f ∘ (g ∘ h) + *) + +Hint Rewrite @compose_id_left : cat. +Hint Rewrite @compose_id_right : cat. + +(** Extensional function equality *) +Definition eqeq {A B} := (@eq A ==> @eq B)%signature. + +Instance Equivalence_eqeq {A B} : Equivalence (@eqeq A B). +Proof. + constructor; cbv; intros; subst; auto. + - symmetry; auto. + - etransitivity; auto. +Qed. + +Instance eq_compose {A B C} : + Proper (eqeq ==> eqeq ==> eqeq) (@compose A B C). +Proof. cbv; auto. Qed. + +(** * Diagramatic/categorical sum combinators. *) Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := fun x => @@ -51,9 +77,94 @@ Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := | inr (inr c) => inr c end. - Definition sum_merge {A} : A + A -> A := sum_elim id id. +(** ** Equational theory *) + +Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : + eqeq (cd ∘ sum_elim ac bc) + (sum_elim (cd ∘ ac) (cd ∘ bc)). +Proof. + intros [] ? []; auto. +Qed. + +Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inl = f. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inr = g. +Proof. reflexivity. Qed. + +Lemma sum_elim_inl' {A B C D} (f : A -> C) (g : B -> C) (h : D -> A) : + sum_elim f g ∘ (inl ∘ h) = f ∘ h. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr' {A B C D} (f : A -> C) (g : B -> C) (h : D -> B) : + sum_elim f g ∘ (inr ∘ h) = g ∘ h. +Proof. reflexivity. Qed. + +Lemma unfold_sum_assoc_r {A B C} : + @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). +Proof. cbv; auto. Qed. + +Instance eqeq_sum_elim {A B C} : + Proper (eqeq ==> eqeq ==> eqeq) (@sum_elim A B C). +Proof. cbv; intros; subst; destruct _; auto. Qed. + +Hint Rewrite @sum_elim_inl : sum_elim. +Hint Rewrite @sum_elim_inr : sum_elim. +Hint Rewrite @sum_elim_inl' : sum_elim. +Hint Rewrite @sum_elim_inr' : sum_elim. + +(** ** Automatic solver of reassociating sums *) + +Class ReSum (A B : Type) := + resum : A -> B. + +Instance ReSum_id A : ReSum A A := id. +Instance ReSum_sum A B C `{ReSum A C} `{ReSum B C} : ReSum (A + B) C := + sum_elim resum resum. +Instance ReSum_inl A B C `{ReSum A B} : ReSum A (B + C) := + inl ∘ resum. +Instance ReSum_inr A B C `{ReSum A B} : ReSum A (C + B) := + inr ∘ resum. + +(* Usage template: + +[[ +Opaque compose. +Opaque id. +Opaque sum_elim. + +Definition f {X Y Z} : complex_sum -> another_complex_sum := + Eval compute in resum. + +Transparent compose. +Transparent id. +Transparent sum_elim. +]] +*) + +(** * Bijections *) + +Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := + { iso_ff' : forall a, f' (f a) = a; + iso_f'f : forall b, f (f' b) = b; + }. + +Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. +Proof. + - destruct 0 as [| []]; auto. + - destruct 0 as [[] |]; auto. +Qed. + +Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. +Proof. + - destruct 0 as [[] |]; auto. + - destruct 0 as [| []]; auto. +Qed. + (* ASM definition *) (* Blocks are indexed by type of jump labels. *) @@ -161,27 +272,6 @@ Lemma rewire_correct {A B C D} (f : C -> A) (g : B -> D) (ab : bks A B) : eq_den (denote_b (rewire_b f g ab)) (rewire_den f g (denote_b ab)). Admitted. -(* -(* Sequential composition of bks. *) -Definition seq_bks {A B C} (ab : bks A (A + B)) (bc : bks B (B + C)) : bks (A + B) ((A + B) + C) := - let rw : (A + B) + (B + C) -> (A + B) + C := - sum_bimap - (sum_bimap id sum_merge ∘ sum_assoc_r : (A + B) + B -> A + B) - (id : C -> C) ∘ sum_assoc_l in - rewire_b rw (cat_b ab bc). -*) - -Class ReSum (A B : Type) := - resum : A -> B. - -Instance ReSum_id A : ReSum A A := id. -Instance ReSum_sum A B C `{ReSum A C} `{ReSum B C} : ReSum (A + B) C := - sum_elim resum resum. -Instance ReSum_inl A B C `{ReSum A B} : ReSum A (B + C) := - inl ∘ resum. -Instance ReSum_inr A B C `{ReSum A B} : ReSum A (C + B) := - inr ∘ resum. - Opaque compose. Opaque id. Opaque sum_elim. @@ -311,23 +401,6 @@ Lemma sum_elim_loop {A B C BD} Proof. Admitted. -Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := - { iso_ff' : forall a, f' (f a) = a; - iso_f'f : forall b, f (f' b) = b; - }. - -Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. -Proof. - - destruct 0 as [| []]; auto. - - destruct 0 as [[] |]; auto. -Qed. - -Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. -Proof. - - destruct 0 as [[] |]; auto. - - destruct 0 as [| []]; auto. -Qed. - Lemma loop_relabel {A B C} (f : A -> B) {f' : B -> A} {ISO_f : Iso f f'} @@ -343,21 +416,6 @@ Lemma seq_lift_den {A B C} (ab : A -> B) (bc : B -> C) : Proof. Admitted. -Lemma compose_id_l {A B} (f : A -> B) : id ∘ f = f. -Proof. reflexivity. Qed. - -Lemma compose_id_r {A B} (f : A -> B) : f ∘ id = f. -Proof. reflexivity. Qed. - -Definition eqeq {A B} := (@eq A ==> @eq B)%signature. - -Instance Equivalence_eqeq {A B} : Equivalence (@eqeq A B). -Proof. - constructor; cbv; intros; subst; auto. - - symmetry; auto. - - etransitivity; auto. -Qed. - Instance eq_lift_den {A B} : Proper (eqeq ==> eq_den) (@lift_den A B). Proof. @@ -369,38 +427,6 @@ Lemma seq_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : Proof. Admitted. -Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : - eqeq (cd ∘ sum_elim ac bc) - (sum_elim (cd ∘ ac) (cd ∘ bc)). -Proof. - intros [] ? []; auto. -Qed. - -Instance eq_compose {A B C} : - Proper (eqeq ==> eqeq ==> eqeq) - (@compose A B C). -Proof. cbv; auto. Qed. - -Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : - sum_elim f g ∘ inl = f. -Proof. reflexivity. Qed. - -Lemma sum_elim_inr {A B C} (f : A -> C) (g : B -> C) : - sum_elim f g ∘ inr = g. -Proof. reflexivity. Qed. - -Lemma sum_elim_inl' {A B C D} (f : A -> C) (g : B -> C) (h : D -> A) : - sum_elim f g ∘ (inl ∘ h) = f ∘ h. -Proof. reflexivity. Qed. - -Lemma sum_elim_inr' {A B C D} (f : A -> C) (g : B -> C) (h : D -> B) : - sum_elim f g ∘ (inr ∘ h) = g ∘ h. -Proof. reflexivity. Qed. - -Lemma unfold_sum_assoc_r {A B C} : - @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). -Proof. cbv; auto. Qed. - Opaque eutt. Lemma lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : @@ -408,18 +434,6 @@ Lemma lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : (lift_den (sum_elim ac bc)). Proof. intros []; reflexivity. Qed. -Instance eqeq_sum_elim {A B C} : - Proper (eqeq ==> eqeq ==> eqeq) (@sum_elim A B C). -Proof. cbv; intros; subst; destruct _; auto. Qed. - -Hint Rewrite @compose_id_l : cat. -Hint Rewrite @compose_id_r : cat. - -Hint Rewrite @sum_elim_inl : sum_elim. -Hint Rewrite @sum_elim_inr : sum_elim. -Hint Rewrite @sum_elim_inl' : sum_elim. -Hint Rewrite @sum_elim_inr' : sum_elim. - Hint Rewrite @lift_sum_elim : lift_den. Hint Rewrite @seq_lift_den : lift_den. From 007ce5afec568d856439add0dc69359918f7994c Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 20 Feb 2019 18:57:04 -0500 Subject: [PATCH 044/142] Implementing Asm to fit with ImpToAsmBis --- examples/Asm.v | 293 +++++++++++++++++++++++++----------------- examples/Imp2AsmBis.v | 223 ++++++-------------------------- examples/sum.v | 158 +++++++++++++++++++++++ 3 files changed, 371 insertions(+), 303 deletions(-) create mode 100644 examples/sum.v diff --git a/examples/Asm.v b/examples/Asm.v index 5a0f34d1..3c991509 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -2,143 +2,175 @@ Require Import Coq.Strings.String. Require Import ZArith. Typeclasses eauto := 5. -Definition var : Set := string. -Definition value : Set := nat. (* this should change *) - -(* start with the syntax *) - -Variant operand : Set := -| Oimm (_ : value) -| Ovar (_ : var). - -Variant instr : Set := -| Imov (dest : var) (src : operand) -| Iadd (dest : var) (src : var) (o : operand) -| Iload (dest : var) (addr : operand) -| Istore (addr : var) (val : operand). - -Variant branch {label : Type} : Type := -| Bjmp (_ : label) (* jump to label *) -| Bbrz (_ : var) (yes no : label) (* conditional jump *) -| Bhalt -. -Arguments branch _ : clear implicits. - -Inductive block {label : Type} : Type := -| bbi (_ : instr) (_ : block) -| bbb (_ : branch label). -Arguments block _ : clear implicits. - -Record program {imports : Type} : Type := - { label : Type (* Internal labels *) - ; main : block (label + imports) (* Entry point *) - ; blocks : label -> block (label + imports) (* Other blocks *) - }. -Arguments program _ : clear implicits. +Section Syntax. -Module AsmNotations. + Definition var : Set := string. + Definition value : Set := nat. (* this should change *) - (* TODO *) - Notation "▿ i0 ; .. ; i ; br △" := - (bbi i0 .. (bbi i (bbb br)) ..) - (right associativity). + (* start with the syntax *) - Open Scope string_scope. - Definition bar := Imov "x" (Ovar "x"). - Definition foo {label: Type}: @block label := - ▿ bar ; bar ; bar ; Bhalt △. + Variant operand : Set := + | Oimm (_ : value) + | Ovar (_ : var). -End AsmNotations. + Variant instr : Set := + | Imov (dest : var) (src : operand) + | Iadd (dest : var) (src : var) (o : operand) + | Iload (dest : var) (addr : operand) + | Istore (addr : var) (val : operand). + + Variant branch {label : Type} : Type := + | Bjmp (_ : label) (* jump to label *) + | Bbrz (_ : var) (yes no : label) (* conditional jump *) + | Bhalt + . + Arguments branch _ : clear implicits. + + Inductive block {label : Type} : Type := + | bbi (_ : instr) (_ : block) + | bbb (_ : branch label). + Arguments block _ : clear implicits. + + Definition fmap_branch {A B : Type} (f: A -> B): branch A -> branch B := + fun b => + match b with + | Bjmp a => Bjmp (f a) + | Bbrz c a a' => Bbrz c (f a) (f a') + | Bhalt => Bhalt + end. -(* now define a semantics *) + Definition fmap_block {A B: Type} (f: A -> B): block A -> block B := + fix fmap b := + match b with + | bbb a => bbb (fmap_branch f a) + | bbi i b => bbi i (fmap b) + end. + + (* Collection of blocks labeled by [A], with jumps in [B]. *) + Definition bks A B := A -> block B. + + (* ASM: linked blocks, can jump to themselves *) + Record asm A B : Type := { + internal : Type; + code : bks (A + internal) ((A + internal) + B) + }. + +End Syntax. + +Arguments internal {A B}. +Arguments code {A B}. From ITree Require Import ITree OpenSum Fix. +Require Import sum. -Require Import ExtLib.Structures.Monad. -Import MonadNotation. -Local Open Scope monad_scope. +Section Semantics. + (* now define a semantics *) -Require Import Imp. + (* Denotations as itrees *) + Definition den {E: Type -> Type} A B : Type := A -> itree E B. + (* den can represent both blocks (A -> block B) and asm (asm A B). *) -Inductive Memory : Type -> Type := -| Load (addr : value) : Memory value -| Store (addr val : value) : Memory unit. + Section den_combinators. -Section with_effect. - Variable e : Type -> Type. - Context {HasLocals : Locals -< e}. - Context {HasMemory : Memory -< e}. + Context {E: Type -> Type }. - Definition denote_operand (o : operand) : itree e value := - match o with - | Oimm v => Ret v - | Ovar v => lift (GetVar v) - end. + (* Sequential composition of den. *) + Definition seq_den {A B C} (ab : den A B) (bc : den B C) : @den E A C := + fun a => ab a >>= bc. - Definition denote_instr (i : instr) : itree e unit := - match i with - | Imov d s => - v <- denote_operand s ;; - lift (SetVar d v) - | Iadd d l r => - lv <- lift (GetVar l) ;; - rv <- denote_operand r ;; - lift (SetVar d (lv + rv)) - | Iload d a => - addr <- denote_operand a ;; - val <- lift (Load addr) ;; - lift (SetVar d val) - | Istore a v => - addr <- lift (GetVar a) ;; - val <- denote_operand v ;; - lift (Store addr val) - end. + Infix ">=>" := seq_den (at level 40). - Section with_labels. - Context {label : Type}. + Definition id_den {A} : @den E A A := fun a => Ret a. - Definition denote_branch (b : branch label) - : itree e (option label) := - match b with - | Bjmp l => ret (Some l) - | Bbrz v y n => - val <- lift (GetVar v) ;; - if val : value then ret (Some y) else ret (Some n) - | Bhalt => ret None + Definition lift_den {A B} (f : A -> B) : @den E A B := fun a => Ret (f a). + + Definition den_sum_map_r {A B C} (ab : den A B) : den (C + A) (C + B) := + sum_elim (lift_den inl) (ab >=> lift_den inr). + + Definition den_sum_bimap {A B C D} (ab : den A B) (cd : den C D) : + den (A + C) (B + D) := + sum_elim (ab >=> lift_den inl) (cd >=> lift_den inr). + + End den_combinators. + + Require Import ExtLib.Structures.Monad. + Import MonadNotation. + Local Open Scope monad_scope. + + Require Import Imp. + + Inductive Memory : Type -> Type := + | Load (addr : value) : Memory value + | Store (addr val : value) : Memory unit. + + (* Denotation of blocks *) + Section with_effect. + Variable e : Type -> Type. + Context {HasLocals : Locals -< e}. + Context {HasMemory : Memory -< e}. + + Definition denote_operand (o : operand) : itree e value := + match o with + | Oimm v => Ret v + | Ovar v => lift (GetVar v) end. - Fixpoint denote_block (b : block label) - : itree e (option label) := - match b with - | bbi i b => - denote_instr i ;; - denote_block b - | bbb b => - denote_branch b + Definition denote_instr (i : instr) : itree e unit := + match i with + | Imov d s => + v <- denote_operand s ;; + lift (SetVar d v) + | Iadd d l r => + lv <- lift (GetVar l) ;; + rv <- denote_operand r ;; + lift (SetVar d (lv + rv)) + | Iload d a => + addr <- denote_operand a ;; + val <- lift (Load addr) ;; + lift (SetVar d val) + | Istore a v => + addr <- lift (GetVar a) ;; + val <- denote_operand v ;; + lift (Store addr val) end. - End with_labels. -End with_effect. - -Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} - (p : program L) (imports: L -> itree e unit) : p.(label) -> itree e unit := - rec (fun lbl : p.(label) => - next <- denote_block (_ +' e) (p.(blocks) lbl) ;; - match next with - | None => ret tt - | Some (inl next) => lift (Call next) - | Some (inr next) => translate (@inr1 _ _) _ (imports next) - end). - -Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} - (p : program L) (imports: L -> itree e unit) : itree e unit := - next <- denote_block e p.(main) ;; - match next with - | None => ret tt - | Some (inl next) => denote_program p imports next - | Some (inr next) => imports next - end. - + + Section with_labels. + Context {A B : Type}. + + Inductive done : Set := Done : done. + + Definition denote_branch (b : @branch B) + : itree e (B + done) := + match b with + | Bjmp l => ret (inl l) + | Bbrz v y n => + val <- lift (GetVar v) ;; + if val : value then ret (inl y) else ret (inl n) + | Bhalt => ret (inr Done) + end. + + Fixpoint denote_block (b : @block B) + : itree e (B + done) := + match b with + | bbi i b => + denote_instr i ;; denote_block b + | bbb b => + denote_branch b + end. + + Definition denote_b: bks A B -> @den e A (B + done) := + fun bs a => denote_block (bs a). + + End with_labels. + End with_effect. + + (* Denotation of [asm] *) + + Definition denote_asm {e} `{Locals -< e} `{Memory -< e} {A B} : asm A B -> @den e A (B + done) := + fun s => seq_den (lift_den inl) (loop (fun a => ITree.map sum_assoc_r (denote_b e (code s) a))). + +End Semantics. (* SAZ: Everything from here down can probably be polished. In particular, I'm still not completely happy with how all the different parts @@ -185,10 +217,14 @@ Instance RelDec_string : RelDec (@eq string) := Instance RelDec_value : RelDec (@eq value) := { rel_dec := Nat.eqb }. -(* SAZ: Is this the nicest way to present this? *) -Definition run (p: program Empty_set) : itree emptyE (env * (memory * unit)) := +(* +TODO: FIX + +Definition run (p: asm unit done) : itree emptyE (env * (memory * unit)) := let eval := Sum1.elim interpret_Locals interpret_Memory in - run_env _ (run_env _ (interp eval _ (denote_main p (fun x => match x with end))) empty) empty. + run_env _ (run_env _ (interp eval _ (denote_asm p tt)) empty) empty. + +*) (* SAZ: Note: we should be able to prove that run produces trees that are equivalent to run' where run' interprets memory and locals in a different order *) @@ -250,4 +286,19 @@ Section Fact. End Fact. *) +(* +Module AsmNotations. + + (* TODO *) + Notation "▿ i0 ; .. ; i ; br △" := + (bbi i0 .. (bbi i (bbb br)) ..) + (right associativity). + + Open Scope string_scope. + Definition bar := Imov "x" (Ovar "x"). + Definition foo {label: Type}: @block label := + ▿ bar ; bar ; bar ; Bhalt △. + +End AsmNotations. +*) \ No newline at end of file diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index b1128201..48845c44 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -1,4 +1,3 @@ - From Coq Require Import Program Lia @@ -6,195 +5,33 @@ From Coq Require Import Morphisms RelationClasses. - From ITree Require Import ITree FixFacts. Require Import Program.Basics. (* ∘ *) - Set Nested Proofs Allowed. - -(** * The Category of Functions *) - -(* id : A -> A - compose : (B -> C) -> (A -> B) -> (A -> C) - Infix "∘" = compose - - compose_id_right : f ∘ id = f - compose_id_left : id ∘ f = f - compose_assoc : (f ∘ g) ∘ h = f ∘ (g ∘ h) - *) - -Hint Rewrite @compose_id_left : cat. -Hint Rewrite @compose_id_right : cat. - -(** Extensional function equality *) -Definition eqeq {A B} := (@eq A ==> @eq B)%signature. - -Instance Equivalence_eqeq {A B} : Equivalence (@eqeq A B). -Proof. - constructor; cbv; intros; subst; auto. - - symmetry; auto. - - etransitivity; auto. -Qed. - -Instance eq_compose {A B C} : - Proper (eqeq ==> eqeq ==> eqeq) (@compose A B C). -Proof. cbv; auto. Qed. - -(** * Diagramatic/categorical sum combinators. *) - -Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := - fun x => - match x with - | inl a => f a - | inr b => g b - end. - -Definition sum_bimap {A B C D} (f : A -> B) (g : C -> D) : - A + C -> B + D := - sum_elim (inl ∘ f) (inr ∘ g). - -Definition sum_map_l {A B C} (f : A -> B) : A + C -> B + C := - sum_bimap f id. - -Definition sum_map_r {A B C} (f : A -> B) : C + A -> C + B := - sum_bimap id f. - -Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := - match abc with - | inl (inl a) => inl a - | inl (inr b) => inr (inl b) - | inr c => inr (inr c) - end. - -Definition sum_comm {A B} : A + B -> B + A := - sum_elim inr inl. - -Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := - match abc with - | inl a => inl (inl a) - | inr (inl b) => inl (inr b) - | inr (inr c) => inr c - end. - -Definition sum_merge {A} : A + A -> A := sum_elim id id. - -(** ** Equational theory *) - -Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : - eqeq (cd ∘ sum_elim ac bc) - (sum_elim (cd ∘ ac) (cd ∘ bc)). -Proof. - intros [] ? []; auto. -Qed. - -Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : - sum_elim f g ∘ inl = f. -Proof. reflexivity. Qed. - -Lemma sum_elim_inr {A B C} (f : A -> C) (g : B -> C) : - sum_elim f g ∘ inr = g. -Proof. reflexivity. Qed. - -Lemma sum_elim_inl' {A B C D} (f : A -> C) (g : B -> C) (h : D -> A) : - sum_elim f g ∘ (inl ∘ h) = f ∘ h. -Proof. reflexivity. Qed. - -Lemma sum_elim_inr' {A B C D} (f : A -> C) (g : B -> C) (h : D -> B) : - sum_elim f g ∘ (inr ∘ h) = g ∘ h. -Proof. reflexivity. Qed. - -Lemma unfold_sum_assoc_r {A B C} : - @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). -Proof. cbv; auto. Qed. - -Instance eqeq_sum_elim {A B C} : - Proper (eqeq ==> eqeq ==> eqeq) (@sum_elim A B C). -Proof. cbv; intros; subst; destruct _; auto. Qed. - -Hint Rewrite @sum_elim_inl : sum_elim. -Hint Rewrite @sum_elim_inr : sum_elim. -Hint Rewrite @sum_elim_inl' : sum_elim. -Hint Rewrite @sum_elim_inr' : sum_elim. - -(** ** Automatic solver of reassociating sums *) +Require Import sum. +Require Import Asm. -Class ReSum (A B : Type) := - resum : A -> B. +Variable E0 : Type -> Type. +Notation den := (@den E0). -Instance ReSum_id A : ReSum A A := id. -Instance ReSum_sum A B C `{ReSum A C} `{ReSum B C} : ReSum (A + B) C := - sum_elim resum resum. -Instance ReSum_inl A B C `{ReSum A B} : ReSum A (B + C) := - inl ∘ resum. -Instance ReSum_inr A B C `{ReSum A B} : ReSum A (C + B) := - inr ∘ resum. - -(* Usage template: - -[[ -Opaque compose. -Opaque id. -Opaque sum_elim. - -Definition f {X Y Z} : complex_sum -> another_complex_sum := - Eval compute in resum. - -Transparent compose. -Transparent id. -Transparent sum_elim. -]] -*) - -(** * Bijections *) - -Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := - { iso_ff' : forall a, f' (f a) = a; - iso_f'f : forall b, f (f' b) = b; - }. - -Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. -Proof. - - destruct 0 as [| []]; auto. - - destruct 0 as [[] |]; auto. -Qed. - -Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. -Proof. - - destruct 0 as [[] |]; auto. - - destruct 0 as [| []]; auto. -Qed. - -(* ASM definition *) - -(* Blocks are indexed by type of jump labels. *) -Axiom block : Type -> Type. -(* Collection of blocks labeled by [A], with jumps in [B]. *) -Definition bks A B := A -> block B. -Axiom E0 : Type -> Type. - -Axiom cat_b : forall {A B C D}, +Definition cat_b {A B C D}: (bks A B) -> (bks C D) -> - (bks (A + C) (B + D)). - -Axiom rewire_b : forall {A B C D}, - (C -> A) -> - (B -> D) -> - (bks A B) -> - (bks C D). - -(* ASM: linked blocks, can jump to themselves *) -Record asm A B : Type := { - internal : Type; - code : bks (A + internal) ((A + internal) + B) -}. -Arguments internal {A B}. -Arguments code {A B}. + (bks (A + C) (B + D)) := + fun ab cd oac => + match oac with + | inl a => fmap_block inl (ab a) + | inr c => fmap_block inr (cd c) + end. -(* Denotations as itrees *) -Definition den A B : Type := A -> itree E0 B. -(* den can represent both blocks (A -> block B) and asm (asm A B). *) +Definition rewire_b {A B C D}: + (C -> A) -> + (B -> D) -> + (bks A B) -> + (bks C D) := + fun f g ab c => + fmap_block g (ab (f c)). Notation eq_den_ d1 d2 := (forall a, eutt eq (d1 a) (d2 a)). @@ -302,7 +139,9 @@ Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := Instance eutt_loop {E A B} : Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B). Proof. -Admitted. + repeat intro. + subst. +Admitted. Instance eutt_loop' {E A B} : Proper (eq_den ==> eq_den) (@loop E A B). @@ -419,6 +258,7 @@ Admitted. Instance eq_lift_den {A B} : Proper (eqeq ==> eq_den) (@lift_den A B). Proof. + repeat intro. Admitted. Lemma seq_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : @@ -437,6 +277,23 @@ Proof. intros []; reflexivity. Qed. Hint Rewrite @lift_sum_elim : lift_den. Hint Rewrite @seq_lift_den : lift_den. +Lemma lift_den_lift_den: forall {A B C} (f: A -> B) (g: B -> C), + eq_den (lift_den f >=> lift_den g) (lift_den (g ∘ f)). +Proof. + intros; intros a. + unfold lift_den, seq_den. + rewrite ret_bind. + reflexivity. +Qed. + +Lemma lift_den_assoc: forall {A B C D} (f: A -> B) (g: B -> C) (k: den C D), + eq_den (lift_den f >=> (lift_den g >=> k)) (lift_den f >=> lift_den g >=> k). +Proof. + intros; intros a. + unfold lift_den, seq_den. + repeat rewrite ret_bind; reflexivity. +Qed. + Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_den (denote_asm (seq_asm ab bc)) (seq_den (denote_asm ab) (denote_asm bc)). @@ -449,12 +306,14 @@ Proof. rewrite unfold_rewire_den. rewrite (seq_den_assoc (_ inl)). rewrite seq_loop_l. + rewrite lift_den_assoc, lift_den_lift_den. unfold den_sum_bimap. rewrite (seq_den_assoc (_ inl)). rewrite seq_loop_l_seq. unfold den_sum_map_r. rewrite sum_elim_loop. rewrite loop_loop. + rewrite lift_den_assoc, lift_den_lift_den. rewrite (loop_relabel sum_assoc_r). repeat (rewrite seq_lift_den + rewrite <- (seq_den_assoc (lift_den _) (lift_den _))). apply eutt_seq_den. diff --git a/examples/sum.v b/examples/sum.v new file mode 100644 index 00000000..d2e4b2b5 --- /dev/null +++ b/examples/sum.v @@ -0,0 +1,158 @@ +From Coq Require Import + Morphisms + Program. + +(* TODO: Move this in the library *) + +(** * The Category of Functions *) + +(* id : A -> A + compose : (B -> C) -> (A -> B) -> (A -> C) + Infix "∘" = compose + + compose_id_right : f ∘ id = f + compose_id_left : id ∘ f = f + compose_assoc : (f ∘ g) ∘ h = f ∘ (g ∘ h) + *) + +Hint Rewrite @compose_id_left : cat. +Hint Rewrite @compose_id_right : cat. + +(** Extensional function equality *) +Definition eqeq {A B} := (@eq A ==> @eq B)%signature. + +Instance Equivalence_eqeq {A B} : Equivalence (@eqeq A B). +Proof. + constructor; cbv; intros; subst; auto. + - symmetry; auto. + - etransitivity; auto. +Qed. + +Instance eq_compose {A B C} : + Proper (eqeq ==> eqeq ==> eqeq) (@compose A B C). +Proof. cbv; auto. Qed. + +(** * Diagramatic/categorical sum combinators. *) + +Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := + fun x => + match x with + | inl a => f a + | inr b => g b + end. + +Definition sum_bimap {A B C D} (f : A -> B) (g : C -> D) : + A + C -> B + D := + sum_elim (inl ∘ f) (inr ∘ g). + +Definition sum_map_l {A B C} (f : A -> B) : A + C -> B + C := + sum_bimap f id. + +Definition sum_map_r {A B C} (f : A -> B) : C + A -> C + B := + sum_bimap id f. + +Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := + match abc with + | inl (inl a) => inl a + | inl (inr b) => inr (inl b) + | inr c => inr (inr c) + end. + +Definition sum_comm {A B} : A + B -> B + A := + sum_elim inr inl. + +Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := + match abc with + | inl a => inl (inl a) + | inr (inl b) => inl (inr b) + | inr (inr c) => inr c + end. + +Definition sum_merge {A} : A + A -> A := sum_elim id id. + +(** ** Equational theory *) + +Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : + eqeq (cd ∘ sum_elim ac bc) + (sum_elim (cd ∘ ac) (cd ∘ bc)). +Proof. + intros [] ? []; auto. +Qed. + +Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inl = f. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr {A B C} (f : A -> C) (g : B -> C) : + sum_elim f g ∘ inr = g. +Proof. reflexivity. Qed. + +Lemma sum_elim_inl' {A B C D} (f : A -> C) (g : B -> C) (h : D -> A) : + sum_elim f g ∘ (inl ∘ h) = f ∘ h. +Proof. reflexivity. Qed. + +Lemma sum_elim_inr' {A B C D} (f : A -> C) (g : B -> C) (h : D -> B) : + sum_elim f g ∘ (inr ∘ h) = g ∘ h. +Proof. reflexivity. Qed. + +Lemma unfold_sum_assoc_r {A B C} : + @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). +Proof. cbv; auto. Qed. + +Instance eqeq_sum_elim {A B C} : + Proper (eqeq ==> eqeq ==> eqeq) (@sum_elim A B C). +Proof. cbv; intros; subst; destruct _; auto. Qed. + +Hint Rewrite @sum_elim_inl : sum_elim. +Hint Rewrite @sum_elim_inr : sum_elim. +Hint Rewrite @sum_elim_inl' : sum_elim. +Hint Rewrite @sum_elim_inr' : sum_elim. + +(** ** Automatic solver of reassociating sums *) + +Class ReSum (A B : Type) := + resum : A -> B. + +Instance ReSum_id A : ReSum A A := id. +Instance ReSum_sum A B C `{ReSum A C} `{ReSum B C} : ReSum (A + B) C := + sum_elim resum resum. +Instance ReSum_inl A B C `{ReSum A B} : ReSum A (B + C) := + inl ∘ resum. +Instance ReSum_inr A B C `{ReSum A B} : ReSum A (C + B) := + inr ∘ resum. + +(* Usage template: + +[[ +Opaque compose. +Opaque id. +Opaque sum_elim. + +Definition f {X Y Z} : complex_sum -> another_complex_sum := + Eval compute in resum. + +Transparent compose. +Transparent id. +Transparent sum_elim. +]] +*) + +(** * Bijections *) + +Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := + { iso_ff' : forall a, f' (f a) = a; + iso_f'f : forall b, f (f' b) = b; + }. + +Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. +Proof. + - destruct 0 as [| []]; auto. + - destruct 0 as [[] |]; auto. +Qed. + +Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. +Proof. + - destruct 0 as [[] |]; auto. + - destruct 0 as [| []]; auto. +Qed. + From 8870dd6964b3e9007657ae4313eb8c29a3a1fa70 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 20 Feb 2019 19:59:50 -0500 Subject: [PATCH 045/142] Rename loop to aloop, add new loop --- Makefile | 30 ++++++++++++++++-------------- examples/Asm.v | 10 ++++++---- examples/Imp2AsmBis.v | 28 ++++++++++++++-------------- theories/Fix.v | 17 +++++++++++++++-- theories/FixFacts.v | 17 +++++++++-------- 5 files changed, 60 insertions(+), 42 deletions(-) diff --git a/Makefile b/Makefile index 934f4254..8555e93a 100644 --- a/Makefile +++ b/Makefile @@ -21,27 +21,29 @@ tests: examples: example-imp example-lc example-io example-nimp example-threads -example-imp: examples/Imp.v - coqc -Q theories/ ITree examples/Imp.v +examples/%.vo: examples/%.v + cd examples && \ + coqc -Q ../theories/ ITree $*.v + +example-imp: examples/Imp.vo -example-lc: examples/stlc.v - coqc -Q theories/ ITree examples/stlc.v +example-lc: examples/stlc.vo -example-lc: examples/stlc.v - coqc -Q theories/ ITree examples/Nimp.v +example-lc: examples/stlc.vo -example-io: examples/IO.v +example-io: examples/IO.vo cd examples && \ - coqc -Q ../theories/ ITree IO.v && \ ocamlbuild io.native && ./io.native -example-asm: example-imp examples/Asm.v - cd examples && \ - coqc -Q ../theories/ ITree Asm.v +examples/Asm.vo: examples/sum.vo examples/Imp.vo +examples/Imp2Asm.vo: examples/Asm.vo +examples/Imp2AsmBis.vo: examples/sum.vo -example-imp2asm: example-asm examples/Imp2Asm.v - cd examples && \ - coqc -Q ../theories/ ITree Imp2Asm.v +example-asm: examples/Asm.vo + +example-imp2asm: examples/Imp2Asm.vo + +example-imp2asm2: examples/Imp2AsmBis.vo THREADSV=examples/MultiThreadedPrinting.v examples/ExtractThreadsExample.v THREADSML=examples/runthread.ml diff --git a/examples/Asm.v b/examples/Asm.v index 3c991509..218c01ee 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -24,12 +24,12 @@ Section Syntax. | Bbrz (_ : var) (yes no : label) (* conditional jump *) | Bhalt . - Arguments branch _ : clear implicits. + Global Arguments branch _ : clear implicits. Inductive block {label : Type} : Type := | bbi (_ : instr) (_ : block) | bbb (_ : branch label). - Arguments block _ : clear implicits. + Global Arguments block _ : clear implicits. Definition fmap_branch {A B : Type} (f: A -> B): branch A -> branch B := fun b => @@ -168,7 +168,9 @@ Section Semantics. (* Denotation of [asm] *) Definition denote_asm {e} `{Locals -< e} `{Memory -< e} {A B} : asm A B -> @den e A (B + done) := - fun s => seq_den (lift_den inl) (loop (fun a => ITree.map sum_assoc_r (denote_b e (code s) a))). + fun s => + seq_den (lift_den inl) + (aloop (fun a => ITree.map sum_assoc_r (denote_b e (code s) a))). End Semantics. (* SAZ: Everything from here down can probably be polished. @@ -301,4 +303,4 @@ Module AsmNotations. End AsmNotations. -*) \ No newline at end of file +*) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index 48845c44..9a438173 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -60,7 +60,7 @@ Axiom denote_b : forall {A B}, bks A B -> den A B. (* Denotation of [asm] *) Definition denote_asm {A B} : asm A B -> den A B := - fun s => seq_den (lift_den inl) (loop (denote_b (code s))). + fun s => seq_den (lift_den inl) (aloop (denote_b (code s))). (* A denotation of an asm program can be viewed as a circuit/diagram where wires correspond to jumps/program links. @@ -137,14 +137,14 @@ Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := (* Unused but should go to FixFacts *) Instance eutt_loop {E A B} : - Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B). + Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@aloop E A B). Proof. repeat intro. subst. Admitted. Instance eutt_loop' {E A B} : - Proper (eq_den ==> eq_den) (@loop E A B). + Proper (eq_den ==> eq_den) (@aloop E A B). Proof. Admitted. @@ -172,15 +172,15 @@ Admitted. Lemma seq_loop_l {A B C} (ab : den A (A + B)) (bc : den B C) : - eq_den (loop ab >=> bc) - (lift_den inl >=> loop (den_sum_bimap ab bc)). + eq_den (aloop ab >=> bc) + (lift_den inl >=> aloop (den_sum_bimap ab bc)). Proof. Admitted. Lemma seq_loop_l_seq {A B C} (ab : den A (A + B)) (bc : den B C) : - eq_den (loop ab >=> bc) - (loop (ab >=> den_sum_map_r bc)). + eq_den (aloop ab >=> bc) + (aloop (ab >=> den_sum_map_r bc)). Proof. Admitted. @@ -223,9 +223,9 @@ Can be rewired as: *) Lemma loop_loop {A B C} (f : A -> B) (bc : den B (B + (A + C))) : - eq_den (loop (lift_den f >=> loop bc)) + eq_den (aloop (lift_den f >=> aloop bc)) (lift_den f - >=> loop (bc >=> lift_den (sum_elim inl (sum_elim (inl ∘ f) inr)))). + >=> aloop (bc >=> lift_den (sum_elim inl (sum_elim (inl ∘ f) inr)))). Proof. Admitted. @@ -233,10 +233,10 @@ Lemma sum_elim_loop {A B C BD} (f : B -> BD) (ac : den A C) (bc : den BD (BD + C)) : eq_den (sum_elim ac - (lift_den f >=> loop bc)) + (lift_den f >=> aloop bc)) (lift_den (sum_map_r f) - >=> loop (sum_elim (ac >=> lift_den inr) - (bc >=> lift_den (sum_map_l inr)))). + >=> aloop (sum_elim (ac >=> lift_den inr) + (bc >=> lift_den (sum_map_l inr)))). Proof. Admitted. @@ -244,8 +244,8 @@ Lemma loop_relabel {A B C} (f : A -> B) {f' : B -> A} {ISO_f : Iso f f'} (ac : den A (A + C)) : - eq_den (loop ac) - (lift_den f >=> loop (lift_den f' >=> ac >=> lift_den (sum_map_l f))). + eq_den (aloop ac) + (lift_den f >=> aloop (lift_den f' >=> ac >=> lift_den (sum_map_l f))). Proof. Admitted. diff --git a/theories/Fix.v b/theories/Fix.v index 6e4737bb..b3612c91 100644 --- a/theories/Fix.v +++ b/theories/Fix.v @@ -114,9 +114,22 @@ Definition rec {E : Type -> Type} {A B : Type} A -> itree E B := fun a => mrec (calling' body) _ (Call a). -(* Iterate a function updating an accumulator [A], +(* Iterate a function updating an accumulator [C], until it produces an output [B]. *) -Definition loop {E : Type -> Type} {A B : Type} +Definition loop {E : Type -> Type} {A B C : Type} + (body : (C + A) -> itree E (C + B)) : + A -> itree E B := + rec (fun a => + bc <- translate (fun _ x => inr1 x) _ (body a) ;; + match bc with + | inl c => ITree.liftE (inl1 (Call a)) + | inr b => Ret b + end) ∘ inr. + +(* Iterate a function updating an accumulator [A], until it produces + an output [B]. It's an Asymmetric variant of [loop], and it looks + similar to an Anamorphism, hence the name [aloop]. *) +Definition aloop {E : Type -> Type} {A B : Type} (body : A -> itree E (A + B)) : A -> itree E B := rec (fun a => diff --git a/theories/FixFacts.v b/theories/FixFacts.v index d5934f14..be33e1f1 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -198,13 +198,14 @@ Proof. Qed. Lemma loop_unfold {E A B} (f : A -> itree E (A + B)) (x : A) : - loop f x ≈ (ab <- f x ;; - match ab with - | inl a => loop f a - | inr b => Ret b - end). + aloop f x + ≈ (ab <- f x ;; + match ab with + | inl a => aloop f a + | inr b => Ret b + end). Proof. - unfold loop at 1. + unfold aloop at 1. rewrite rec_unfold. rewrite interp_bind. rewrite interp_translate. @@ -225,8 +226,8 @@ Definition sum_map1 {A B C} (f : A -> B) (ac : A + C) : B + C := end. Lemma bind_loop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) (x : A) : - (loop f x >>= loop g) - ≈ loop (fun ab => + (aloop f x >>= aloop g) + ≈ aloop (fun ab => match ab with | inl a => ITree.map inl (f a) | inr b => ITree.map (sum_map1 inr) (g b) From 5108ddbcd6a65abd7d1b434e656b08e2472e02dd Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 20 Feb 2019 21:57:33 -0500 Subject: [PATCH 046/142] Proving a few lemmas --- examples/Imp2AsmBis.v | 171 ++++++++++++++++++++++++++---------------- 1 file changed, 105 insertions(+), 66 deletions(-) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index 9a438173..ae56d014 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -92,10 +92,115 @@ Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) (ab : den A B) : den C D := fun a => ITree.map g (ab (f a)). +Lemma lift_den_lift_den: forall {A B C} (f: A -> B) (g: B -> C), + eq_den (lift_den f >=> lift_den g) (lift_den (g ∘ f)). +Proof. + intros; intros a. + unfold lift_den, seq_den. + rewrite ret_bind. + reflexivity. +Qed. + +Lemma lift_den_assoc: forall {A B C D} (f: A -> B) (g: B -> C) (k: den C D), + eq_den (lift_den f >=> (lift_den g >=> k)) (lift_den f >=> lift_den g >=> k). +Proof. + intros; intros a. + unfold lift_den, seq_den. + repeat rewrite ret_bind; reflexivity. +Qed. + +Lemma lift_seq_den {A B C}: forall (f:A -> B) (bc: den B C), + eq_den (lift_den f >=> bc) (fun a => bc (f a)). +Proof. + intros; intro a. + unfold lift_den, seq_den. + rewrite ret_bind; reflexivity. +Qed. + +Lemma seq_den_lift {A B C}: forall (ab: den A B) (g:B -> C), + eq_den (ab >=> lift_den g) (fun a => ITree.map g (ab a)). +Proof. + intros; intro a. + reflexivity. +Qed. + +Lemma seq_den_assoc {A B C D} + (ab : den A B) (bc : den B C) (cd : den C D) : + eq_den ((ab >=> bc) >=> cd) + (ab >=> (bc >=> cd)). +Proof. + unfold seq_den; intro a. + rewrite bind_bind; reflexivity. +Qed. + +Instance eutt_seq_den {A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@seq_den A B C). +Proof. + intros ab ab' eqAB bc bc' eqBC. + intro a. + unfold seq_den. + rewrite (eqAB a). + apply eutt_bind; [reflexivity | intro b]. + rewrite (eqBC b); reflexivity. +Qed. + +Instance Equivalence_eq_den {E A B} : Equivalence (@eq_den E A B). +Proof. + split. + - intros ab a; reflexivity. + - intros ab ab' eqAB a; symmetry; auto. + - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. +Qed. + Lemma unfold_rewire_den {A B C D} (f : C -> A) (g : B -> D) (ab : den A B) : eq_den (rewire_den f g ab) (lift_den f >=> ab >=> lift_den g). +Proof. + rewrite lift_seq_den, seq_den_lift. + reflexivity. +Qed. + +Instance lift_den_respectful {A B} : + Proper ((eq ==> eq) ==> eq_den) + (@lift_den A B). +Proof. + repeat intro. + unfold lift_den. + erewrite (H a); reflexivity. +Qed. + +Instance eutt_rewire_den {A B C D} : + Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq_den ==> eq_den) + (@rewire_den A B C D). +Proof. + intros f f' eqf g g' eqg ab ab' eqAB. + do 2 rewrite unfold_rewire_den. + rewrite eqf, eqg, eqAB; reflexivity. +Qed. + +(* Unused but should go to FixFacts *) +Instance eutt_loop {E A B} : + Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@aloop E A B). +Proof. +Admitted. + +Instance eutt_loop' {E A B} : + Proper (eq_den ==> eq_den) (@aloop E A B). +Proof. +Admitted. + +Lemma seq_loop_l {A B C} + (ab : den A (A + B)) (bc : den B C) : + eq_den (aloop ab >=> bc) + (lift_den inl >=> aloop (den_sum_bimap ab bc)). +Proof. +Admitted. + +Lemma seq_loop_l_seq {A B C} + (ab : den A (A + B)) (bc : den B C) : + eq_den (aloop ab >=> bc) + (aloop (ab >=> den_sum_map_r bc)). Proof. Admitted. @@ -135,55 +240,6 @@ Definition seq_bks {A I B J C} Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := {| code := seq_bks (code ab) (code bc) |}. -(* Unused but should go to FixFacts *) -Instance eutt_loop {E A B} : - Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@aloop E A B). -Proof. - repeat intro. - subst. -Admitted. - -Instance eutt_loop' {E A B} : - Proper (eq_den ==> eq_den) (@aloop E A B). -Proof. -Admitted. - -Instance eutt_rewire_den {A B C D} : - Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq_den ==> eq_den) - (@rewire_den A B C D). -Proof. -Admitted. - -Instance eutt_seq_den {A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@seq_den A B C). -Proof. -Admitted. - -Instance Equivalence_eq_den {E A B} : Equivalence (@eq_den E A B). -Proof. -Admitted. - -Lemma seq_den_assoc {A B C D} - (ab : den A B) (bc : den B C) (cd : den C D) : - eq_den ((ab >=> bc) >=> cd) - (ab >=> (bc >=> cd)). -Proof. -Admitted. - -Lemma seq_loop_l {A B C} - (ab : den A (A + B)) (bc : den B C) : - eq_den (aloop ab >=> bc) - (lift_den inl >=> aloop (den_sum_bimap ab bc)). -Proof. -Admitted. - -Lemma seq_loop_l_seq {A B C} - (ab : den A (A + B)) (bc : den B C) : - eq_den (aloop ab >=> bc) - (aloop (ab >=> den_sum_map_r bc)). -Proof. -Admitted. - (* Lemma seq_loop_r {A B C} (ab : den A B) (bc : den B (B + C)) : @@ -277,23 +333,6 @@ Proof. intros []; reflexivity. Qed. Hint Rewrite @lift_sum_elim : lift_den. Hint Rewrite @seq_lift_den : lift_den. -Lemma lift_den_lift_den: forall {A B C} (f: A -> B) (g: B -> C), - eq_den (lift_den f >=> lift_den g) (lift_den (g ∘ f)). -Proof. - intros; intros a. - unfold lift_den, seq_den. - rewrite ret_bind. - reflexivity. -Qed. - -Lemma lift_den_assoc: forall {A B C D} (f: A -> B) (g: B -> C) (k: den C D), - eq_den (lift_den f >=> (lift_den g >=> k)) (lift_den f >=> lift_den g >=> k). -Proof. - intros; intros a. - unfold lift_den, seq_den. - repeat rewrite ret_bind; reflexivity. -Qed. - Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_den (denote_asm (seq_asm ab bc)) (seq_den (denote_asm ab) (denote_asm bc)). From 58d05da285e32ede25a5af7e5696c247190973ab Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 20 Feb 2019 22:18:22 -0500 Subject: [PATCH 047/142] Cleaning up some lemmas I accidentally duplicated --- examples/Imp2AsmBis.v | 24 +++++++----------------- 1 file changed, 7 insertions(+), 17 deletions(-) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index ae56d014..ad5ebbf0 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -92,7 +92,7 @@ Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) (ab : den A B) : den C D := fun a => ITree.map g (ab (f a)). -Lemma lift_den_lift_den: forall {A B C} (f: A -> B) (g: B -> C), +Lemma seq_lift_den: forall {A B C} (f: A -> B) (g: B -> C), eq_den (lift_den f >=> lift_den g) (lift_den (g ∘ f)). Proof. intros; intros a. @@ -161,7 +161,7 @@ Proof. reflexivity. Qed. -Instance lift_den_respectful {A B} : +Instance eq_lift_den {A B} : Proper ((eq ==> eq) ==> eq_den) (@lift_den A B). Proof. @@ -204,7 +204,9 @@ Lemma seq_loop_l_seq {A B C} Proof. Admitted. -(* Correctness of [cat_b] and [rewire_b] (easy) *) +(* Correctness of [cat_b] and [rewire_b] (easy) + YZ: Those depend on the implementation. Should they be assumed by the theory? + *) Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : eq_den (denote_b (cat_b ab cd)) (cat_den (denote_b ab) (denote_b cd)). @@ -305,18 +307,6 @@ Lemma loop_relabel {A B C} Proof. Admitted. -Lemma seq_lift_den {A B C} (ab : A -> B) (bc : B -> C) : - eq_den (lift_den ab >=> lift_den bc) - (lift_den (bc ∘ ab)). -Proof. -Admitted. - -Instance eq_lift_den {A B} : - Proper (eqeq ==> eq_den) (@lift_den A B). -Proof. - repeat intro. -Admitted. - Lemma seq_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : eq_den (sum_elim ac bc >=> cd) (sum_elim (ac >=> cd) (bc >=> cd)). @@ -345,14 +335,14 @@ Proof. rewrite unfold_rewire_den. rewrite (seq_den_assoc (_ inl)). rewrite seq_loop_l. - rewrite lift_den_assoc, lift_den_lift_den. + rewrite lift_den_assoc, seq_lift_den. unfold den_sum_bimap. rewrite (seq_den_assoc (_ inl)). rewrite seq_loop_l_seq. unfold den_sum_map_r. rewrite sum_elim_loop. rewrite loop_loop. - rewrite lift_den_assoc, lift_den_lift_den. + rewrite lift_den_assoc, seq_lift_den. rewrite (loop_relabel sum_assoc_r). repeat (rewrite seq_lift_den + rewrite <- (seq_den_assoc (lift_den _) (lift_den _))). apply eutt_seq_den. From d813330b8a06832b46c54960ff339f350f6a0bff Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 08:00:30 -0500 Subject: [PATCH 048/142] Refactoring - Hide done from the signature of denotations - Use loop instead of aloop - Rename cat_den to juxta_den - Rename seq_den to cat_den - Add ITree.cat --- Makefile | 2 +- examples/Asm.v | 75 ++++-- examples/Imp2AsmBis.v | 536 ++++++++++++++++++++++-------------------- examples/sum.v | 22 ++ theories/Core.v | 6 + theories/FixFacts.v | 7 + 6 files changed, 370 insertions(+), 278 deletions(-) diff --git a/Makefile b/Makefile index 8555e93a..0917ed5b 100644 --- a/Makefile +++ b/Makefile @@ -37,7 +37,7 @@ example-io: examples/IO.vo examples/Asm.vo: examples/sum.vo examples/Imp.vo examples/Imp2Asm.vo: examples/Asm.vo -examples/Imp2AsmBis.vo: examples/sum.vo +examples/Imp2AsmBis.vo: examples/sum.vo examples/Asm.vo example-asm: examples/Asm.vo diff --git a/examples/Asm.v b/examples/Asm.v index 218c01ee..d08deebe 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -1,4 +1,6 @@ -Require Import Coq.Strings.String. +From Coq Require Import + Strings.String + Program.Basics. Require Import ZArith. Typeclasses eauto := 5. @@ -52,7 +54,7 @@ Section Syntax. (* ASM: linked blocks, can jump to themselves *) Record asm A B : Type := { internal : Type; - code : bks (A + internal) ((A + internal) + B) + code : bks (internal + A) (internal + B) }. End Syntax. @@ -64,36 +66,48 @@ From ITree Require Import ITree OpenSum Fix. Require Import sum. +Delimit Scope den_scope with den. +Local Open Scope den_scope. + Section Semantics. (* now define a semantics *) + Inductive done : Set := Done : done. + (* Denotations as itrees *) - Definition den {E: Type -> Type} A B : Type := A -> itree E B. + Definition den {E: Type -> Type} A B : Type := A -> itree E (B + done). (* den can represent both blocks (A -> block B) and asm (asm A B). *) + Bind Scope den_scope with den. + Section den_combinators. Context {E: Type -> Type }. + Let den := @den E. (* Sequential composition of den. *) - Definition seq_den {A B C} (ab : den A B) (bc : den B C) : @den E A C := - fun a => ab a >>= bc. - - Infix ">=>" := seq_den (at level 40). + Definition cat_den {A B C} (ab : den A B) (bc : den B C) : den A C := + fun a => ob <- ab a ;; + match ob with + | inl b => bc b + | inr d => Ret (inr d) + end. - Definition id_den {A} : @den E A A := fun a => Ret a. + Infix ">=>" := cat_den (at level 50, left associativity). - Definition lift_den {A B} (f : A -> B) : @den E A B := fun a => Ret (f a). + Definition id_den {A} : den A A := fun a => Ret (inl a). - Definition den_sum_map_r {A B C} (ab : den A B) : den (C + A) (C + B) := - sum_elim (lift_den inl) (ab >=> lift_den inr). + Definition lift_den {A B} (f : A -> B) : den A B := fun a => Ret (inl (f a)). - Definition den_sum_bimap {A B C D} (ab : den A B) (cd : den C D) : + Definition juxta_den {A B C D} (ab : den A B) (cd : den C D) : den (A + C) (B + D) := sum_elim (ab >=> lift_den inl) (cd >=> lift_den inr). End den_combinators. + Definition eq_den {E A B} (d1 d2 : A -> itree E B) := + (forall a, eutt eq (d1 a) (d2 a)). + Require Import ExtLib.Structures.Monad. Import MonadNotation. Local Open Scope monad_scope. @@ -138,8 +152,6 @@ Section Semantics. Section with_labels. Context {A B : Type}. - Inductive done : Set := Done : done. - Definition denote_branch (b : @branch B) : itree e (B + done) := match b with @@ -159,18 +171,39 @@ Section Semantics. denote_branch b end. - Definition denote_b: bks A B -> @den e A (B + done) := + Definition denote_b: bks A B -> @den e A B := fun bs a => denote_block (bs a). End with_labels. End with_effect. - (* Denotation of [asm] *) +(* A denotation of an asm program can be viewed as a circuit/diagram + where wires correspond to jumps/program links. + + A [box : den (I + A) (I + B)] is a circuit, drawn below as ###, + with two input wires labeled by I and A, and two output wires + labeled by I and B. - Definition denote_asm {e} `{Locals -< e} `{Memory -< e} {A B} : asm A B -> @den e A (B + done) := - fun s => - seq_den (lift_den inl) - (aloop (fun a => ITree.map sum_assoc_r (denote_b e (code s) a))). + The [loop_den : den (I + A) (I + B) -> den A B] combinator closes + the circuit, linking the box with itself by plugging the I output + back into the input. + + +-----+ + | ### | + +-###-+I + A----###----B + ### + + *) + + Definition loop_den {E I A B} : + (I + A -> itree E ((I + B) + done)) -> A -> itree E (B + done) := + fun body => loop (compose (ITree.map sum_assoc_r) body). + + (* Denotation of [asm] *) + Definition denote_asm {e} `{Locals -< e} `{Memory -< e} {A B} : + asm A B -> @den e A B := + fun s => loop_den (denote_b e (code s)). End Semantics. (* SAZ: Everything from here down can probably be polished. @@ -180,6 +213,8 @@ End Semantics. *) +Infix ">=>" := cat_den (at level 50, left associativity). + (* Interpretation ----------------------------------------------------------- *) diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index ad5ebbf0..ae47a247 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -12,363 +12,385 @@ Require Import Program.Basics. (* ∘ *) Require Import sum. Require Import Asm. +(** * Category of denotations *) + Variable E0 : Type -> Type. +Instance ME0 : Memory -< E0. Admitted. +Instance LE0 : Imp.Locals -< E0. Admitted. Notation den := (@den E0). -Definition cat_b {A B C D}: - (bks A B) -> - (bks C D) -> - (bks (A + C) (B + D)) := - fun ab cd oac => - match oac with - | inl a => fmap_block inl (ab a) - | inr c => fmap_block inr (cd c) - end. - -Definition rewire_b {A B C D}: - (C -> A) -> - (B -> D) -> - (bks A B) -> - (bks C D) := - fun f g ab c => - fmap_block g (ab (f c)). - -Notation eq_den_ d1 d2 := (forall a, eutt eq (d1 a) (d2 a)). - -Definition eq_den {E A B} (d1 d2 : A -> itree E B) := - (forall a, eutt eq (d1 a) (d2 a)). - -(* Sequential composition of den. *) -Definition seq_den {A B C} (ab : den A B) (bc : den B C) : den A C := - fun a => ab a >>= bc. - -Infix ">=>" := seq_den (at level 40). - -Definition id_den {A} : den A A := fun a => Ret a. - -Definition lift_den {A B} (f : A -> B) : den A B := fun a => Ret (f a). - -Definition den_sum_map_r {A B C} (ab : den A B) : den (C + A) (C + B) := - sum_elim (lift_den inl) (ab >=> lift_den inr). - -Definition den_sum_bimap {A B C D} (ab : den A B) (cd : den C D) : - den (A + C) (B + D) := - sum_elim (ab >=> lift_den inl) (cd >=> lift_den inr). - -(* Denotation of [bks] *) -Axiom denote_b : forall {A B}, bks A B -> den A B. - -(* Denotation of [asm] *) -Definition denote_asm {A B} : asm A B -> den A B := - fun s => seq_den (lift_den inl) (aloop (denote_b (code s))). +Instance Equivalence_eq_den {E A B} : Equivalence (@eq_den E A B). +Proof. + split. + - intros ab a; reflexivity. + - intros ab ab' eqAB a; symmetry; auto. + - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. +Qed. -(* A denotation of an asm program can be viewed as a circuit/diagram - where wires correspond to jumps/program links. +Instance eq_den_loop {E I A B} : + Proper (eq_den ==> eq_den) (@loop_den E I A B). +Proof. +Admitted. - A [box : den A (A + B)] is a circuit, drawn below as ###, - with one input wire labeled by A, and two output wires labeled - by A and B. +Instance eq_den_cat {E A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@cat_den E A B C). +Proof. + intros ab ab' eqAB bc bc' eqBC. + intro a. + unfold cat_den. + rewrite (eqAB a). + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + rewrite (eqBC b); reflexivity. +Qed. - The [loop : den A (A + B) -> den A B] combinator closes the - circuit, linking the box with itself by plugging the A output - back into the output. +Instance eq_den_elim {E A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@sum_elim A B (itree E C)). +Proof. + repeat intro. destruct a; unfold sum_elim; auto. +Qed. - +-----+ - | ### | - A--+-###-+ - ###----B - ### +(** *** [cat_den] *) - *) +Lemma cat_den_assoc {A B C D} + (ab : den A B) (bc : den B C) (cd : den C D) : + eq_den ((ab >=> bc) >=> cd) + (ab >=> (bc >=> cd)). +Proof. + intros a. + unfold lift_den, cat_den. + rewrite bind_bind. + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + rewrite ret_bind; reflexivity. +Qed. -(* Denotation of [cat_b] *) -Definition cat_den {A B C D} : - (den A B) -> - (den C D) -> - (den (A + C) (B + D)) := den_sum_bimap. +Lemma cat_lift_den {E A B C} (ab : A -> B) (bc : B -> C) : + @eq_den E _ _ + (lift_den ab >=> lift_den bc) + (lift_den (bc ∘ ab)). +Proof. + intros a. + unfold lift_den, cat_den. + rewrite ret_bind. + reflexivity. +Qed. -(* Denotation of [rewire_b] *) -Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) - (ab : den A B) : den C D := - fun a => ITree.map g (ab (f a)). +Instance eq_lift_den {E A B} : + Proper (eqeq ==> eq_den) (@lift_den E A B). +Proof. + repeat intro. + unfold lift_den. + erewrite (H a); reflexivity. +Qed. -Lemma seq_lift_den: forall {A B C} (f: A -> B) (g: B -> C), - eq_den (lift_den f >=> lift_den g) (lift_den (g ∘ f)). +Lemma lift_den_lift_den {E A B C} (f: A -> B) (g: B -> C) : + @eq_den E _ _ (lift_den f >=> lift_den g) (lift_den (g ∘ f)). Proof. - intros; intros a. - unfold lift_den, seq_den. + intros a. + unfold lift_den, cat_den. rewrite ret_bind. reflexivity. Qed. -Lemma lift_den_assoc: forall {A B C D} (f: A -> B) (g: B -> C) (k: den C D), - eq_den (lift_den f >=> (lift_den g >=> k)) (lift_den f >=> lift_den g >=> k). +Lemma cat_lift_den_l {A B C D} (f: A -> B) (g: B -> C) (k: den C D) : + eq_den + (lift_den f >=> (lift_den g >=> k)) + (lift_den (g ∘ f) >=> k). Proof. - intros; intros a. - unfold lift_den, seq_den. - repeat rewrite ret_bind; reflexivity. + rewrite <- cat_den_assoc. + rewrite cat_lift_den. + reflexivity. +Qed. + +(* For completeness. *) +Lemma cat_lift_den_r {A B C D} (f: B -> C) (g: C -> D) (k: den A B) : + eq_den + ((k >=> lift_den f) >=> lift_den g) + (k >=> lift_den (g ∘ f)). +Proof. + rewrite cat_den_assoc. + rewrite cat_lift_den. + reflexivity. Qed. -Lemma lift_seq_den {A B C}: forall (f:A -> B) (bc: den B C), +(* Low-level *) +Lemma lift_cat_den {A B C}: forall (f:A -> B) (bc: den B C), eq_den (lift_den f >=> bc) (fun a => bc (f a)). Proof. intros; intro a. - unfold lift_den, seq_den. + unfold lift_den, cat_den. rewrite ret_bind; reflexivity. Qed. -Lemma seq_den_lift {A B C}: forall (ab: den A B) (g:B -> C), - eq_den (ab >=> lift_den g) (fun a => ITree.map g (ab a)). +Lemma cat_den_lift {A B C}: forall (ab: den A B) (g:B -> C), + eq_den (ab >=> lift_den g) + (fun a => ITree.map (sum_bimap g id) (ab a)). Proof. intros; intro a. + unfold cat_den. + unfold ITree.map. + apply eutt_bind. reflexivity. + intros []; reflexivity. Qed. -Lemma seq_den_assoc {A B C D} - (ab : den A B) (bc : den B C) (cd : den C D) : - eq_den ((ab >=> bc) >=> cd) - (ab >=> (bc >=> cd)). +(** *** [juxta] lemmas *) + +Lemma juxta_swap {A B C D} (ab : den A B) (cd : den C D) : + eq_den (juxta_den ab cd) + (lift_den sum_comm >=> juxta_den cd ab >=> lift_den sum_comm). Proof. - unfold seq_den; intro a. - rewrite bind_bind; reflexivity. + unfold juxta_den. + rewrite !(cat_den_lift cd), !(cat_den_lift ab), !lift_cat_den, !cat_den_lift. + intros []; cbn; rewrite map_map; cbn; + apply eutt_map; try intros []; reflexivity. Qed. -Instance eutt_seq_den {A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@seq_den A B C). +(* Unused but should go to FixFacts *) +Instance eutt_loop {E A B} : + Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@aloop E A B). +Proof. +Admitted. + +Instance eutt_loop' {E A B} : + Proper (eq_den ==> eq_den) (@aloop E A B). Proof. - intros ab ab' eqAB bc bc' eqBC. - intro a. - unfold seq_den. - rewrite (eqAB a). - apply eutt_bind; [reflexivity | intro b]. - rewrite (eqBC b); reflexivity. -Qed. +Admitted. -Instance Equivalence_eq_den {E A B} : Equivalence (@eq_den E A B). +Lemma juxta_id_lift {E A B C} (f : B -> C) : + eq_den (juxta_den (@id_den E A) (lift_den f)) + (lift_den (sum_bimap id f)). Proof. - split. - - intros ab a; reflexivity. - - intros ab ab' eqAB a; symmetry; auto. - - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. -Qed. +Admitted. + +Lemma juxta_lift_id {E A B C} (f : A -> B) : + eq_den (juxta_den (lift_den f) (@id_den E C)) + (lift_den (sum_bimap f id)). +Proof. +Admitted. + +Hint Rewrite @cat_den_assoc : lift_den. +Hint Rewrite @lift_den_lift_den : lift_den. +Hint Rewrite @cat_lift_den_l : lift_den. +Hint Rewrite @juxta_id_lift : lift_den. +Hint Rewrite @juxta_lift_id : lift_den. + +(** *** [sum_elim] lemmas *) + +Lemma cat_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : + eq_den (sum_elim ac bc >=> cd) + (sum_elim (ac >=> cd) (bc >=> cd)). +Proof. +Admitted. + +Opaque eutt. + +Lemma lift_sum_elim {E A B C} (ac : A -> C) (bc : B -> C) : + @eq_den E _ _ + (sum_elim (lift_den ac) (lift_den bc)) + (lift_den (sum_elim ac bc)). +Proof. intros []; reflexivity. Qed. + +Hint Rewrite @lift_sum_elim : lift_den. +Hint Rewrite @cat_lift_den : lift_den. + +(* Denotation of [rewire_b] *) +Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) + (ab : den A B) : den C D := + fun a => ITree.map (sum_map_l g) (ab (f a)). + +Notation rewire_den' f g ab := (lift_den f >=> ab >=> lift_den g)%den + (only parsing). Lemma unfold_rewire_den {A B C D} (f : C -> A) (g : B -> D) (ab : den A B) : eq_den (rewire_den f g ab) - (lift_den f >=> ab >=> lift_den g). + (rewire_den' f g ab). Proof. - rewrite lift_seq_den, seq_den_lift. + rewrite lift_cat_den, cat_den_lift. reflexivity. Qed. -Instance eq_lift_den {A B} : - Proper ((eq ==> eq) ==> eq_den) - (@lift_den A B). -Proof. - repeat intro. - unfold lift_den. - erewrite (H a); reflexivity. -Qed. - -Instance eutt_rewire_den {A B C D} : +Instance eq_den_rewire_den {A B C D} : Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq_den ==> eq_den) (@rewire_den A B C D). Proof. intros f f' eqf g g' eqg ab ab' eqAB. do 2 rewrite unfold_rewire_den. - rewrite eqf, eqg, eqAB; reflexivity. + rewrite eqf, eqg, eqAB; reflexivity. Qed. -(* Unused but should go to FixFacts *) -Instance eutt_loop {E A B} : - Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@aloop E A B). +Lemma seq_loop_l {I A B C} + (ab : den (I + A) (I + B)) (bc : den B C) : + eq_den (loop_den ab >=> bc) + (loop_den (rewire_den' (sum_assoc_r ∘ sum_bimap sum_comm id) + sum_comm + (juxta_den bc ab))). Proof. -Admitted. +Admitted. -Instance eutt_loop' {E A B} : - Proper (eq_den ==> eq_den) (@aloop E A B). +Lemma seq_loop_r {I A B C} + (ab : den A B) (bc : den (I + B) (I + C)) : + eq_den (ab >=> loop_den bc) + (loop_den (rewire_den' sum_comm + (sum_bimap sum_comm id ∘ sum_assoc_l) + (juxta_den ab bc))). +Proof. +Admitted. + +(* Should be a consequence of the others. *) +Lemma seq_loop_l_seq {A B C I} + (ab : den (I + A) (I + B)) (bc : den B C) : + eq_den (loop_den ab >=> bc) + (loop_den (ab >=> juxta_den id_den bc)). +Proof. +Admitted. + +(* Should be a consequence of the others *) +Lemma seq_loop_r_seq {A B C I} + (ab : den A B) (bc : den (I + B) (I + C)) : + eq_den (ab >=> loop_den bc) + (loop_den (juxta_den id_den ab >=> bc)). +Proof. +Admitted. + +(* [loop_loop]: + +These two loops: + +[[ + +----------+ + | +-----+ | + | | ### | | + | +-###-+I | + +---###----+J + A-----###-------B + ### +]] + +... can be rewired as a single one: + + +[[ + +-------+ + | ### | + +--###--+(I+J) + +--###--+ + A-----###-----B + ### +]] + +*) +Lemma loop_loop {I J A B} + (ab : den (I + (J + A)) (I + (J + B))) : + eq_den (loop_den (loop_den ab)) + (loop_den (rewire_den' sum_assoc_r sum_assoc_l ab)). Proof. Admitted. -Lemma seq_loop_l {A B C} - (ab : den A (A + B)) (bc : den B C) : - eq_den (aloop ab >=> bc) - (lift_den inl >=> aloop (den_sum_bimap ab bc)). +Lemma juxta_den_loop {I A B C D} + (ab : den (I + A) (I + B)) (cd : den C D) : + eq_den (juxta_den (loop_den ab) cd) + (loop_den (rewire_den' sum_assoc_l sum_assoc_r + (juxta_den ab cd))). Proof. Admitted. -Lemma seq_loop_l_seq {A B C} - (ab : den A (A + B)) (bc : den B C) : - eq_den (aloop ab >=> bc) - (aloop (ab >=> den_sum_map_r bc)). +Lemma loop_relabel {I J A B} + (f : I -> J) {f' : J -> I} + {ISO_f : Iso f f'} + (ab : den (I + A) (I + B)) : + eq_den (loop_den ab) + (loop_den (rewire_den' (sum_bimap f' id) (sum_bimap f id) ab)). Proof. Admitted. +(**) + +Definition cat_b {A B C D}: + (bks A B) -> + (bks C D) -> + (bks (A + C) (B + D)) := + fun ab cd oac => + match oac with + | inl a => fmap_block inl (ab a) + | inr c => fmap_block inr (cd c) + end. + +Definition rewire_b {A B C D}: + (C -> A) -> + (B -> D) -> + (bks A B) -> + (bks C D) := + fun f g ab c => + fmap_block g (ab (f c)). + (* Correctness of [cat_b] and [rewire_b] (easy) YZ: Those depend on the implementation. Should they be assumed by the theory? *) Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : - eq_den (denote_b (cat_b ab cd)) (cat_den (denote_b ab) (denote_b cd)). + eq_den (denote_b E0 (cat_b ab cd)) + (juxta_den (denote_b _ ab) (denote_b E0 cd)). Admitted. Lemma rewire_correct {A B C D} (f : C -> A) (g : B -> D) (ab : bks A B) : - eq_den (denote_b (rewire_b f g ab)) (rewire_den f g (denote_b ab)). + eq_den (denote_b _ (rewire_b f g ab)) + (rewire_den' f g (denote_b _ ab)). Admitted. Opaque compose. Opaque id. Opaque sum_elim. -Definition rw {A I B J C} : ((A + I) + B) + ((B + J) + C) -> - ((A + (I + (B + J))) + C) := +Definition rw {I B J C} : + (I + B) + (J + C) -> (I + J + B) + C := + Eval compute in resum. + +Definition corw {A I B J} : (I + J + B) + A -> (I + A) + (J + B) := Eval compute in resum. Transparent compose. Transparent id. Transparent sum_elim. -Definition corw {A I B J} : (A + (I + (B + J))) -> (A + I) + (B + J) := - sum_assoc_l. (* Sequential composition of bks. *) Definition seq_bks {A I B J C} - (ab : bks (A + I) ((A + I) + B)) - (bc : bks (B + J) ((B + J) + C)) : - bks (A + (I + (B + J))) ((A + (I + (B + J))) + C) := + (ab : bks (I + A) (I + B)) + (bc : bks (J + B) (J + C)) : + bks ((I + J + B) + A) ((I + J + B) + C) := rewire_b corw rw (cat_b ab bc). (* Sequential composition of asm. *) Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := {| code := seq_bks (code ab) (code bc) |}. -(* -Lemma seq_loop_r {A B C} - (ab : den A B) (bc : den B (B + C)) : - eq_den (ab >=> loop bc) - (loop ( -*) - -Instance eutt_elim {E A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@sum_elim A B (itree E C)). -Proof. - repeat intro. destruct a; unfold sum_elim; auto. -Qed. - -(* - -loop_loop (f : A -> B) (box : den B (B + (A + C))): - -These two loops (where wires represent jumps): - - +------------+ - | +-----+ | - | | ### | | - | f-+-###-+B | - A--+-+ ###----+A - ###-------C - ### - -Can be rewired as: - - +---------+ - | ### | - +-+-###--+--+B - A----+f ###--+f <- A - ###------C - ### - -*) -Lemma loop_loop {A B C} - (f : A -> B) (bc : den B (B + (A + C))) : - eq_den (aloop (lift_den f >=> aloop bc)) - (lift_den f - >=> aloop (bc >=> lift_den (sum_elim inl (sum_elim (inl ∘ f) inr)))). -Proof. -Admitted. - -Lemma sum_elim_loop {A B C BD} - (f : B -> BD) - (ac : den A C) (bc : den BD (BD + C)) : - eq_den (sum_elim ac - (lift_den f >=> aloop bc)) - (lift_den (sum_map_r f) - >=> aloop (sum_elim (ac >=> lift_den inr) - (bc >=> lift_den (sum_map_l inr)))). -Proof. -Admitted. - -Lemma loop_relabel {A B C} - (f : A -> B) {f' : B -> A} - {ISO_f : Iso f f'} - (ac : den A (A + C)) : - eq_den (aloop ac) - (lift_den f >=> aloop (lift_den f' >=> ac >=> lift_den (sum_map_l f))). -Proof. -Admitted. - -Lemma seq_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : - eq_den (sum_elim ac bc >=> cd) - (sum_elim (ac >=> cd) (bc >=> cd)). -Proof. -Admitted. - -Opaque eutt. - -Lemma lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : - eq_den (sum_elim (lift_den ac) (lift_den bc)) - (lift_den (sum_elim ac bc)). -Proof. intros []; reflexivity. Qed. - -Hint Rewrite @lift_sum_elim : lift_den. -Hint Rewrite @seq_lift_den : lift_den. - Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : - eq_den (denote_asm (seq_asm ab bc)) - (seq_den (denote_asm ab) (denote_asm bc)). + @eq_den E0 _ _ + (denote_asm (seq_asm ab bc)) + (cat_den (denote_asm ab) (denote_asm bc)). Proof. unfold denote_asm, seq_asm; simpl. unfold seq_bks. rewrite rewire_correct. rewrite cat_correct. - unfold cat_den. - rewrite unfold_rewire_den. - rewrite (seq_den_assoc (_ inl)). rewrite seq_loop_l. - rewrite lift_den_assoc, seq_lift_den. - unfold den_sum_bimap. - rewrite (seq_den_assoc (_ inl)). + rewrite juxta_den_loop. + rewrite seq_loop_r_seq. rewrite seq_loop_l_seq. - unfold den_sum_map_r. - rewrite sum_elim_loop. rewrite loop_loop. - rewrite lift_den_assoc, seq_lift_den. - rewrite (loop_relabel sum_assoc_r). - repeat (rewrite seq_lift_den + rewrite <- (seq_den_assoc (lift_den _) (lift_den _))). - apply eutt_seq_den. - { apply eq_lift_den. - cbv; congruence. } - apply eutt_loop'. - unfold corw. - repeat rewrite seq_den_assoc + rewrite seq_lift_den. - eapply eutt_seq_den. - { reflexivity. } - repeat rewrite seq_sum_elim. - repeat rewrite seq_den_assoc + rewrite seq_lift_den. - unfold sum_map_r, sum_map_l, sum_bimap. - rewrite unfold_sum_assoc_r. - unfold rw. - autorewrite with cat. - repeat rewrite compose_assoc. - autorewrite with sum_elim. + rewrite (juxta_swap (_ (code bc))). + rewrite (loop_relabel (sum_bimap sum_comm id ∘ sum_assoc_l)). autorewrite with lift_den. - eapply eutt_elim. - - eapply eutt_seq_den. - + reflexivity. - + eapply eq_lift_den. - intros a ? []. destruct a as [[] | ]; auto. - - eapply eutt_seq_den. + (* Now everything matches except [lift_den] *) + apply eq_den_loop. + apply eq_den_cat. + - apply eq_lift_den. + intros [[[] | ] | ] ? []; auto. + - apply eq_den_cat. + reflexivity. - + eapply eq_lift_den. - intros a ? []; destruct a as [[] | ]; auto. + + apply eq_lift_den. + intros [[] | [] ] ? []; auto. Qed. diff --git a/examples/sum.v b/examples/sum.v index d2e4b2b5..f47a8fca 100644 --- a/examples/sum.v +++ b/examples/sum.v @@ -2,6 +2,8 @@ From Coq Require Import Morphisms Program. +Set Universe Polymorphism. + (* TODO: Move this in the library *) (** * The Category of Functions *) @@ -144,6 +146,9 @@ Class Iso {A B} (f : A -> B) (f' : B -> A) : Type := iso_f'f : forall b, f (f' b) = b; }. +Instance Iso_id {A} : Iso (@id A) id := {}. +Proof. all: auto. Qed. + Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. Proof. - destruct 0 as [| []]; auto. @@ -156,3 +161,20 @@ Proof. - destruct 0 as [| []]; auto. Qed. +Instance Iso_compose {A B C} (f : A -> B) (g : B -> C) + {f' : B -> A} `{Iso _ _ f f'} + {g' : C -> B} `{Iso _ _ g g'} : Iso (compose g f) (compose f' g') := {}. +Proof. + all: intro a; cbv; rewrite ?iso_ff', ?iso_f'f; auto. +Qed. + +Instance Iso_sum_comm {A B} : @Iso (A + B) _ sum_comm sum_comm := {}. +Proof. all: intros []; auto. Qed. + +Instance Iso_sum_bimap {A B C D} (f : A -> B) (g : C -> D) + {f' : B -> A} `{Iso _ _ f f'} + {g' : D -> C} `{Iso _ _ g g'} : + Iso (sum_bimap f g) (sum_bimap f' g') := {}. +Proof. + all: intros []; cbv; rewrite ?iso_ff', ?iso_f'f; auto. +Qed. diff --git a/theories/Core.v b/theories/Core.v index f00bd104..e7517827 100644 --- a/theories/Core.v +++ b/theories/Core.v @@ -123,6 +123,11 @@ Definition bind {E T U} : itree E U := bind' k c. +Definition cat {E T U V} + (k : T -> itree E U) (h : U -> itree E V) : + T -> itree E V := + fun t => bind (k t) h. + (* note(gmm): There needs to be generic automation for monads to simplify * using the monad laws up to a setoid. * this would be *really* useful to a lot of projects. @@ -176,6 +181,7 @@ Notation "t1 ;; t2" := (ITree.bind t1 (fun _ => t2)) Notation "' p <- t1 ;; t2" := (ITree.bind t1 (fun x_ => match x_ with p => t2 end)) (at level 100, t1 at next level, p pattern, right associativity) : itree_scope. +Infix ">=>" := ITree.cat (at level 50, left associativity) : itree_scope. Instance Functor_itree {E} : Functor (itree E) := { fmap := @ITree.map E }. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index be33e1f1..7a0fee61 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -233,3 +233,10 @@ Lemma bind_loop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) | inr b => ITree.map (sum_map1 inr) (g b) end) (inl x). Admitted. + +Instance eutt_loop {E A B C} : + Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B C). +Proof. + repeat intro. + subst. +Admitted. From 42a2dc4b86f2a6d4c8cc54e15cd2538d536e2fb2 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 08:48:07 -0500 Subject: [PATCH 049/142] Fix stlc example --- examples/stlc.v | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/examples/stlc.v b/examples/stlc.v index 545e1964..685e71b0 100644 --- a/examples/stlc.v +++ b/examples/stlc.v @@ -59,17 +59,16 @@ Fixpoint subst (n : nat) (s t : term) := (* big-step call-by-value *) Definition big_step : term -> itree emptyE value := - mfix (fun _ => value) - (fun _ lift big_step t => + rec (fun t => match t with | Var n => ret (VHead (VVar n)) | App t1 t2 => - t2' <- big_step t2;; - t1' <- big_step t1;; + t2' <- lift (Call t2);; + t1' <- lift (Call t1);; match t1' with | VHead hv => ret (VHead (VApp hv t2')) | VLam t1'' => - big_step (subst O (to_term t2') t1'') + lift (Call (subst O (to_term t2') t1'')) end | Lam t => ret (VLam t) end). From 3e5fe0f33293e615d1073d7f9153593d1004b583 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Thu, 21 Feb 2019 21:50:00 -0500 Subject: [PATCH 050/142] interp_interp --- theories/MorphismsFacts.v | 88 +++++++++++++++++++-------------------- 1 file changed, 43 insertions(+), 45 deletions(-) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 95600e52..c74a18e9 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -141,56 +141,54 @@ Qed. Lemma interp_id_liftE {E R} (t : itree E R) : interp (fun _ e => ITree.liftE e) _ t ≈ t. Proof. -Admitted. - -Inductive interp_inv0 {E F R} - (ff : itree E ~> itree F) (gg : itree E ~> itree F) : - relation (itree F R) := -| interp_inv_main t : interp_inv0 ff gg (ff _ t) (gg _ t) -| interp_inv_bind u t (k: u -> _) : - interp_inv0 ff gg - (ITree.bind t (fun x => ff _ (k x))) - (ITree.bind t (fun x => gg _ (k x))) -. -Hint Constructors interp_inv0. - -Inductive iinv {E F R} (ff gg : itree E ~> itree F) (t1 t2 : itree F R) : Prop := -| iinv_intros t1' t2' : - t1 ≈ t1' -> - t2 ≈ t2' -> - interp_inv0 ff gg t1' t2' -> - iinv ff gg t1 t2 -. -Hint Constructors iinv. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite unfold_interp. unfold interp_u. unfold handleF. + rewrite eutt_is_eutt'_gres. + pfold. revert t. pcofix CIH'. + intros t. + destruct (observe t); cbn. + - pfold. econstructor. + - pfold. econstructor. + right. rewrite interp_unfold. unfold interp_u. unfold handleF. + apply CIH'. + - pfold. econstructor. cbn. econstructor. intros. + assert (ITree.bind' (fun x0 : u => interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0)) (Ret x) = (x0 <- Ret x ;; interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0))). + { intros; reflexivity. } + rewrite H. + rewrite ret_bind. + pupto2_final. right. apply CIH. +Qed. -Polymorphic Definition II_MAIN_STEP {E F R} (ff gg : itree E ~> itree F) : - Prop := - forall (t : itree _ R), - euttF' (iinv ff gg) (fun x y => iinv ff gg (go x) (go y)) - (observe (ff _ t)) (observe (gg _ t)). Theorem interp_interp {E F G R} (f : E ~> itree F) (g : F ~> itree G) : forall t : itree E R, interp g _ (interp f _ t) - ≈ interp (fun _ e => interp g _ (f _ e)) _ t. -Proof. - intros. - assert (H : @II_MAIN_STEP _ _ R - (fun _ t => interp g _ (interp f _ t)) - (fun _ t => interp (fun _ e => interp g _ (f _ e)) _ t)). - { red; intros. repeat rewrite interp_unfold; cbn. - destruct (observe t0); cbn. - - constructor. - - constructor. econstructor; - try eapply interp_inv_main; - (rewrite <- itree_eta; reflexivity). - - constructor. econstructor; - try eapply interp_inv_bind; - (rewrite <- itree_eta; try reflexivity). - rewrite interp_bind; reflexivity. } - eapply eutt_is_eutt'. -Admitted. - + ≅ interp (fun _ e => interp g _ (f _ e)) _ t. +Proof. + intros t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta t). + rewrite (itree_eta (interp (fun (T : Type) (e : E T) => interp g T (f T e)) R {| _observe := observe t|})). + rewrite unfold_interp. + destruct (observe t); cbn. + - pupto2_final. pfold. econstructor. reflexivity. + - pupto2_final. pfold. econstructor. right. apply CIH. + - rewrite interp_bind. + pfold. econstructor. + pupto2 eq_itree_clo_bind_h. + apply pbc_intro_h with (RU := eq). + + reflexivity. + + intros. + pupto2_final. right. subst. apply CIH. +Qed. + (** * [interp1] *) (* SAZ: If we need to introduce these auxilliar definitions to prove From 06c6b5d7fd4305a04796ab9b29124ab8017d78ca Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Thu, 21 Feb 2019 22:25:07 -0500 Subject: [PATCH 051/142] some more morphism facts --- theories/MorphismsFacts.v | 62 +++++++++++++++++++++++++++++++++------ 1 file changed, 53 insertions(+), 9 deletions(-) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index c74a18e9..9765d76d 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -500,20 +500,50 @@ Proof. Qed. -(* Commuting interpreters *) +(* Translate facts ---------------------------------------------------------- *) -Lemma interp_translate {E F G} (f : E ~> F) (g : F ~> itree G) {R} (t : itree E R) : - interp g _ (translate f _ t) ≅ interp (fun _ e => g _ (f _ e)) _ t. -Proof. -Admitted. +Definition translate_u {E F} (h : E ~> F) R : + itreeF E R _ -> itree F R := + handleF (translate h _) + (fun _ e k => Vis (h _ e) (fun x => translate h _ (k x))). + +Lemma translate_unfold {E F R} {h : E ~> F} (t : itree E R) : + observe (translate h _ t) = observe (translate_u h _ (observe t)). +Proof. eauto. Qed. +Lemma unfold_translate {E F R} {h : E ~> F} (t : itree E R) : + translate h _ t ≅ translate_u h _ (observe t). +Proof. rewrite itree_eta, translate_unfold, <-itree_eta. reflexivity. Qed. -(* Translate facts ---------------------------------------------------------- *) Instance translate_Proper : forall {A B R} (h : A ~> B), Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h _). Proof. -Admitted. - + repeat red. + intros A B R h x y H. + pupto2_init. + revert x y H. + pcofix CIH. + intros x y H. + rewrite itree_eta. + rewrite (itree_eta (translate h R y)). + repeat rewrite translate_unfold. unfold translate_u. + rewrite (itree_eta x) in H. + rewrite (itree_eta y) in H. + destruct (observe x); destruct (observe y); pinversion H; subst; cbn. + - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution not working *) + - pupto2_final. pfold. constructor. right. apply CIH. eauto. + - pupto2_final. pfold. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + constructor. + inversion H. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + right. apply CIH. + eapply transitivity. pclearbot. apply REL0. reflexivity. +Qed. Lemma translate_ret : forall {A B R} (h : A ~> B) (r:R), translate h _ (Ret r) ≅ Ret r. @@ -538,7 +568,21 @@ Proof. rewrite itree_eta. cbn. reflexivity. Qed. - + +(* Commuting interpreters --------------------------------------------------- *) + +Lemma interp_translate {E F G} (f : E ~> F) (g : F ~> itree G) {R} (t : itree E R) : + interp g _ (translate f _ t) ≅ interp (fun _ e => g _ (f _ e)) _ t. +Proof. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite (itree_eta). + rewrite (itree_eta (interp (fun (T : Type) (e : E T) => g T (f T e)) R t)). + rewrite !unfold_interp. unfold interp_u. +Admitted. + (* Morphism Category -------------------------------------------------------- *) Definition eh_eq {A B : Type -> Type} f g := forall X, pointwise_relation (A X) (@eutt B X _ (@eq X)) (f X) (g X). From 2451db5643def92f71168b3b198bfb4a6ff5346c Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 18:27:18 -0500 Subject: [PATCH 052/142] Simplify definition of loop --- theories/Fix.v | 29 ++++++++++++++++++----------- theories/FixFacts.v | 28 ++++++++++++++++------------ 2 files changed, 34 insertions(+), 23 deletions(-) diff --git a/theories/Fix.v b/theories/Fix.v index b3612c91..85aa08b6 100644 --- a/theories/Fix.v +++ b/theories/Fix.v @@ -114,15 +114,22 @@ Definition rec {E : Type -> Type} {A B : Type} A -> itree E B := fun a => mrec (calling' body) _ (Call a). -(* Iterate a function updating an accumulator [C], - until it produces an output [B]. *) +(** Iterate a function updating an accumulator [C], + until it produces an output [B]. An encoding of tail recursive + functions. + + The Kleisli category for the [itree] monad is a traced + monoidal category, with [loop] as its trace. + *) +(* We use explicit recursion instead of relying on [rec] to + make the definition properly tail recursive. *) Definition loop {E : Type -> Type} {A B C : Type} (body : (C + A) -> itree E (C + B)) : A -> itree E B := - rec (fun a => - bc <- translate (fun _ x => inr1 x) _ (body a) ;; - match bc with - | inl c => ITree.liftE (inl1 (Call a)) + (cofix loop_ ca := + cb <- body ca ;; + match cb with + | inl c => Tau (loop_ (inl c)) | inr b => Ret b end) ∘ inr. @@ -132,9 +139,9 @@ Definition loop {E : Type -> Type} {A B C : Type} Definition aloop {E : Type -> Type} {A B : Type} (body : A -> itree E (A + B)) : A -> itree E B := - rec (fun a => - ac <- translate (fun _ x => inr1 x) _ (body a) ;; - match ac with - | inl a => ITree.liftE (inl1 (Call a)) + cofix aloop_ a := + ab <- body a ;; + match ab with + | inl a => Tau (aloop_ a) | inr b => Ret b - end). + end. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 7a0fee61..ff038023 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -197,6 +197,18 @@ Proof. reflexivity. Qed. +Lemma loop_unfold' {E A B} (f : A -> itree E (A + B)) (x : A) : + aloop f x + ≅ (ab <- f x ;; + match ab with + | inl a => Tau (aloop f a) + | inr b => Ret b + end). +Proof. + rewrite (itree_eta (aloop _ _)), (itree_eta (ITree.bind _ _)). + reflexivity. +Qed. + Lemma loop_unfold {E A B} (f : A -> itree E (A + B)) (x : A) : aloop f x ≈ (ab <- f x ;; @@ -205,18 +217,10 @@ Lemma loop_unfold {E A B} (f : A -> itree E (A + B)) (x : A) : | inr b => Ret b end). Proof. - unfold aloop at 1. - rewrite rec_unfold. - rewrite interp_bind. - rewrite interp_translate. - rewrite interp_id_liftE. - eapply eutt_bind; [ reflexivity |]. - intros [a | b]. - - rewrite interp_liftE; cbn. - rewrite tau_eutt. - reflexivity. - - rewrite ret_interp. - reflexivity. + rewrite loop_unfold'. + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + apply tau_eutt. Qed. Definition sum_map1 {A B C} (f : A -> B) (ac : A + C) : B + C := From 9425a50d64109480ed319b5f30c877dd6e93ffeb Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 19:15:21 -0500 Subject: [PATCH 053/142] Move sum to theories/Basics_Functions.v --- _CoqConfig | 1 + examples/sum.v => theories/Basics_Functions.v | 57 ++++++++++--------- 2 files changed, 31 insertions(+), 27 deletions(-) rename examples/sum.v => theories/Basics_Functions.v (82%) diff --git a/_CoqConfig b/_CoqConfig index 7f760de9..9c90ec9c 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -1,6 +1,7 @@ -Q theories ITree theories/Basics.v +theories/Basics_Functions.v theories/Core.v theories/Eq/Eq.v diff --git a/examples/sum.v b/theories/Basics_Functions.v similarity index 82% rename from examples/sum.v rename to theories/Basics_Functions.v index f47a8fca..60e7f1e7 100644 --- a/examples/sum.v +++ b/theories/Basics_Functions.v @@ -1,14 +1,21 @@ +(** * The Category of Functions + + Definitions to reason about Coq functions [A -> B] categorically. + + *) + +(* begin hide *) From Coq Require Import Morphisms - Program. + Program.Basics + Program.Combinators. Set Universe Polymorphism. +(* end hide *) -(* TODO: Move this in the library *) - -(** * The Category of Functions *) +(* From [Program.Basics] and [Program.Combinators]: -(* id : A -> A + id : A -> A (* This one is from [Init.Datatypes] *) compose : (B -> C) -> (A -> B) -> (A -> C) Infix "∘" = compose @@ -17,24 +24,22 @@ Set Universe Polymorphism. compose_assoc : (f ∘ g) ∘ h = f ∘ (g ∘ h) *) -Hint Rewrite @compose_id_left : cat. -Hint Rewrite @compose_id_right : cat. - (** Extensional function equality *) -Definition eqeq {A B} := (@eq A ==> @eq B)%signature. +Definition eeq {A B} : (A -> B) -> (A -> B) -> Prop := + fun f g => forall a : A, f a = g a. -Instance Equivalence_eqeq {A B} : Equivalence (@eqeq A B). -Proof. - constructor; cbv; intros; subst; auto. - - symmetry; auto. - - etransitivity; auto. -Qed. +Instance subrelation_eeq_eqeq {A B} : + @subrelation (A -> B) eeq (@eq A ==> @eq B)%signature := {}. +Proof. congruence. Qed. + +Instance Equivalence_eeq {A B} : Equivalence (@eeq A B). +Proof. constructor; congruence. Qed. Instance eq_compose {A B C} : - Proper (eqeq ==> eqeq ==> eqeq) (@compose A B C). -Proof. cbv; auto. Qed. + Proper (eeq ==> eeq ==> eeq) (@compose A B C). +Proof. cbv; congruence. Qed. -(** * Diagramatic/categorical sum combinators. *) +(** * [sum] as a tensor product. *) Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := fun x => @@ -60,9 +65,6 @@ Definition sum_assoc_r {A B C} (abc : (A + B) + C) : A + (B + C) := | inr c => inr (inr c) end. -Definition sum_comm {A B} : A + B -> B + A := - sum_elim inr inl. - Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := match abc with | inl a => inl (inl a) @@ -70,16 +72,17 @@ Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := | inr (inr c) => inr c end. +Definition sum_comm {A B} : A + B -> B + A := + sum_elim inr inl. + Definition sum_merge {A} : A + A -> A := sum_elim id id. (** ** Equational theory *) Lemma compose_sum_elim {A B C D} (ac : A -> C) (bc : B -> C) (cd : C -> D) : - eqeq (cd ∘ sum_elim ac bc) + eeq (cd ∘ sum_elim ac bc) (sum_elim (cd ∘ ac) (cd ∘ bc)). -Proof. - intros [] ? []; auto. -Qed. +Proof. intros []; auto. Qed. Lemma sum_elim_inl {A B C} (f : A -> C) (g : B -> C) : sum_elim f g ∘ inl = f. @@ -101,8 +104,8 @@ Lemma unfold_sum_assoc_r {A B C} : @sum_assoc_r A B C = sum_elim (sum_elim inl (inr ∘ inl)) (inr ∘ inr). Proof. cbv; auto. Qed. -Instance eqeq_sum_elim {A B C} : - Proper (eqeq ==> eqeq ==> eqeq) (@sum_elim A B C). +Instance eeq_sum_elim {A B C} : + Proper (eeq ==> eeq ==> eeq) (@sum_elim A B C). Proof. cbv; intros; subst; destruct _; auto. Qed. Hint Rewrite @sum_elim_inl : sum_elim. From bb8dbc8433822171434566c5600a3a02153689b9 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 19:59:56 -0500 Subject: [PATCH 054/142] State loop equations for traced monoidal category --- theories/Basics_Functions.v | 12 ++++++ theories/Eq/Eq.v | 42 ++++++++++++++++++++ theories/FixFacts.v | 79 ++++++++++++++++++++++++++++++++++++- 3 files changed, 132 insertions(+), 1 deletion(-) diff --git a/theories/Basics_Functions.v b/theories/Basics_Functions.v index 60e7f1e7..1a5954e3 100644 --- a/theories/Basics_Functions.v +++ b/theories/Basics_Functions.v @@ -39,6 +39,12 @@ Instance eq_compose {A B C} : Proper (eeq ==> eeq ==> eeq) (@compose A B C). Proof. cbv; congruence. Qed. +(** * [Empty_set] as an initial object. *) + +Notation from_Empty_set := + (fun v : Empty_set => match v with end) + (only parsing). + (** * [sum] as a tensor product. *) Definition sum_elim {A B C} (f : A -> C) (g : B -> C) : A + B -> C := @@ -75,6 +81,12 @@ Definition sum_assoc_l {A B C} (abc : A + (B + C)) : (A + B) + C := Definition sum_comm {A B} : A + B -> B + A := sum_elim inr inl. +Definition sum_empty_l {A} : Empty_set + A -> A := + sum_elim from_Empty_set id. + +Definition sum_empty_r {A} : A + Empty_set -> A := + sum_elim id from_Empty_set. + Definition sum_merge {A} : A + A -> A := sum_elim id id. (** ** Equational theory *) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index bd38e0e9..96c90c09 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -259,6 +259,48 @@ Arguments eq_itree_clo_trans : clear implicits. Hint Constructors eq_itree_trans_clo. +Lemma eq_itree_tau {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + eq_itree RR t1 t2 -> eq_itree RR (Tau t1) (Tau t2). +Proof. + intros; pfold; constructor; auto. +Qed. + +Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + (forall u, eq_itree RR (k1 u) (k2 u)) -> + eq_itree RR (Vis e k1) (Vis e k2). +Proof. + intros; pfold; constructor; left. apply H. +Qed. + +Lemma eq_itree_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + RR r1 r2 -> @eq_itree E _ _ RR (Ret r1) (Ret r2). +Proof. + intros; pfold; eauto; constructor; auto. +Qed. + +Lemma eq_itree_tau_inv {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + eq_itree RR (Tau t1) (Tau t2) -> eq_itree RR t1 t2. +Proof. + intros H; punfold H; inversion H; pclearbot; auto. +Qed. + +Lemma eq_itree_vis_inv {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + eq_itree RR (Vis e k1) (Vis e k2) -> + (forall u, eq_itree RR (k1 u) (k2 u)). +Proof. + intros H; punfold H; inversion H; pclearbot; auto_inj_pair2; subst; auto. +Qed. + +Lemma eq_itree_ret_inv {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + @eq_itree E _ _ RR (Ret r1) (Ret r2) -> RR r1 r2. +Proof. + intros H; punfold H; inversion H; pclearbot; auto_inj_pair2; subst; auto. +Qed. + Lemma bind_unfold {E R S} (t : itree E R) (k : R -> itree E S) : observe (ITree.bind t k) = observe (ITree.bind_match k (ITree.bind' k) (observe t)). diff --git a/theories/FixFacts.v b/theories/FixFacts.v index ff038023..0922658e 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -11,6 +11,7 @@ From Coq Require Import From ITree Require Import Basics + Basics_Functions Core Morphisms MorphismsFacts @@ -223,13 +224,89 @@ Proof. apply tau_eutt. Qed. +(* Equations for a traced monoidal category *) + +Lemma loop_natural_l {E A A' B C} (f : A -> itree E A') + (body : C + A' -> itree E (C + B)) (a : A) : + ITree.bind (f a) (loop body) + ≅ loop (fun ca => + match ca with + | inl c => Ret (inl c) + | inr a => ITree.map inr (f a) + end >>= body) a. +Admitted. + +Lemma loop_natural_r {E A B B' C} (f : B -> itree E B') + (body : C + A -> itree E (C + B)) (a : A) : + loop body a >>= f + ≅ loop (fun ca => body ca >>= fun cb => + match cb with + | inl c => Ret (inl c) + | inr b => ITree.map inr (f b) + end) a. +Admitted. + +Lemma loop_dinatural {E A B C C'} (f : C -> itree E C') + (body : C' + A -> itree E (C + B)) (a : A) : + loop (fun c'a => body c'a >>= fun cb => + match cb with + | inl c => ITree.map inl (f c) + | inr b => Ret (inr b) + end) a + ≅ loop (fun ca => + match ca with + | inl c => ITree.map inl (f c) + | inr a => Ret (inr a) + end >>= body) a. +Admitted. + +Lemma vanishing1 {E A B} (f : Empty_set + A -> itree E (Empty_set + B)) + (a : A) : + loop f a ≅ ITree.map sum_empty_l (f (inr a)). +Admitted. + +Lemma vanishing2 {E A B C D} (f : D + (C + A) -> itree E (D + (C + B))) + (a : A) : + loop (loop f) a + ≅ loop (fun dca => ITree.map sum_assoc_l (f (sum_assoc_r dca))) a. +Admitted. + +Lemma superposing1 {E A B C D D'} (f : C + A -> itree E (C + B)) + (g : D -> itree E D') (a : A) : + ITree.map inl (loop f a) + ≅ loop (fun cad => + match cad with + | inl c => ITree.map (sum_bimap id inl) (f (inl c)) + | inr (inl a) => ITree.map (sum_bimap id inl) (f (inr a)) + | inr (inr d) => ITree.map (inr ∘ inr) (g d) + end) (inl a). +Admitted. + +Lemma superposing2 {E A B C D D'} (f : C + A -> itree E (C + B)) + (g : D -> itree E D') (d : D) : + ITree.map inr (g d) + ≅ loop (fun cad => + match cad with + | inl c => ITree.map (sum_bimap id inl) (f (inl c)) + | inr (inl a) => ITree.map (sum_bimap id inl) (f (inr a)) + | inr (inr d) => ITree.map (inr ∘ inr) (g d) + end) (inr d). +Admitted. + +Lemma yanking {E A} (a : A) : + @loop E _ _ _ (fun aa => Ret (sum_comm aa)) a ≅ Tau (Ret a). +Proof. + rewrite itree_eta; cbn; apply eq_itree_tau. + rewrite itree_eta; reflexivity. +Qed. + Definition sum_map1 {A B C} (f : A -> B) (ac : A + C) : B + C := match ac with | inl a => inl (f a) | inr c => inr c end. -Lemma bind_loop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) (x : A) : +Lemma bind_aloop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) (x : A) : (aloop f x >>= aloop g) ≈ aloop (fun ab => match ab with From 3496b7b2b9cc15344fa763488e2d54b859028557 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 21:43:56 -0500 Subject: [PATCH 055/142] Prove a few of the loop lemmas --- theories/Fix.v | 22 +++++++++---- theories/FixFacts.v | 75 ++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 83 insertions(+), 14 deletions(-) diff --git a/theories/Fix.v b/theories/Fix.v index 85aa08b6..76be8254 100644 --- a/theories/Fix.v +++ b/theories/Fix.v @@ -114,6 +114,21 @@ Definition rec {E : Type -> Type} {A B : Type} A -> itree E B := fun a => mrec (calling' body) _ (Call a). +Definition loop_once {E : Type -> Type} {A B C : Type} + (body : C + A -> itree E (C + B)) + (loop_ : C + A -> itree E B) : C + A -> itree E B := + fun ca => + cb <- body ca ;; + match cb with + | inl c => loop_ (inl c) + | inr b => Ret b + end. + +Definition loop_ {E : Type -> Type} {A B C : Type} + (body : C + A -> itree E (C + B)) : + C + A -> itree E B := + cofix loop__ := loop_once body (fun cb => Tau (loop__ cb)). + (** Iterate a function updating an accumulator [C], until it produces an output [B]. An encoding of tail recursive functions. @@ -126,12 +141,7 @@ Definition rec {E : Type -> Type} {A B : Type} Definition loop {E : Type -> Type} {A B C : Type} (body : (C + A) -> itree E (C + B)) : A -> itree E B := - (cofix loop_ ca := - cb <- body ca ;; - match cb with - | inl c => Tau (loop_ (inl c)) - | inr b => Ret b - end) ∘ inr. + fun a => loop_ body (inr a). (* Iterate a function updating an accumulator [A], until it produces an output [B]. It's an Asymmetric variant of [loop], and it looks diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 0922658e..4843f0a4 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -198,7 +198,28 @@ Proof. reflexivity. Qed. -Lemma loop_unfold' {E A B} (f : A -> itree E (A + B)) (x : A) : +Notation loop_once_ f loop_ := + (loop_once f (fun cb => Tau (loop_ f%function cb))). + +Lemma unfold_loop' {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : + loop_ f x + ≅ loop_once f (fun cb => Tau (loop_ f cb)) x. +Proof. + rewrite itree_eta, (itree_eta (loop_once _ _ _)). + reflexivity. +Qed. + +Lemma unfold_loop {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : + loop_ f x + ≈ loop_once f (loop_ f) x. +Proof. + rewrite unfold_loop'. + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + rewrite tau_eutt; reflexivity. +Qed. + +Lemma unfold_aloop' {E A B} (f : A -> itree E (A + B)) (x : A) : aloop f x ≅ (ab <- f x ;; match ab with @@ -210,7 +231,7 @@ Proof. reflexivity. Qed. -Lemma loop_unfold {E A B} (f : A -> itree E (A + B)) (x : A) : +Lemma unfold_aloop {E A B} (f : A -> itree E (A + B)) (x : A) : aloop f x ≈ (ab <- f x ;; match ab with @@ -218,7 +239,7 @@ Lemma loop_unfold {E A B} (f : A -> itree E (A + B)) (x : A) : | inr b => Ret b end). Proof. - rewrite loop_unfold'. + rewrite unfold_aloop'. apply eutt_bind; try reflexivity. intros []; try reflexivity. apply tau_eutt. @@ -234,7 +255,26 @@ Lemma loop_natural_l {E A A' B C} (f : A -> itree E A') | inl c => Ret (inl c) | inr a => ITree.map inr (f a) end >>= body) a. -Admitted. +Proof. + unfold loop. + rewrite unfold_loop'; unfold loop_once. + unfold ITree.map. rewrite !bind_bind. + eapply eq_itree_bind; try reflexivity. + intros a' _ []. + rewrite ret_bind. + remember (inr a') as ca eqn:EQ; clear EQ a'. + pupto2_init. revert ca; clear; pcofix self; intro ca. + rewrite unfold_loop'; unfold loop_once. + pupto2 @eq_itree_clo_bind; constructor; try reflexivity. + intros [c | b]. + - match goal with + | [ |- _ _ (Tau (loop_ ?f _)) ] => rewrite (unfold_loop' f) + end. + unfold loop_once_. + rewrite ret_bind. + pfold; constructor; auto. + - pfold; constructor; auto. +Qed. Lemma loop_natural_r {E A B B' C} (f : B -> itree E B') (body : C + A -> itree E (C + B)) (a : A) : @@ -244,18 +284,32 @@ Lemma loop_natural_r {E A B B' C} (f : B -> itree E B') | inl c => Ret (inl c) | inr b => ITree.map inr (f b) end) a. -Admitted. +Proof. + unfold loop. + remember (inr a) as ca eqn:EQ; clear EQ a. + pupto2_init. revert ca; clear; pcofix self; intro ca. + rewrite !unfold_loop'; unfold loop_once. + rewrite !bind_bind. + pupto2 @eq_itree_clo_bind; constructor; try reflexivity. + intros [c | b]. + - rewrite ret_bind, tau_bind. + pfold; constructor; auto. + - rewrite ret_bind. + unfold ITree.map; rewrite bind_bind; setoid_rewrite ret_bind; + rewrite bind_ret. + pupto2_final; apply reflexivity. +Qed. Lemma loop_dinatural {E A B C C'} (f : C -> itree E C') (body : C' + A -> itree E (C + B)) (a : A) : loop (fun c'a => body c'a >>= fun cb => match cb with - | inl c => ITree.map inl (f c) + | inl c => Tau (ITree.map inl (f c)) | inr b => Ret (inr b) end) a ≅ loop (fun ca => match ca with - | inl c => ITree.map inl (f c) + | inl c => f c >>= fun c' => Tau (Ret (inl c')) | inr a => Ret (inr a) end >>= body) a. Admitted. @@ -263,7 +317,12 @@ Admitted. Lemma vanishing1 {E A B} (f : Empty_set + A -> itree E (Empty_set + B)) (a : A) : loop f a ≅ ITree.map sum_empty_l (f (inr a)). -Admitted. +Proof. + unfold loop. + rewrite unfold_loop'; unfold loop_once, ITree.map. + eapply eq_itree_bind; try reflexivity. + intros [[]| b] _ []; reflexivity. +Qed. Lemma vanishing2 {E A B C D} (f : D + (C + A) -> itree E (D + (C + B))) (a : A) : From fc836fbaa93eb95748af83af30684dbb4e46e545 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 21 Feb 2019 22:30:38 -0500 Subject: [PATCH 056/142] Prove all the loop lemmas --- theories/Eq/Eq.v | 23 ++++++++++ theories/FixFacts.v | 100 +++++++++++++++++++++++++++++++++++++++----- 2 files changed, 113 insertions(+), 10 deletions(-) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 96c90c09..b5e16876 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -387,6 +387,27 @@ Proof. intros; subst; auto. Qed. +Lemma eq_itree_map {E R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) + f1 f2 t1 t2 : + (forall r1 r2, RR r1 r2 -> RS (f1 r1) (f2 r2)) -> + @eq_itree E _ _ RR t1 t2 -> + eq_itree RS (ITree.map f1 t1) (ITree.map f2 t2). +Proof. + unfold ITree.map; intros. + eapply eq_itree_bind; eauto. + intros; pfold; constructor; auto. +Qed. + +Instance eq_itree_eq_map {E R S} : + Proper (pointwise_relation _ eq ==> + eq_itree eq ==> + eq_itree eq) (@ITree.map E R S). +Proof. + repeat intro; eapply eq_itree_map; eauto. + intros; subst; auto. +Qed. + Instance eq_itree_paco {E R} r: Proper (eq_itree eq ==> eq_itree eq ==> flip impl) (paco2 (@eq_itree_ E R _ eq ∘ gres2 (eq_itree_ eq)) r). @@ -507,7 +528,9 @@ Proof. Qed. *) +Hint Rewrite @map_bind : itree. Hint Rewrite @ret_bind : itree. Hint Rewrite @tau_bind : itree. Hint Rewrite @vis_bind : itree. Hint Rewrite @bind_ret : itree. +Hint Rewrite @bind_bind : itree. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 4843f0a4..d4a69813 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -258,10 +258,9 @@ Lemma loop_natural_l {E A A' B C} (f : A -> itree E A') Proof. unfold loop. rewrite unfold_loop'; unfold loop_once. - unfold ITree.map. rewrite !bind_bind. + unfold ITree.map. autorewrite with itree. eapply eq_itree_bind; try reflexivity. - intros a' _ []. - rewrite ret_bind. + intros a' _ []. autorewrite with itree. remember (inr a') as ca eqn:EQ; clear EQ a'. pupto2_init. revert ca; clear; pcofix self; intro ca. rewrite unfold_loop'; unfold loop_once. @@ -294,9 +293,7 @@ Proof. intros [c | b]. - rewrite ret_bind, tau_bind. pfold; constructor; auto. - - rewrite ret_bind. - unfold ITree.map; rewrite bind_bind; setoid_rewrite ret_bind; - rewrite bind_ret. + - autorewrite with itree. pupto2_final; apply reflexivity. Qed. @@ -312,7 +309,31 @@ Lemma loop_dinatural {E A B C C'} (f : C -> itree E C') | inl c => f c >>= fun c' => Tau (Ret (inl c')) | inr a => Ret (inr a) end >>= body) a. -Admitted. +Proof. + unfold loop. + do 2 rewrite unfold_loop'; unfold loop_once. + autorewrite with itree. + eapply eq_itree_bind; try reflexivity. + clear a; intros cb _ []. + pupto2_init. revert cb; pcofix self; intros. + destruct cb as [c | b]. + - rewrite tau_bind. + pfold; constructor; pupto2_final; left. + rewrite map_bind. + rewrite (unfold_loop' _ (inl c)); unfold loop_once. + autorewrite with itree. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + intros c'. + rewrite tau_bind. + rewrite ret_bind. + rewrite unfold_loop'; unfold loop_once. + rewrite bind_bind. + pfold; constructor. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + auto. + - rewrite ret_bind. + pupto2_final; apply reflexivity. +Qed. Lemma vanishing1 {E A B} (f : Empty_set + A -> itree E (Empty_set + B)) (a : A) : @@ -328,7 +349,34 @@ Lemma vanishing2 {E A B C D} (f : D + (C + A) -> itree E (D + (C + B))) (a : A) : loop (loop f) a ≅ loop (fun dca => ITree.map sum_assoc_l (f (sum_assoc_r dca))) a. -Admitted. +Proof. + unfold loop; rewrite 2 unfold_loop'; unfold loop_once. + rewrite map_bind. + rewrite unfold_loop'; unfold loop_once. + rewrite bind_bind. + eapply eq_itree_bind; try reflexivity. + clear a; intros dcb _ []. + pupto2_init. revert dcb; pcofix self; intros. + destruct dcb as [d | [c | b]]; simpl. + - (* d *) + rewrite tau_bind. + rewrite 2 unfold_loop'; unfold loop_once. + autorewrite with itree. + pfold; constructor. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + auto. + - (* c *) + rewrite ret_bind. + rewrite 2 unfold_loop'; unfold loop_once. + rewrite unfold_loop'; unfold loop_once. + autorewrite with itree. + pfold; constructor. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + auto. + - (* b *) + rewrite ret_bind. + pupto2_final; apply reflexivity. +Qed. Lemma superposing1 {E A B C D D'} (f : C + A -> itree E (C + B)) (g : D -> itree E D') (a : A) : @@ -339,7 +387,34 @@ Lemma superposing1 {E A B C D D'} (f : C + A -> itree E (C + B)) | inr (inl a) => ITree.map (sum_bimap id inl) (f (inr a)) | inr (inr d) => ITree.map (inr ∘ inr) (g d) end) (inl a). -Admitted. +Proof. + unfold loop. + remember (inr a) as inra eqn:Hr. + remember (inr (inl a)) as inla eqn:Hl. + assert (Hlr : match inra with + | inl c => inl c + | inr a => inr (inl a) + end = inla). + { subst; auto. } + clear a Hl Hr. + unfold ITree.map. + pupto2_init. revert inla inra Hlr; pcofix self; intros. + rewrite 2 unfold_loop'; unfold loop_once. + rewrite bind_bind. + destruct inra as [c | a]; subst. + - rewrite bind_bind; setoid_rewrite ret_bind. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + intros [c' | b]; simpl. + + rewrite tau_bind. pfold; constructor. + pupto2_final. auto. + + rewrite ret_bind. pupto2_final; apply reflexivity. + - rewrite bind_bind; setoid_rewrite ret_bind. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + intros [c' | b]; simpl. + + rewrite tau_bind. pfold; constructor. + pupto2_final. auto. + + rewrite ret_bind. pupto2_final; apply reflexivity. +Qed. Lemma superposing2 {E A B C D D'} (f : C + A -> itree E (C + B)) (g : D -> itree E D') (d : D) : @@ -350,7 +425,12 @@ Lemma superposing2 {E A B C D D'} (f : C + A -> itree E (C + B)) | inr (inl a) => ITree.map (sum_bimap id inl) (f (inr a)) | inr (inr d) => ITree.map (inr ∘ inr) (g d) end) (inr d). -Admitted. +Proof. + unfold loop; rewrite unfold_loop'; unfold loop_once. + rewrite map_bind; unfold ITree.map. + eapply eq_itree_bind; try reflexivity. + intros d' _ []. reflexivity. +Qed. Lemma yanking {E A} (a : A) : @loop E _ _ _ (fun aa => Ret (sum_comm aa)) a ≅ Tau (Ret a). From 170c7ef426b790c80cbd6e5eae3cf4bb7f9263af Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 21 Feb 2019 23:39:03 -0500 Subject: [PATCH 057/142] Extracting the traced monoidal category of den outside, in progress to rephrase Asm and the linking accordingly --- examples/Asm.v | 75 +------ examples/Den.v | 402 ++++++++++++++++++++++++++++++++++ examples/Imp2AsmBis.v | 485 +++++++++++------------------------------- 3 files changed, 530 insertions(+), 432 deletions(-) create mode 100644 examples/Den.v diff --git a/examples/Asm.v b/examples/Asm.v index d08deebe..58361d66 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -52,10 +52,11 @@ Section Syntax. Definition bks A B := A -> block B. (* ASM: linked blocks, can jump to themselves *) - Record asm A B : Type := { - internal : Type; - code : bks (internal + A) (internal + B) - }. + Record asm A B : Type := + { + internal : Type; + code : bks (internal + A) (internal + B) + }. End Syntax. @@ -65,48 +66,11 @@ Arguments code {A B}. From ITree Require Import ITree OpenSum Fix. Require Import sum. - -Delimit Scope den_scope with den. -Local Open Scope den_scope. +Require Import Den. Section Semantics. - (* now define a semantics *) - - Inductive done : Set := Done : done. - - (* Denotations as itrees *) - Definition den {E: Type -> Type} A B : Type := A -> itree E (B + done). - (* den can represent both blocks (A -> block B) and asm (asm A B). *) - - Bind Scope den_scope with den. - - Section den_combinators. - - Context {E: Type -> Type }. - Let den := @den E. - - (* Sequential composition of den. *) - Definition cat_den {A B C} (ab : den A B) (bc : den B C) : den A C := - fun a => ob <- ab a ;; - match ob with - | inl b => bc b - | inr d => Ret (inr d) - end. - - Infix ">=>" := cat_den (at level 50, left associativity). - - Definition id_den {A} : den A A := fun a => Ret (inl a). - - Definition lift_den {A B} (f : A -> B) : den A B := fun a => Ret (inl (f a)). - Definition juxta_den {A B C D} (ab : den A B) (cd : den C D) : - den (A + C) (B + D) := - sum_elim (ab >=> lift_den inl) (cd >=> lift_den inr). - - End den_combinators. - - Definition eq_den {E A B} (d1 d2 : A -> itree E B) := - (forall a, eutt eq (d1 a) (d2 a)). + (* Denotation in terms of itrees *) Require Import ExtLib.Structures.Monad. Import MonadNotation. @@ -177,28 +141,10 @@ Section Semantics. End with_labels. End with_effect. -(* A denotation of an asm program can be viewed as a circuit/diagram + (* A denotation of an asm program can be viewed as a circuit/diagram where wires correspond to jumps/program links. - A [box : den (I + A) (I + B)] is a circuit, drawn below as ###, - with two input wires labeled by I and A, and two output wires - labeled by I and B. - - The [loop_den : den (I + A) (I + B) -> den A B] combinator closes - the circuit, linking the box with itself by plugging the I output - back into the input. - - +-----+ - | ### | - +-###-+I - A----###----B - ### - - *) - - Definition loop_den {E I A B} : - (I + A -> itree E ((I + B) + done)) -> A -> itree E (B + done) := - fun body => loop (compose (ITree.map sum_assoc_r) body). + It is therefore denoted as a [dem] term *) (* Denotation of [asm] *) Definition denote_asm {e} `{Locals -< e} `{Memory -< e} {A B} : @@ -213,9 +159,6 @@ End Semantics. *) -Infix ">=>" := cat_den (at level 50, left associativity). - - (* Interpretation ----------------------------------------------------------- *) From ITree Require Import diff --git a/examples/Den.v b/examples/Den.v new file mode 100644 index 00000000..5d5b43b3 --- /dev/null +++ b/examples/Den.v @@ -0,0 +1,402 @@ +From ITree Require Import + ITree + OpenSum + Fix + FixFacts + Basics_Functions. + +From Coq Require Import + Program + Morphisms. + +(** * Category of denotations *) +Inductive done : Set := Done : done. +Definition den {E: Type -> Type} A B : Type := A -> itree E (B + done). +(* den can represent both blocks (A -> block B) and asm (asm A B). *) + +Section Den. + + (* (@den E) forms a traced monoidal category, i.e. a symmetric monoidal one with a loop operator *) + (* Obj ≅ Type *) + (* Arrow: A -> B ≅ terms of type (den A B) *) + + Context {E: Type -> Type}. + Notation denE := (@den E). + + Section Equivalence. + + (* We work up to pointwise eutt *) + Definition eq_den {A B} (d1 d2 : A -> itree E B) := + (forall a, eutt eq (d1 a) (d2 a)). + + Global Instance Equivalence_eq_den {A B} : Equivalence (@eq_den A B). + Proof. + split. + - intros ab a; reflexivity. + - intros ab ab' eqAB a; symmetry; auto. + - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. + Qed. + + Global Instance eq_den_elim {A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@sum_elim A B (itree E C)). + Proof. + repeat intro. destruct a; unfold sum_elim; auto. + Qed. + + End Equivalence. + + Infix "⩰" := eq_den (at level 70). + + Section Structure. + + (* Composition *) + Definition compose_den {A B C} (ab : denE A B) (bc : denE B C) : @denE A C := + fun a => ob <- ab a ;; + match ob with + | inl b => bc b + | inr d => Ret (inr d) + end. + + (* Identities *) + Definition id_den {A} : denE A A := fun a => Ret (inl a). + + (* Utility function to lift a pure computation into den *) + Definition lift_den {A B} (f : A -> B) : denE A B := fun a => Ret (inl (f a)). + + (* Tensor product *) + (* Tensoring on objects is simply the sum type constructor *) + Definition tensor_den {A B C D} + (ab : denE A B) (cd : denE C D) : den (A + C) (B + D) := + sum_elim (compose_den ab (lift_den inl)) (compose_den cd (lift_den inr)). + + (* + A [box : den (I + A) (I + B)] is a circuit, drawn below as ###, + with two input wires labeled by I and A, and two output wires + labeled by I and B. + + The [loop_den : den (I + A) (I + B) -> den A B] combinator closes + the circuit, linking the box with itself by plugging the I output + back into the input. + + +-----+ + | ### | + +-###-+I + A----###----B + ### + + *) + Definition loop_den {I A B} : + (I + A -> itree E ((I + B) + done)) -> A -> itree E (B + done) := + fun body => loop (compose (ITree.map sum_assoc_r) body). + + End Structure. + + Infix ">=>" := compose_den (at level 50, left associativity). + Infix "⊗" := (tensor_den) (at level 30). + + Section Facts. + + (** *** [compose_den] respect eq_den *) + Global Instance eq_den_compose {A B C} : + Proper (eq_den ==> eq_den ==> eq_den) (@compose_den A B C). + Proof. + intros ab ab' eqAB bc bc' eqBC. + intro a. + unfold compose_den. + rewrite (eqAB a). + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + rewrite (eqBC b); reflexivity. + Qed. + + (** *** [compose_den] is associative *) + Lemma compose_den_assoc {A B C D} + (ab : den A B) (bc : den B C) (cd : den C D) : + ((ab >=> bc) >=> cd) ⩰ (ab >=> (bc >=> cd)). + Proof. + intros a. + unfold compose_den. + rewrite bind_bind. + apply eutt_bind; try reflexivity. + intros []; try reflexivity. + rewrite ret_bind; reflexivity. + Qed. + + (** *** [id_den] respect identity laws *) + Lemma id_den_left {A B}: forall (f: denE A B), + id_den >=> f ⩰ f. + Proof. + intros f a; unfold compose_den, id_den; rewrite ret_bind; reflexivity. + Qed. + + Lemma id_den_right {A B}: forall (f: denE A B), + f >=> id_den ⩰ f. + Proof. + intros f a; unfold compose_den, id_den. + rewrite <- (bind_ret (f a)) at 2. + apply eutt_bind; [reflexivity | intros []; reflexivity]. + Qed. + + (** *** [lift_den] is well-behaved *) + + Global Instance eq_lift_den {A B} : + Proper (eeq ==> eq_den) (@lift_den A B). + Proof. + repeat intro. + unfold lift_den. + erewrite (H a); reflexivity. + Qed. + + Fact compose_lift_den {A B C} (ab : A -> B) (bc : B -> C) : + (lift_den ab >=> lift_den bc) ⩰ (lift_den (bc ∘ ab)). + Proof. + intros a. + unfold lift_den, compose_den. + rewrite ret_bind. + reflexivity. + Qed. + + Fact compose_lift_den_l {A B C D} (f: A -> B) (g: B -> C) (k: den C D) : + (lift_den f >=> (lift_den g >=> k)) ⩰ (lift_den (g ∘ f) >=> k). + Proof. + rewrite <- compose_den_assoc. + rewrite compose_lift_den. + reflexivity. + Qed. + + Fact compose_lift_den_r {A B C D} (f: B -> C) (g: C -> D) (k: den A B) : + ((k >=> lift_den f) >=> lift_den g) ⩰ (k >=> lift_den (g ∘ f)). + Proof. + rewrite compose_den_assoc. + rewrite compose_lift_den. + reflexivity. + Qed. + + Fact lift_den_lift_den {A B C} (f: A -> B) (g: B -> C) : + lift_den f >=> lift_den g ⩰ lift_den (g ∘ f). + Proof. + intros a. + unfold lift_den, compose_den. + rewrite ret_bind. + reflexivity. + Qed. + + Fact lift_compose_den {A B C}: forall (f:A -> B) (bc: den B C), + lift_den f >=> bc ⩰ fun a => bc (f a). + Proof. + intros; intro a. + unfold lift_den, compose_den. + rewrite ret_bind; reflexivity. + Qed. + + Fact compose_den_lift {A B C}: forall (ab: den A B) (g:B -> C), + eq_den (ab >=> lift_den g) + (fun a => ITree.map (sum_bimap g id) (ab a)). + Proof. + intros; intro a. + unfold compose_den. + unfold ITree.map. + apply eutt_bind. + reflexivity. + intros []; reflexivity. + Qed. + + (** *** [sum_elim] lemmas *) + + Fact compose_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : + sum_elim ac bc >=> cd ⩰ sum_elim (ac >=> cd) (bc >=> cd). + Proof. + intros; intros []; + (unfold compose_den; simpl; apply eutt_bind; [reflexivity | intros []; reflexivity]). + Qed. + + Fact lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : + sum_elim (lift_den ac) (lift_den bc) ⩰ lift_den (sum_elim ac bc). + Proof. + intros []; reflexivity. + Qed. + + (** *** [tensor] lemmas *) + + Lemma tensor_swap {A B C D} (ab : den A B) (cd : den C D) : + ab ⊗ cd ⩰ (lift_den sum_comm >=> cd ⊗ ab >=> lift_den sum_comm). + Proof. + unfold tensor_den. + rewrite !(compose_den_lift cd), !(compose_den_lift ab), !lift_compose_den, !compose_den_lift. + intros []; cbn; rewrite map_map; cbn; + apply eutt_map; try intros []; reflexivity. + Qed. + + Fact tensor_id_lift {A B C} (f : B -> C) : + (@id_den A) ⊗ (lift_den f) ⩰ lift_den (sum_bimap id f). + Proof. + unfold tensor_den. + rewrite compose_lift_den, id_den_left. + rewrite lift_sum_elim. + reflexivity. + Qed. + + Fact tensor_lift_id {A B C} (f : A -> B) : + (lift_den f) ⊗ (@id_den C) ⩰ lift_den (sum_bimap f id). + Proof. + unfold tensor_den. + rewrite compose_lift_den, id_den_left. + rewrite lift_sum_elim. + reflexivity. + Qed. + + (** *** [loop] lemmas *) + + Global Instance eq_den_loop {I A B} : + Proper (eq_den ==> eq_den) (@loop_den I A B). + Proof. + Admitted. + + (* Should be a consequence of the others. *) + Lemma seq_loop_l_seq {A B C I} + (ab : den (I + A) (I + B)) (bc : den B C) : + loop_den ab >=> bc ⩰ + loop_den (ab >=> tensor_den id_den bc). + Proof. + Admitted. + + (* Should be a consequence of the others *) + Lemma seq_loop_r_seq {A B C I} + (ab : den A B) (bc : den (I + B) (I + C)) : + ab >=> loop_den bc ⩰ + loop_den (tensor_den id_den ab >=> bc). + Proof. + Admitted. + + (* Naturality of (loop_den I A B) in A *) + (* Or more diagrammatically: +[[ + +-----+ + | ### | + +-###-+I +A----B----###----C + ### + +is equivalent to: + + +----------+ + | ### | + +------###-+I +A----B----###----C + ### + +]] + *) + + Lemma compose_loop {I A B C}: + forall (bc_: denE (I + B) (I + C)) (ab: denE A B), + loop_den ((id_den ⊗ ab) >=> bc_) ⩰ + ab >=> loop_den bc_. + Admitted. + + (* Naturality of (loop_den I A B) in B *) + (* Or more diagrammatically: +[[ + +-----+ + | ### | + +-###-+I +A----###----B----C + ### + +is equivalent to: + + +----------+ + | ### | + +-###------+I +A----###----B----C + ### + +]] + *) + + Lemma loop_compose {I A B B'}: + forall (ab_: denE (I + A) (I + B)) (bc: denE B B'), + loop_den (ab_ >=> (id_den ⊗ bc)) ⩰ + loop_den ab_ >=> bc. + Admitted. + + (* Dinaturality of (loop_den I A B) in I *) + + Lemma loop_rename_internal {I J A B}: + forall (ab_: denE (I + A) (J + B)) (ji: denE J I), + loop_den (ab_ >=> (ji ⊗ id_den)) ⩰ + loop_den ((ji ⊗ id_den) >=> ab_). + Admitted. + + (* [loop_loop]: + +These two loops: + +[[ + +----------+ + | +-----+ | + | | ### | | + | +-###-+I | + +---###----+J + A-----###-------B + ### +]] + +... can be rewired as a single one: + + +[[ + +-------+ + | ### | + +--###--+(I+J) + +--###--+ + A-----###-----B + ### +]] + + *) + + (* I do not see a way to avoid the use of lift_den. *) + + Notation rewire_den f g ab := + (lift_den f >=> ab >=> lift_den g) (only parsing). + + Lemma loop_loop {I J A B}: + forall (ab__: denE (I + (J + A)) (I + (J + B))), + loop_den (loop_den ab__) ⩰ + loop_den (rewire_den sum_assoc_r sum_assoc_l ab__). + Admitted. + + Lemma tensor_den_loop {I A B C D} + (ab : denE (I + A) (I + B)) (cd : denE C D) : + (loop_den ab) ⊗ cd ⩰ + loop_den (rewire_den sum_assoc_l sum_assoc_r (ab ⊗ cd)). + Proof. + Admitted. + + (* Lemma loop_relabel {I J A B} *) + (* (f : I -> J) {f' : J -> I} *) + (* {ISO_f : Iso f f'} *) + (* (ab : den (I + A) (I + B)) : *) + (* eq_den (loop_den ab) *) + (* (loop_den (rewire_den' (sum_bimap f' id) (sum_bimap f id) ab)). *) + (* Proof. *) + (* Admitted. *) + + End Facts. +End Den. + +Bind Scope den_scope with den. +Infix "⩰" := eq_den (at level 70). +Infix ">=>" := compose_den (at level 50, left associativity). +Infix "⊗" := (tensor_den) (at level 30). + +Hint Rewrite @compose_den_assoc : lift_den. +Hint Rewrite @lift_den_lift_den : lift_den. +Hint Rewrite @compose_lift_den_l : lift_den. +Hint Rewrite @tensor_id_lift : lift_den. +Hint Rewrite @tensor_lift_id : lift_den. +Hint Rewrite @lift_sum_elim : lift_den. +Hint Rewrite @compose_lift_den : lift_den. + + diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index ae47a247..20d2fa83 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -5,392 +5,145 @@ From Coq Require Import Morphisms RelationClasses. -From ITree Require Import ITree FixFacts. +From ITree Require Import + ITree + FixFacts + Basics_Functions. Require Import Program.Basics. (* ∘ *) -Require Import sum. -Require Import Asm. - -(** * Category of denotations *) - -Variable E0 : Type -> Type. -Instance ME0 : Memory -< E0. Admitted. -Instance LE0 : Imp.Locals -< E0. Admitted. -Notation den := (@den E0). - -Instance Equivalence_eq_den {E A B} : Equivalence (@eq_den E A B). -Proof. - split. - - intros ab a; reflexivity. - - intros ab ab' eqAB a; symmetry; auto. - - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. -Qed. - -Instance eq_den_loop {E I A B} : - Proper (eq_den ==> eq_den) (@loop_den E I A B). -Proof. -Admitted. - -Instance eq_den_cat {E A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@cat_den E A B C). -Proof. - intros ab ab' eqAB bc bc' eqBC. - intro a. - unfold cat_den. - rewrite (eqAB a). - apply eutt_bind; try reflexivity. - intros []; try reflexivity. - rewrite (eqBC b); reflexivity. -Qed. - -Instance eq_den_elim {E A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@sum_elim A B (itree E C)). -Proof. - repeat intro. destruct a; unfold sum_elim; auto. -Qed. - -(** *** [cat_den] *) - -Lemma cat_den_assoc {A B C D} - (ab : den A B) (bc : den B C) (cd : den C D) : - eq_den ((ab >=> bc) >=> cd) - (ab >=> (bc >=> cd)). -Proof. - intros a. - unfold lift_den, cat_den. - rewrite bind_bind. - apply eutt_bind; try reflexivity. - intros []; try reflexivity. - rewrite ret_bind; reflexivity. -Qed. - -Lemma cat_lift_den {E A B C} (ab : A -> B) (bc : B -> C) : - @eq_den E _ _ - (lift_den ab >=> lift_den bc) - (lift_den (bc ∘ ab)). -Proof. - intros a. - unfold lift_den, cat_den. - rewrite ret_bind. - reflexivity. -Qed. - -Instance eq_lift_den {E A B} : - Proper (eqeq ==> eq_den) (@lift_den E A B). -Proof. - repeat intro. - unfold lift_den. - erewrite (H a); reflexivity. -Qed. - -Lemma lift_den_lift_den {E A B C} (f: A -> B) (g: B -> C) : - @eq_den E _ _ (lift_den f >=> lift_den g) (lift_den (g ∘ f)). -Proof. - intros a. - unfold lift_den, cat_den. - rewrite ret_bind. - reflexivity. -Qed. - -Lemma cat_lift_den_l {A B C D} (f: A -> B) (g: B -> C) (k: den C D) : - eq_den - (lift_den f >=> (lift_den g >=> k)) - (lift_den (g ∘ f) >=> k). -Proof. - rewrite <- cat_den_assoc. - rewrite cat_lift_den. - reflexivity. -Qed. - -(* For completeness. *) -Lemma cat_lift_den_r {A B C D} (f: B -> C) (g: C -> D) (k: den A B) : - eq_den - ((k >=> lift_den f) >=> lift_den g) - (k >=> lift_den (g ∘ f)). -Proof. - rewrite cat_den_assoc. - rewrite cat_lift_den. - reflexivity. -Qed. - -(* Low-level *) -Lemma lift_cat_den {A B C}: forall (f:A -> B) (bc: den B C), - eq_den (lift_den f >=> bc) (fun a => bc (f a)). -Proof. - intros; intro a. - unfold lift_den, cat_den. - rewrite ret_bind; reflexivity. -Qed. - -Lemma cat_den_lift {A B C}: forall (ab: den A B) (g:B -> C), - eq_den (ab >=> lift_den g) - (fun a => ITree.map (sum_bimap g id) (ab a)). -Proof. - intros; intro a. - unfold cat_den. - unfold ITree.map. - apply eutt_bind. - reflexivity. - intros []; reflexivity. -Qed. - -(** *** [juxta] lemmas *) - -Lemma juxta_swap {A B C D} (ab : den A B) (cd : den C D) : - eq_den (juxta_den ab cd) - (lift_den sum_comm >=> juxta_den cd ab >=> lift_den sum_comm). -Proof. - unfold juxta_den. - rewrite !(cat_den_lift cd), !(cat_den_lift ab), !lift_cat_den, !cat_den_lift. - intros []; cbn; rewrite map_map; cbn; - apply eutt_map; try intros []; reflexivity. -Qed. - -(* Unused but should go to FixFacts *) -Instance eutt_loop {E A B} : - Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@aloop E A B). -Proof. -Admitted. - -Instance eutt_loop' {E A B} : - Proper (eq_den ==> eq_den) (@aloop E A B). -Proof. -Admitted. - -Lemma juxta_id_lift {E A B C} (f : B -> C) : - eq_den (juxta_den (@id_den E A) (lift_den f)) - (lift_den (sum_bimap id f)). -Proof. -Admitted. - -Lemma juxta_lift_id {E A B C} (f : A -> B) : - eq_den (juxta_den (lift_den f) (@id_den E C)) - (lift_den (sum_bimap f id)). -Proof. -Admitted. - -Hint Rewrite @cat_den_assoc : lift_den. -Hint Rewrite @lift_den_lift_den : lift_den. -Hint Rewrite @cat_lift_den_l : lift_den. -Hint Rewrite @juxta_id_lift : lift_den. -Hint Rewrite @juxta_lift_id : lift_den. - -(** *** [sum_elim] lemmas *) - -Lemma cat_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : - eq_den (sum_elim ac bc >=> cd) - (sum_elim (ac >=> cd) (bc >=> cd)). -Proof. -Admitted. - -Opaque eutt. - -Lemma lift_sum_elim {E A B C} (ac : A -> C) (bc : B -> C) : - @eq_den E _ _ - (sum_elim (lift_den ac) (lift_den bc)) - (lift_den (sum_elim ac bc)). -Proof. intros []; reflexivity. Qed. - -Hint Rewrite @lift_sum_elim : lift_den. -Hint Rewrite @cat_lift_den : lift_den. - -(* Denotation of [rewire_b] *) -Definition rewire_den {A B C D} (f : C -> A) (g : B -> D) - (ab : den A B) : den C D := - fun a => ITree.map (sum_map_l g) (ab (f a)). - -Notation rewire_den' f g ab := (lift_den f >=> ab >=> lift_den g)%den - (only parsing). - -Lemma unfold_rewire_den {A B C D} (f : C -> A) (g : B -> D) - (ab : den A B) : - eq_den (rewire_den f g ab) - (rewire_den' f g ab). -Proof. - rewrite lift_cat_den, cat_den_lift. - reflexivity. -Qed. - -Instance eq_den_rewire_den {A B C D} : - Proper ((eq ==> eq) ==> (eq ==> eq) ==> eq_den ==> eq_den) - (@rewire_den A B C D). -Proof. - intros f f' eqf g g' eqg ab ab' eqAB. - do 2 rewrite unfold_rewire_den. - rewrite eqf, eqg, eqAB; reflexivity. -Qed. - -Lemma seq_loop_l {I A B C} - (ab : den (I + A) (I + B)) (bc : den B C) : - eq_den (loop_den ab >=> bc) - (loop_den (rewire_den' (sum_assoc_r ∘ sum_bimap sum_comm id) - sum_comm - (juxta_den bc ab))). -Proof. -Admitted. - -Lemma seq_loop_r {I A B C} - (ab : den A B) (bc : den (I + B) (I + C)) : - eq_den (ab >=> loop_den bc) - (loop_den (rewire_den' sum_comm - (sum_bimap sum_comm id ∘ sum_assoc_l) - (juxta_den ab bc))). -Proof. -Admitted. +Require Import Den. + +Section Linking. + + Variable E0 : Type -> Type. + Notation den := (@den E0). + + (* Definition cat_b {A B C D}: *) + (* (bks A B) -> *) + (* (bks C D) -> *) + (* (bks (A + C) (B + D)) := *) + (* fun ab cd oac => *) + (* match oac with *) + (* | inl a => fmap_block inl (ab a) *) + (* | inr c => fmap_block inr (cd c) *) + (* end. *) + + (* Definition rewire_b {A B C D}: *) + (* (C -> A) -> *) + (* (B -> D) -> *) + (* (bks A B) -> *) + (* (bks C D) := *) + (* fun f g ab c => *) + (* fmap_block g (ab (f c)). *) + + (* + (* Correctness of [cat_b] and [rewire_b] (easy) + YZ: Those depend on the implementation. Should they be assumed by the theory? + *) -(* Should be a consequence of the others. *) -Lemma seq_loop_l_seq {A B C I} - (ab : den (I + A) (I + B)) (bc : den B C) : - eq_den (loop_den ab >=> bc) - (loop_den (ab >=> juxta_den id_den bc)). -Proof. -Admitted. + Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : + eq_den (denote_b E0 (cat_b ab cd)) + (juxta_den (denote_b _ ab) (denote_b E0 cd)). + Admitted. -(* Should be a consequence of the others *) -Lemma seq_loop_r_seq {A B C I} - (ab : den A B) (bc : den (I + B) (I + C)) : - eq_den (ab >=> loop_den bc) - (loop_den (juxta_den id_den ab >=> bc)). -Proof. -Admitted. + Lemma rewire_correct {A B C D} (f : C -> A) (g : B -> D) (ab : bks A B) : + eq_den (denote_b _ (rewire_b f g ab)) + (rewire_den' f g (denote_b _ ab)). + Admitted. + *) -(* [loop_loop]: + (* Opaque compose. *) + (* Opaque id. *) + (* Opaque sum_elim. *) -These two loops: + (* Definition rw {I B J C} : *) + (* (I + B) + (J + C) -> (I + J + B) + C := *) + (* Eval compute in resum. *) -[[ - +----------+ - | +-----+ | - | | ### | | - | +-###-+I | - +---###----+J - A-----###-------B - ### -]] + (* Definition corw {A I B J} : (I + J + B) + A -> (I + A) + (J + B) := *) + (* Eval compute in resum. *) -... can be rewired as a single one: + (* Transparent compose. *) + (* Transparent id. *) + (* Transparent sum_elim. *) -[[ - +-------+ - | ### | - +--###--+(I+J) - +--###--+ - A-----###-----B - ### -]] + (* Sequential composition of bks. *) -*) -Lemma loop_loop {I J A B} - (ab : den (I + (J + A)) (I + (J + B))) : - eq_den (loop_den (loop_den ab)) - (loop_den (rewire_den' sum_assoc_r sum_assoc_l ab)). -Proof. -Admitted. +(* + Definition rw {I B J C} : + (I + B) + (J + C) -> (I + J + B) + C := + Eval compute in resum. -Lemma juxta_den_loop {I A B C D} - (ab : den (I + A) (I + B)) (cd : den C D) : - eq_den (juxta_den (loop_den ab) cd) - (loop_den (rewire_den' sum_assoc_l sum_assoc_r - (juxta_den ab cd))). -Proof. -Admitted. + Definition corw {A I B J} : (I + J + B) + A -> (I + A) + (J + B) := + Eval compute in resum. -Lemma loop_relabel {I J A B} - (f : I -> J) {f' : J -> I} - {ISO_f : Iso f f'} - (ab : den (I + A) (I + B)) : - eq_den (loop_den ab) - (loop_den (rewire_den' (sum_bimap f' id) (sum_bimap f id) ab)). -Proof. -Admitted. -(**) + Definition rewire_b {A B C D}: + (C -> A) -> + (B -> D) -> + (bks A B) -> + (bks C D) := + fun f g ab c => + fmap_block g (ab (f c)). -Definition cat_b {A B C D}: + Definition cat_b {A B C D}: (bks A B) -> (bks C D) -> (bks (A + C) (B + D)) := - fun ab cd oac => - match oac with - | inl a => fmap_block inl (ab a) - | inr c => fmap_block inr (cd c) - end. - -Definition rewire_b {A B C D}: - (C -> A) -> - (B -> D) -> - (bks A B) -> - (bks C D) := - fun f g ab c => - fmap_block g (ab (f c)). - -(* Correctness of [cat_b] and [rewire_b] (easy) - YZ: Those depend on the implementation. Should they be assumed by the theory? - *) - -Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : - eq_den (denote_b E0 (cat_b ab cd)) - (juxta_den (denote_b _ ab) (denote_b E0 cd)). -Admitted. - -Lemma rewire_correct {A B C D} (f : C -> A) (g : B -> D) (ab : bks A B) : - eq_den (denote_b _ (rewire_b f g ab)) - (rewire_den' f g (denote_b _ ab)). -Admitted. - -Opaque compose. -Opaque id. -Opaque sum_elim. - -Definition rw {I B J C} : - (I + B) + (J + C) -> (I + J + B) + C := - Eval compute in resum. - -Definition corw {A I B J} : (I + J + B) + A -> (I + A) + (J + B) := - Eval compute in resum. - -Transparent compose. -Transparent id. -Transparent sum_elim. + fun ab cd oac => + match oac with + | inl a => fmap_block inl (ab a) + | inr c => fmap_block inr (cd c) + end. + + Definition seq_bks {A I B J C} + (ab : bks (I + A) (I + B)) + (bc : bks (J + B) (J + C)) : + bks ((I + J + B) + A) ((I + J + B) + C) := + rewire_b corw rw (cat_b ab bc). +*) -(* Sequential composition of bks. *) -Definition seq_bks {A I B J C} - (ab : bks (I + A) (I + B)) - (bc : bks (J + B) (J + C)) : - bks ((I + J + B) + A) ((I + J + B) + C) := - rewire_b corw rw (cat_b ab bc). + (* TODO: redefine seq_den purely in term of Den.v *) + (* + Definition seq_den {A I B J C} + (ab: den (I + A) (I + B)) + (bc: den (J + B) (J + C)) := + den ((I + J + B) + A) ((I + J + B) + C) := + _ + + Theorem seq_correct {A B C} (ab : den A B) (bc : den B C) : + (seq_den ab bc) ⩰ ab >=> bc. + Proof. + unfold denote_asm, seq_asm; simpl. + unfold seq_bks. +*) -(* Sequential composition of asm. *) -Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C) : asm A C := - {| code := seq_bks (code ab) (code bc) |}. +(* + Can we prove this without rewire? + In particular, need loop_loop + + (* rewrite rewire_correct. *) + (* rewrite cat_correct. *) + rewrite seq_loop_l. + rewrite tensor_den_loop. + rewrite seq_loop_r_seq. + rewrite seq_loop_l_seq. + rewrite loop_loop. + rewrite (juxta_swap (_ (code bc))). + rewrite (loop_relabel (sum_bimap sum_comm id ∘ sum_assoc_l)). + autorewrite with lift_den. + (* Now everything matches except [lift_den] *) + apply eq_den_loop. + apply eq_den_cat. + - apply eq_lift_den. + intros [[[] | ] | ] ? []; auto. + - apply eq_den_cat. + + reflexivity. + + apply eq_lift_den. + intros [[] | [] ] ? []; auto. + *) -Theorem seq_correct {A B C} (ab : asm A B) (bc : asm B C) : - @eq_den E0 _ _ - (denote_asm (seq_asm ab bc)) - (cat_den (denote_asm ab) (denote_asm bc)). -Proof. - unfold denote_asm, seq_asm; simpl. - unfold seq_bks. - rewrite rewire_correct. - rewrite cat_correct. - rewrite seq_loop_l. - rewrite juxta_den_loop. - rewrite seq_loop_r_seq. - rewrite seq_loop_l_seq. - rewrite loop_loop. - rewrite (juxta_swap (_ (code bc))). - rewrite (loop_relabel (sum_bimap sum_comm id ∘ sum_assoc_l)). - autorewrite with lift_den. - (* Now everything matches except [lift_den] *) - apply eq_den_loop. - apply eq_den_cat. - - apply eq_lift_den. - intros [[[] | ] | ] ? []; auto. - - apply eq_den_cat. - + reflexivity. - + apply eq_lift_den. - intros [[] | [] ] ? []; auto. -Qed. + (* Qed. *) From 7832ecf3f48c616dce55d8cd471bdc16bf5fa85a Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 22 Feb 2019 00:13:04 -0500 Subject: [PATCH 058/142] Trailing corrupted import --- examples/Asm.v | 1 - 1 file changed, 1 deletion(-) diff --git a/examples/Asm.v b/examples/Asm.v index 58361d66..84141372 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -65,7 +65,6 @@ Arguments code {A B}. From ITree Require Import ITree OpenSum Fix. -Require Import sum. Require Import Den. Section Semantics. From 8bdd795ab543e53295be31b190a9810694765e7d Mon Sep 17 00:00:00 2001 From: Lysxia Date: Fri, 22 Feb 2019 11:14:30 -0500 Subject: [PATCH 059/142] Make ~> parse-only (overlaps with other notations) --- theories/Basics.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Basics.v b/theories/Basics.v index e2aaa86d..fd5227d1 100644 --- a/theories/Basics.v +++ b/theories/Basics.v @@ -14,7 +14,7 @@ Set Universe Polymorphism. - Monad morphisms *) Notation "E ~> F" := (forall T, E T -> F T) - (at level 99, right associativity) : type_scope. + (at level 99, right associativity, only parsing) : type_scope. (** Identity morphism. *) Definition idM {E : Type -> Type} : E ~> E := fun _ e => e. From 82e54dbd82addfb4b57dad0a756c12a8de0e0814 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Fri, 22 Feb 2019 17:15:45 -0500 Subject: [PATCH 060/142] Almost prove eutt_loop --- theories/Eq/Eq.v | 22 ++++++ theories/Eq/UpToTaus.v | 23 ++++++ theories/FixFacts.v | 160 ++++++++++++++++++++++++++++++++++++++++- 3 files changed, 202 insertions(+), 3 deletions(-) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index b5e16876..88c154f0 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -301,6 +301,28 @@ Proof. intros H; punfold H; inversion H; pclearbot; auto_inj_pair2; subst; auto. Qed. +(* One-sided inversion *) + +Lemma eq_itree_ret_inv1 {E R} (t : itree E R) r : + t ≅ Ret r -> observe t = RetF r. +Proof. + intros; punfold H; inversion H; subst; auto. +Qed. + +Lemma eq_itree_vis_inv1 {E R U} (t : itree E R) (e : E U) (k : U -> _) : + t ≅ Vis e k -> exists k', observe t = VisF e k' /\ forall u, k' u ≅ k u. +Proof. + intros; punfold H; inversion H; subst; auto_inj_pair2; subst; pclearbot; eauto. +Qed. + +Lemma eq_itree_tau_inv1 {E R} (t t' : itree E R) : + t ≅ Tau t' -> exists t0, observe t = TauF t0 /\ t0 ≅ t'. +Proof. + intros; punfold H; inversion H; pclearbot; eauto. +Qed. + +(**) + Lemma bind_unfold {E R S} (t : itree E R) (k : R -> itree E S) : observe (ITree.bind t k) = observe (ITree.bind_match k (ITree.bind' k) (observe t)). diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index d9adc161..f72338d9 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -745,6 +745,29 @@ Hint Constructors eutt_trans_clo. Infix "≈" := (eutt eq) (at level 70) : itree_scope. +(**) + +Lemma eutt_tau {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + eutt RR t1 t2 -> eutt RR (Tau t1) (Tau t2). +Proof. + intros; pfold; constructor; auto. +Admitted. + +Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + (forall u, eq_itree RR (k1 u) (k2 u)) -> + eq_itree RR (Vis e k1) (Vis e k2). +Proof. + intros; pfold; constructor; left. apply H. +Qed. + +Lemma eq_itree_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + RR r1 r2 -> @eq_itree E _ _ RR (Ret r1) (Ret r2). +Proof. + intros; pfold; eauto; constructor; auto. +Qed. + (* Lemmas about [bind]. *) Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) diff --git a/theories/FixFacts.v b/theories/FixFacts.v index d4a69813..2946f36c 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -201,6 +201,11 @@ Qed. Notation loop_once_ f loop_ := (loop_once f (fun cb => Tau (loop_ f%function cb))). +Lemma unfold_loop'' {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : + observe (loop_ f x) + = observe (loop_once f (fun cb => Tau (loop_ f cb)) x). +Proof. reflexivity. Qed. + Lemma unfold_loop' {E A B C} (f : C + A -> itree E (C + B)) (x : C + A) : loop_ f x ≅ loop_once f (fun cb => Tau (loop_ f cb)) x. @@ -454,9 +459,158 @@ Lemma bind_aloop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) end) (inl x). Admitted. +Instance eq_itree_loop {E A B C} : + Proper ((eq ==> eq_itree eq) ==> eq ==> eq_itree eq) (@loop E A B C). +Proof. + repeat intro; subst. + unfold loop. + remember (inr _) as ca eqn:EQ; clear EQ y0. + pupto2_init. revert ca; pcofix self; intros. + rewrite 2 unfold_loop'; unfold loop_once. + pupto2 eq_itree_clo_bind; constructor; try auto. + intros [c | b]; pfold; constructor; auto. +Qed. + +Section eutt_loop. + +Context {E : Type -> Type} {A B C : Type}. +Variables f1 f2 : C + A -> itree E (C + B). +Hypothesis eutt_f : forall ca, f1 ca ≈ f2 ca. + +Inductive loop_preinv (t1 t2 : itree E B) : Prop := +| loop_inv_main ca : + t1 ≅ loop_ f1 ca -> + t2 ≅ loop_ f2 ca -> + loop_preinv t1 t2 +| loop_inv_bind u1 u2 : + eutt eq u1 u2 -> + t1 ≅ (cb <- u1;; + match cb with + | inl c => Tau (loop_ f1 (inl c)) + | inr b => Ret b + end) -> + t2 ≅ (cb <- u2;; + match cb with + | inl c => Tau (loop_ f2 (inl c)) + | inr b => Ret b + end) -> + loop_preinv t1 t2 +. +Hint Constructors loop_preinv. + +Lemma eutt_loop_inv_main_step (ca : C + A) t1 t2 : + t1 ≅ loop_ f1 ca -> + t2 ≅ loop_ f2 ca -> + euttF' loop_preinv + (fun ot1 ot2 => loop_preinv (go ot1) (go ot2)) + (observe t1) (observe t2). +Proof. + intros H1 H2. + rewrite unfold_loop' in H1. + rewrite unfold_loop' in H2. + unfold loop_once. + specialize (eutt_f ca). + punfold eutt_f. + destruct eutt_f. + unfold loop_once in H1. + rewrite unfold_bind in H1. + destruct (observe (f1 ca)) eqn:Ef1. + - assert (H1unalltaus : @unalltausF E _ (RetF r) (RetF r)). + { apply untaus_all; constructor. } + assert (H2unalltaus : finite_taus (f2 ca)). + { apply FIN; eauto. } + destruct H2unalltaus as [ot2 H2unalltaus]. + specialize (EQV _ _ H1unalltaus H2unalltaus). + destruct H2unalltaus as [H2untaus _]. + unfold loop_once in H2. + remember (f2 ca) as t2' eqn:Et2; clear Et2. + rewrite unfold_bind in H2. + genobs t2' ot2'. + induction H2untaus. + + inversion EQV; subst. rewrite <- H3 in H2; simpl in H1, H2. + destruct r2. + * apply eq_itree_tau_inv1 in H1. + apply eq_itree_tau_inv1 in H2. + destruct H1 as [t01 [Ht01 Ht01']]. + destruct H2 as [t02 [Ht02 Ht02']]. + rewrite Ht01, Ht02. + constructor. + econstructor. + { rewrite Ht01'. rewrite <- itree_eta. reflexivity. } + { rewrite Ht02'. rewrite <- itree_eta. reflexivity. } + * admit. + + admit. + - admit. + - admit. +Admitted. + +Lemma eutt_loop_inv t1 t2 : + loop_preinv t1 t2 -> eutt eq t1 t2. +Proof. + intros HH. + apply eutt_is_eutt'. + revert t1 t2 HH; pcofix self; intros. pfold. + revert t1 t2 HH; pcofix self_tau; intros. + destruct HH as [ca H1 H2 | u1 u2 Hu H1 H2]. + - pfold. eapply euttF'_mon. + + eapply eutt_loop_inv_main_step; eauto. + + intros. right. eapply self; eauto; try reflexivity. + + simpl; intros. right. + replace x0 with (observe (go x0)) by reflexivity. + replace x1 with (observe (go x1)) by reflexivity. + eapply self_tau; eauto; try reflexivity. + - apply eutt_is_eutt' in Hu. punfold Hu. punfold Hu. + rewrite unfold_bind in H1. + rewrite unfold_bind in H2. + pfold. + genobs t1 ot1. genobs t2 ot2. + revert ot1 ot2 t1 t2 Heqot1 Heqot2 H1 H2. + induction Hu; intros; cbn in H1, H2; subst. + + destruct r1 as [ c | b ]. + * apply eq_itree_tau_inv1 in H1. + apply eq_itree_tau_inv1 in H2. + destruct H1 as [t1'' [H1 H1']]. + destruct H2 as [t2'' [H2 H2']]. + rewrite H1, H2. constructor; eauto. + * apply eq_itree_ret_inv1 in H1. apply eq_itree_ret_inv1 in H2. + rewrite H1, H2. auto. + + apply eq_itree_vis_inv1 in H1. apply eq_itree_vis_inv1 in H2. + destruct H1 as [k1' [H1 H1']]. + destruct H2 as [k2' [H2 H2']]. + rewrite H1, H2. pclearbot. eauto. + constructor; intro z; right. + eapply self; eauto. + econstructor 2. + apply eutt_is_eutt'; apply EUTTK. + eauto. eauto. + + pclearbot. + apply eq_itree_tau_inv1 in H1. apply eq_itree_tau_inv1 in H2. + destruct H1 as [t1'' [H1 H1']]. + destruct H2 as [t2'' [H2 H2']]. + rewrite H1, H2. constructor. right. + eapply self_tau; eauto. + econstructor 2. + apply eutt_is_eutt'; eauto. + eauto. eauto. + + apply eq_itree_tau_inv1 in H1. + destruct H1 as [t1'' [H1 H1']]. + rewrite H1. constructor. + eapply IHHu; eauto. + rewrite <- unfold_bind. auto. + + apply eq_itree_tau_inv1 in H2. + destruct H2 as [t2'' [H2 H2']]. + rewrite H2. constructor. + eapply IHHu; eauto. + rewrite <- unfold_bind. auto. +Qed. + +End eutt_loop. + Instance eutt_loop {E A B C} : Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B C). Proof. - repeat intro. - subst. -Admitted. + repeat intro; subst. + eapply eutt_loop_inv. + - eauto. + - unfold loop; econstructor; reflexivity. +Qed. From 82917767bfba05ee1d327d1c462bbd7b01a530e5 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Sat, 23 Feb 2019 08:17:38 -0500 Subject: [PATCH 061/142] easy lemma eutt_tau --- theories/Eq/UpToTaus.v | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index f72338d9..40acba31 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -751,8 +751,9 @@ Lemma eutt_tau {E R1 R2} (RR : R1 -> R2 -> Prop) (t1 : itree E R1) (t2 : itree E R2) : eutt RR t1 t2 -> eutt RR (Tau t1) (Tau t2). Proof. - intros; pfold; constructor; auto. -Admitted. + intros H. + pfold. eapply euttF_tau. reflexivity. reflexivity. punfold H. +Qed. Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : From 96eede5caa9da8a7974c7daacbaf71acabe38ee4 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 23 Feb 2019 12:56:48 -0500 Subject: [PATCH 062/142] Finish eutt_loop proof --- theories/Eq/Eq.v | 2 +- theories/Eq/UpToTaus.v | 11 ++++ theories/FixFacts.v | 145 +++++++++++++++++++++++++++++++++++++++-- 3 files changed, 150 insertions(+), 8 deletions(-) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 88c154f0..2e45b34f 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -330,7 +330,7 @@ Proof. eauto. Qed. Lemma unfold_bind {E R S} (t : itree E R) (k : R -> itree E S) : - ITree.bind t k ≅ ITree.bind_match k (ITree.bind' k) (observe t). + ITree.bind t k ≅ ITree.bind_match k (fun t => ITree.bind t k) (observe t). Proof. rewrite itree_eta, bind_unfold, <-itree_eta. reflexivity. Qed. Lemma ret_bind {E R S} (r : R) (k : R -> itree E S) : diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 40acba31..f0e40e04 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -304,6 +304,17 @@ Variant eq_notauF {I J} (eutt : I -> J -> Prop) eq_notauF eutt (VisF e k1) (VisF e k2). Hint Constructors eq_notauF. +Lemma eq_notauF_vis_inv1 {I J} {eutt : I -> J -> Prop} {U} + ot (e : E U) k : + eq_notauF eutt ot (VisF e k) -> + exists k', + ot = VisF e k' /\ (forall x, eutt (k' x) (k x)). +Proof. + intros. remember (VisF e k) as t. + inversion H; subst; try discriminate. + inversion H2; subst; auto_inj_pair2; subst; eauto. +Qed. + (* Variant eq_notauF' {I} (eutt : relation I) : relation (itreeF E R I) := diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 2946f36c..d78c9a7a 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -498,6 +498,7 @@ Inductive loop_preinv (t1 t2 : itree E B) : Prop := . Hint Constructors loop_preinv. +(* TODO: Make this proof less ugly. *) Lemma eutt_loop_inv_main_step (ca : C + A) t1 t2 : t1 ≅ loop_ f1 ca -> t2 ≅ loop_ f2 ca -> @@ -515,7 +516,9 @@ Proof. unfold loop_once in H1. rewrite unfold_bind in H1. destruct (observe (f1 ca)) eqn:Ef1. - - assert (H1unalltaus : @unalltausF E _ (RetF r) (RetF r)). + + 1:{ (* f1 ca = Ret _ *) + assert (H1unalltaus : @unalltausF E _ (RetF r) (RetF r)). { apply untaus_all; constructor. } assert (H2unalltaus : finite_taus (f2 ca)). { apply FIN; eauto. } @@ -526,7 +529,8 @@ Proof. remember (f2 ca) as t2' eqn:Et2; clear Et2. rewrite unfold_bind in H2. genobs t2' ot2'. - induction H2untaus. + revert t2 H2 t2' eutt_f Heqot2'. + induction H2untaus; intros. + inversion EQV; subst. rewrite <- H3 in H2; simpl in H1, H2. destruct r2. * apply eq_itree_tau_inv1 in H1. @@ -538,11 +542,138 @@ Proof. econstructor. { rewrite Ht01'. rewrite <- itree_eta. reflexivity. } { rewrite Ht02'. rewrite <- itree_eta. reflexivity. } - * admit. - + admit. - - admit. - - admit. -Admitted. + * apply eq_itree_ret_inv1 in H1. + apply eq_itree_ret_inv1 in H2. + rewrite H1, H2. auto. + + rewrite <- OBS in H2. apply eq_itree_tau_inv1 in H2. + destruct H2 as [t02 [Ht02 Ht02']]. + rewrite Ht02. + constructor. + eapply IHH2untaus; auto. + erewrite <- (untaus_finite_taus _ (observe t')); eauto. + rewrite <- unfold_bind; auto. + eapply euttF_tau_right; subst; eauto. } + + 2:{ (* f1 ca = Vis _ _ *) + assert (H1unalltaus : @unalltausF E _ (VisF e k) (VisF e k)). + { apply untaus_all; constructor. } + assert (H2unalltaus : finite_taus (f2 ca)). + { apply FIN; eauto. } + destruct H2unalltaus as [ot2 H2unalltaus]. + specialize (EQV _ _ H1unalltaus H2unalltaus). + destruct H2unalltaus as [H2untaus _]. + unfold loop_once in H2. + remember (f2 ca) as t2' eqn:Et2; clear Et2. + rewrite unfold_bind in H2. + genobs t2' ot2'. + revert t2 H2 t2' eutt_f Heqot2'. + induction H2untaus; intros. + + inversion EQV; auto_inj_pair2; subst. + rewrite <- H0 in H2; simpl in H1, H2. + apply eq_itree_vis_inv1 in H1. + apply eq_itree_vis_inv1 in H2. + destruct H1 as [k01 [Hk1 Ht1]]. + destruct H2 as [k02 [Hk2 Ht2]]. + rewrite Hk1, Hk2. + pclearbot. + constructor. + intros; eapply loop_inv_bind; [ eapply H5 | | ]; eauto. + + rewrite <- OBS in H2. apply eq_itree_tau_inv1 in H2. + destruct H2 as [t02 [Ht02 Ht02']]. + rewrite Ht02. + constructor. + eapply IHH2untaus; auto. + erewrite <- (untaus_finite_taus _ (observe t')); eauto. + rewrite <- unfold_bind; auto. + eapply euttF_tau_right; subst; eauto. } + + 1:{ (* f1 ca = Tau _ *) + unfold loop_once in H2. + rewrite unfold_bind in H2. + destruct (observe (f2 ca)) eqn:Ef2. + + 1:{ (* f2 ca = Ret _ *) + rewrite <- Ef1 in *; clear Ef1 t. + assert (H2unalltaus : @unalltausF E _ (RetF r) (RetF r)). + { apply untaus_all; constructor. } + assert (H1unalltaus : finite_taus (f1 ca)). + { apply FIN; eauto. } + destruct H1unalltaus as [ot1 H1unalltaus]. + specialize (EQV _ _ H1unalltaus H2unalltaus). + destruct H1unalltaus as [H1untaus _]. + remember (f1 ca) as t1' eqn:Et1; clear Et1. + genobs t1' ot1'. + revert t1 H1 t1' eutt_f Heqot1'. + induction H1untaus; intros. + + inversion EQV; subst. rewrite <- H0 in H1; simpl in H1, H2. + destruct r. + * apply eq_itree_tau_inv1 in H1. + apply eq_itree_tau_inv1 in H2. + destruct H1 as [t01 [Ht01 Ht01']]. + destruct H2 as [t02 [Ht02 Ht02']]. + rewrite Ht01, Ht02. + constructor. + econstructor. + { rewrite Ht01'. rewrite <- itree_eta. reflexivity. } + { rewrite Ht02'. rewrite <- itree_eta. reflexivity. } + * apply eq_itree_ret_inv1 in H1. + apply eq_itree_ret_inv1 in H2. + rewrite H1, H2. auto. + + rewrite <- OBS in H1. apply eq_itree_tau_inv1 in H1. + destruct H1 as [t01 [Ht01 Ht01']]. + rewrite Ht01. + constructor. + eapply IHH1untaus; auto. + erewrite <- (untaus_finite_taus _ (observe t')); eauto. + rewrite <- unfold_bind; auto. + eapply euttF_tau_left; subst; eauto. } + + 2:{ (* f2 ca = Vis _ _ *) + rewrite <- Ef1 in *; clear Ef1 t. + assert (H2unalltaus : @unalltausF E _ (VisF e k) (VisF e k)). + { apply untaus_all; constructor. } + assert (H1unalltaus : finite_taus (f1 ca)). + { apply FIN; eauto. } + destruct H1unalltaus as [ot1 H1unalltaus]. + specialize (EQV _ _ H1unalltaus H2unalltaus). + destruct H1unalltaus as [H1untaus _]. + remember (f1 ca) as t1' eqn:Et1; clear Et1. + genobs t1' ot1'. + revert t1 H1 t1' eutt_f Heqot1'. + apply eq_notauF_vis_inv1 in EQV. + destruct EQV as [k' [Hot0 Hk']]. + induction H1untaus; intros. + + rewrite Hot0 in H1; simpl in H1, H2. + apply eq_itree_vis_inv1 in H1. + apply eq_itree_vis_inv1 in H2. + destruct H1 as [k01 [Hk1 Ht1]]. + destruct H2 as [k02 [Hk2 Ht2]]. + rewrite Hk1, Hk2. + pclearbot. + constructor. + intros; eapply loop_inv_bind; [ eapply Hk' | | ]; eauto. + + rewrite <- OBS in H1. apply eq_itree_tau_inv1 in H1. + destruct H1 as [t01 [Ht01 Ht01']]. + rewrite Ht01. + constructor. + eapply IHH1untaus; auto. + erewrite <- (untaus_finite_taus _ (observe t')); eauto. + rewrite <- unfold_bind; auto. + eapply euttF_tau_left; subst; eauto. } + + 1:{ (* f2 ca = Tau _ *) + apply eq_itree_tau_inv1 in H1. + apply eq_itree_tau_inv1 in H2. + destruct H1 as [t01 [Ht01 Ht01']]. + destruct H2 as [t02 [Ht02 Ht02']]. + rewrite Ht01, Ht02. + constructor. + eapply loop_inv_bind; try (rewrite <- itree_eta; eauto). + + erewrite <- (tauF_eutt _ t), <- (tauF_eutt _ t0); try eauto. + pfold; auto. } + } + +Qed. Lemma eutt_loop_inv t1 t2 : loop_preinv t1 t2 -> eutt eq t1 t2. From 5757ee13ce646c0c86e8c147e8e88a699a6313d6 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 23 Feb 2019 10:35:07 -0500 Subject: [PATCH 063/142] ci: Manual travis script --- .travis.yml | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 74633849..c1d29c70 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,13 +1,14 @@ language: c sudo: required -install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh -script: bash -ex .travis-opam.sh env: global: - - EXTRA_REMOTES="https://coq.inria.fr/opam/released https://coq.inria.fr/opam/extra-dev" + - OPAMVERBOSE=1 + - OPAMYES=true + - OPAMKEEPBUILDDIR=true + - PACO_VERSION="2.0.2" matrix: - - OCAML_VERSION=4.07 PINS="coq.8.8.2 coq-paco.2.0.2" - - OCAML_VERSION=4.07 PINS="coq.8.9.0 coq-paco.2.0.2" + - OCAML_VERSION=4.07 COQ_VERSION="8.8.2" + - OCAML_VERSION=4.07 COQ_VERSION="8.9.0" os: - linux # - osx @@ -20,3 +21,23 @@ cache: directories: - $HOME/.opam - $HOME/Library/Caches/Homebrew + +before_install: + # Install OCaml and opam + - curl -L https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-ocaml.sh | sh + +install: +- eval $(opam config env) +- opam repo add coq-released https://coq.inria.fr/opam/released +- opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev +- opam pin add coq $COQ_VERSION +- opam pin add coq-paco $PACO_VERSION +- opam upgrade # Upgrade dependencies if cached +- opam pin add coq-itree --kind=path . -n +- opam install coq-itree --deps-only -v +- opam list + +script: +- set -e +- opam install coq-itree -v +- opam remove coq-itree -v From 1344e4eb3e0f0d3153f4c51855624e48a18d165c Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 23 Feb 2019 13:51:51 -0500 Subject: [PATCH 064/142] Makefile: Update test scripts --- Makefile | 1 + tests/Makefile | 15 ++++++++++----- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 0917ed5b..e1bf7810 100644 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ Makefile.coq: _CoqProject clean: Makefile.coq $(MAKE) -f Makefile.coq clean + $(MAKE) -C tests clean $(RM) {*,*/*}/*.{vo,glob} {*,*/*}/.*.aux $(RM) _CoqProject Makefile.coq* $(RM) examples/extracted/*.* diff --git a/tests/Makefile b/tests/Makefile index 77071558..ebe4c01f 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,4 +1,4 @@ -.PHONY: all extraction +.PHONY: all extraction clean all: extraction @@ -7,10 +7,15 @@ all: extraction # ITree library # - Extract.v contains the extraction command for # MetaModule (and recursively its dependencies) +COQC=coqc -Q ../../theories ITree -Q . TestExtraction + extraction: cd extraction; \ - coqc -Q ../../theories ITree \ - -Q . TestExtraction \ - ./MetaModule.v \ - ./Extract.v + $(COQC) ./MetaModule.v; \ + $(COQC) ./Extract.v ocamlbuild extraction/MetaModule.native -no-links + +clean: + $(RM) {*,*/*}/*.{vo,glob} {*,*/*}/.*.aux + $(RM) -rf _build/ + $(RM) extraction/*.ml{i,} From d3b335239f7aa99557c4ac92746b99e9ef55d404 Mon Sep 17 00:00:00 2001 From: Yannick Date: Sat, 23 Feb 2019 16:11:12 -0500 Subject: [PATCH 065/142] Progress in den theory, abstract sequential linking --- examples/Den.v | 206 +++++++++++++++++++++++++++++++++--------- examples/Imp2AsmBis.v | 147 ++++-------------------------- 2 files changed, 183 insertions(+), 170 deletions(-) diff --git a/examples/Den.v b/examples/Den.v index 5d5b43b3..3d3aba0c 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -9,6 +9,7 @@ From Coq Require Import Program Morphisms. +Set Nested Proofs Allowed. (** * Category of denotations *) Inductive done : Set := Done : done. Definition den {E: Type -> Type} A B : Type := A -> itree E (B + done). @@ -58,6 +59,7 @@ Section Den. end. (* Identities *) + Definition I: Type := Empty_set. Definition id_den {A} : denE A A := fun a => Ret (inl a). (* Utility function to lift a pure computation into den *) @@ -69,6 +71,17 @@ Section Den. (ab : denE A B) (cd : denE C D) : den (A + C) (B + D) := sum_elim (compose_den ab (lift_den inl)) (compose_den cd (lift_den inr)). + (* Left and right unitors *) + Definition λ_den {A: Type}: denE (I + A) A := lift_den sum_empty_l. + Definition ρ_den {A: Type}: denE (A + I) A := lift_den sum_empty_r. + + (* Associator *) + Definition assoc_den_l {A B C: Type}: denE (A + (B + C)) ((A + B) + C) := lift_den sum_assoc_l. + Definition assoc_den_r {A B C: Type}: denE ((A + B) + C) (A + (B + C)) := lift_den sum_assoc_r. + + (* Symmetry *) + Definition sym_den {A B: Type}: denE (A + B) (B + A) := lift_den sum_comm. + (* A [box : den (I + A) (I + B)] is a circuit, drawn below as ###, with two input wires labeled by I and A, and two output wires @@ -94,7 +107,7 @@ Section Den. Infix ">=>" := compose_den (at level 50, left associativity). Infix "⊗" := (tensor_den) (at level 30). - Section Facts. + Section Laws. (** *** [compose_den] respect eq_den *) Global Instance eq_den_compose {A B C} : @@ -172,15 +185,6 @@ Section Den. reflexivity. Qed. - Fact lift_den_lift_den {A B C} (f: A -> B) (g: B -> C) : - lift_den f >=> lift_den g ⩰ lift_den (g ∘ f). - Proof. - intros a. - unfold lift_den, compose_den. - rewrite ret_bind. - reflexivity. - Qed. - Fact lift_compose_den {A B C}: forall (f:A -> B) (bc: den B C), lift_den f >=> bc ⩰ fun a => bc (f a). Proof. @@ -218,13 +222,12 @@ Section Den. (** *** [tensor] lemmas *) - Lemma tensor_swap {A B C D} (ab : den A B) (cd : den C D) : - ab ⊗ cd ⩰ (lift_den sum_comm >=> cd ⊗ ab >=> lift_den sum_comm). + Instance eq_den_tensor {A B C D}: + Proper (eq_den ==> eq_den ==> eq_den) (@tensor_den A B C D). Proof. + intros ac ac' eqac bd bd' eqbd. unfold tensor_den. - rewrite !(compose_den_lift cd), !(compose_den_lift ab), !lift_compose_den, !compose_den_lift. - intros []; cbn; rewrite map_map; cbn; - apply eutt_map; try intros []; reflexivity. + rewrite eqac, eqbd; reflexivity. Qed. Fact tensor_id_lift {A B C} (f : B -> C) : @@ -245,28 +248,136 @@ Section Den. reflexivity. Qed. - (** *** [loop] lemmas *) + Lemma assoc_I {A B}: + @assoc_den_r A I B >=> id_den ⊗ λ_den ⩰ ρ_den ⊗ id_den. + Proof. + unfold ρ_den,λ_den. + rewrite tensor_lift_id, tensor_id_lift. + unfold assoc_den_r. + rewrite compose_lift_den. + apply eq_lift_den. + intros [[|]|]; compute; try reflexivity. + destruct i. + Qed. - Global Instance eq_den_loop {I A B} : - Proper (eq_den ==> eq_den) (@loop_den I A B). + Lemma lift_den_id {A: Type}: @id_den A ⩰ lift_den id. + Proof. + unfold id_den, lift_den; reflexivity. + Qed. + + Lemma sum_elim_compose {A B C D F}: + forall (ac: denE A (C + D)) (bc: denE B (C + D)) (cf: denE C F) (df: denE D F), + sum_elim ac bc >=> sum_elim cf df ⩰ + sum_elim (ac >=> (sum_elim cf df)) (bc >=> (sum_elim cf df)). Proof. - Admitted. + intros. + unfold compose_den. + intros []; reflexivity. + Qed. - (* Should be a consequence of the others. *) - Lemma seq_loop_l_seq {A B C I} - (ab : den (I + A) (I + B)) (bc : den B C) : - loop_den ab >=> bc ⩰ - loop_den (ab >=> tensor_den id_den bc). + Lemma inl_sum_elim {A B C}: + forall (ac: denE A C) (bc: denE B C), + lift_den inl >=> sum_elim ac bc ⩰ ac. Proof. - Admitted. + intros. + unfold compose_den, lift_den. + intros ?. + rewrite ret_bind. + reflexivity. + Qed. - (* Should be a consequence of the others *) - Lemma seq_loop_r_seq {A B C I} - (ab : den A B) (bc : den (I + B) (I + C)) : - ab >=> loop_den bc ⩰ - loop_den (tensor_den id_den ab >=> bc). + Lemma inr_sum_elim {A B C}: + forall (ac: denE A C) (bc: denE B C), + lift_den inr >=> sum_elim ac bc ⩰ bc. Proof. - Admitted. + intros. + unfold compose_den, lift_den. + intros ?. + rewrite ret_bind. + reflexivity. + Qed. + + Lemma tensor_den_slide {A B C D}: + forall (ac: @den E A C) (bd: den B D), + ac ⊗ bd ⩰ ac ⊗ id_den >=> id_den ⊗ bd. + Proof. + intros. + unfold tensor_den. + repeat rewrite id_den_left. + rewrite sum_elim_compose. + rewrite compose_den_assoc. + rewrite inl_sum_elim, inr_sum_elim. + reflexivity. + Qed. + + Lemma assoc_coherent {A B C D}: + @assoc_den_r A B C ⊗ @id_den D >=> assoc_den_r >=> id_den ⊗ assoc_den_r ⩰ + assoc_den_r >=> assoc_den_r. + Proof. + unfold tensor_den, assoc_den_r. + repeat rewrite id_den_left. + repeat rewrite compose_sum_elim. + repeat rewrite compose_lift_den. + rewrite lift_sum_elim. + repeat rewrite compose_lift_den. + rewrite lift_sum_elim. + apply eq_lift_den. + intros [[[|]|]|]; reflexivity. + Qed. + + (** *** [sym] lemmas *) + + Lemma sym_unit_den {A} : + sym_den >=> λ_den ⩰ @ρ_den A. + Proof. + unfold sym_den, ρ_den, λ_den. + rewrite lift_compose_den. + intros []; simpl; reflexivity. + Qed. + + Lemma sym_assoc_den {A B C}: + @assoc_den_r A B C >=> sym_den >=> assoc_den_r ⩰ + (sym_den ⊗ id_den) >=> assoc_den_r >=> (id_den ⊗ sym_den). + Proof. + unfold assoc_den_r, sym_den. + rewrite tensor_lift_id, tensor_id_lift. + repeat rewrite compose_lift_den. + apply eq_lift_den. + intros [[|]|]; compute; reflexivity. + Qed. + + Lemma sym_nilpotent {A B: Type}: + sym_den >=> sym_den ⩰ @id_den (A + B). + Proof. + unfold sym_den, id_den. + rewrite compose_lift_den. + unfold compose. + unfold lift_den; intros a. + setoid_rewrite iso_ff'; reflexivity. + Qed. + + Lemma tensor_swap {A B C D} (ab : den A B) (cd : den C D) : + ab ⊗ cd ⩰ (sym_den >=> cd ⊗ ab >=> sym_den). + Proof. + unfold tensor_den. + unfold sym_den. + rewrite !(compose_den_lift cd), !(compose_den_lift ab), !lift_compose_den, !compose_den_lift. + intros []; cbn; rewrite map_map; cbn; + apply eutt_map; try intros []; reflexivity. + Qed. + + (** *** [loop] lemmas *) + + Global Instance eq_den_loop {I A B} : + Proper (eq_den ==> eq_den) (@loop_den I A B). + Proof. + repeat intro. + unfold loop_den. + apply eutt_loop; [| reflexivity]. + intros ? z ->. + unfold compose. + rewrite (H z); reflexivity. + Qed. (* Naturality of (loop_den I A B) in A *) (* Or more diagrammatically: @@ -288,11 +399,23 @@ A----B----###----C ]] *) + Lemma bind_map: forall {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z), + eq_itree eq (ITree.map f (x <- t;; k x)) (x <- t;; ITree.map f (k x)). + Proof. + intros. + unfold ITree.map. + rewrite bind_bind. + reflexivity. + Qed. + + Lemma compose_loop {I A B C}: forall (bc_: denE (I + B) (I + C)) (ab: denE A B), loop_den ((id_den ⊗ ab) >=> bc_) ⩰ ab >=> loop_den bc_. + Proof. Admitted. + (* Naturality of (loop_den I A B) in B *) (* Or more diagrammatically: @@ -328,6 +451,7 @@ A----###----B----C loop_den ((ji ⊗ id_den) >=> ab_). Admitted. + (* [loop_loop]: These two loops: @@ -356,24 +480,23 @@ These two loops: *) - (* I do not see a way to avoid the use of lift_den. *) - - Notation rewire_den f g ab := - (lift_den f >=> ab >=> lift_den g) (only parsing). - Lemma loop_loop {I J A B}: forall (ab__: denE (I + (J + A)) (I + (J + B))), loop_den (loop_den ab__) ⩰ - loop_den (rewire_den sum_assoc_r sum_assoc_l ab__). + loop_den (assoc_den_r >=> ab__ >=> assoc_den_l). Admitted. Lemma tensor_den_loop {I A B C D} (ab : denE (I + A) (I + B)) (cd : denE C D) : - (loop_den ab) ⊗ cd ⩰ - loop_den (rewire_den sum_assoc_l sum_assoc_r (ab ⊗ cd)). + (loop_den ab) ⊗ cd ⩰ + loop_den (assoc_den_l >=> (ab ⊗ cd) >=> assoc_den_r). Proof. Admitted. + Lemma yanking_den {A: Type}: + loop_den sym_den ⩰ @id_den A. + Admitted. + (* Lemma loop_relabel {I J A B} *) (* (f : I -> J) {f' : J -> I} *) (* {ISO_f : Iso f f'} *) @@ -383,7 +506,7 @@ These two loops: (* Proof. *) (* Admitted. *) - End Facts. + End Laws. End Den. Bind Scope den_scope with den. @@ -392,11 +515,8 @@ Infix ">=>" := compose_den (at level 50, left associativity). Infix "⊗" := (tensor_den) (at level 30). Hint Rewrite @compose_den_assoc : lift_den. -Hint Rewrite @lift_den_lift_den : lift_den. -Hint Rewrite @compose_lift_den_l : lift_den. Hint Rewrite @tensor_id_lift : lift_den. Hint Rewrite @tensor_lift_id : lift_den. Hint Rewrite @lift_sum_elim : lift_den. -Hint Rewrite @compose_lift_den : lift_den. diff --git a/examples/Imp2AsmBis.v b/examples/Imp2AsmBis.v index 20d2fa83..39678871 100644 --- a/examples/Imp2AsmBis.v +++ b/examples/Imp2AsmBis.v @@ -16,134 +16,27 @@ Require Import Den. Section Linking. - Variable E0 : Type -> Type. - Notation den := (@den E0). + Variable E : Type -> Type. - (* Definition cat_b {A B C D}: *) - (* (bks A B) -> *) - (* (bks C D) -> *) - (* (bks (A + C) (B + D)) := *) - (* fun ab cd oac => *) - (* match oac with *) - (* | inl a => fmap_block inl (ab a) *) - (* | inr c => fmap_block inr (cd c) *) - (* end. *) - - (* Definition rewire_b {A B C D}: *) - (* (C -> A) -> *) - (* (B -> D) -> *) - (* (bks A B) -> *) - (* (bks C D) := *) - (* fun f g ab c => *) - (* fmap_block g (ab (f c)). *) - - (* - (* Correctness of [cat_b] and [rewire_b] (easy) - YZ: Those depend on the implementation. Should they be assumed by the theory? - *) - - Lemma cat_correct {A B C D} (ab : bks A B) (cd : bks C D) : - eq_den (denote_b E0 (cat_b ab cd)) - (juxta_den (denote_b _ ab) (denote_b E0 cd)). - Admitted. - - Lemma rewire_correct {A B C D} (f : C -> A) (g : B -> D) (ab : bks A B) : - eq_den (denote_b _ (rewire_b f g ab)) - (rewire_den' f g (denote_b _ ab)). - Admitted. - *) - - (* Opaque compose. *) - (* Opaque id. *) - (* Opaque sum_elim. *) - - (* Definition rw {I B J C} : *) - (* (I + B) + (J + C) -> (I + J + B) + C := *) - (* Eval compute in resum. *) - - (* Definition corw {A I B J} : (I + J + B) + A -> (I + A) + (J + B) := *) - (* Eval compute in resum. *) - - (* Transparent compose. *) - (* Transparent id. *) - (* Transparent sum_elim. *) - - - (* Sequential composition of bks. *) - -(* - Definition rw {I B J C} : - (I + B) + (J + C) -> (I + J + B) + C := - Eval compute in resum. - - Definition corw {A I B J} : (I + J + B) + A -> (I + A) + (J + B) := - Eval compute in resum. - - - Definition rewire_b {A B C D}: - (C -> A) -> - (B -> D) -> - (bks A B) -> - (bks C D) := - fun f g ab c => - fmap_block g (ab (f c)). - - Definition cat_b {A B C D}: - (bks A B) -> - (bks C D) -> - (bks (A + C) (B + D)) := - fun ab cd oac => - match oac with - | inl a => fmap_block inl (ab a) - | inr c => fmap_block inr (cd c) - end. - - Definition seq_bks {A I B J C} - (ab : bks (I + A) (I + B)) - (bc : bks (J + B) (J + C)) : - bks ((I + J + B) + A) ((I + J + B) + C) := - rewire_b corw rw (cat_b ab bc). - -*) - - (* TODO: redefine seq_den purely in term of Den.v *) - (* - Definition seq_den {A I B J C} - (ab: den (I + A) (I + B)) - (bc: den (J + B) (J + C)) := - den ((I + J + B) + A) ((I + J + B) + C) := - _ + Definition link_seq_den {A B C} + (ab: @den E A B) + (bc: den B C): den A C := + loop_den (sym_den >=> ab ⊗ bc). Theorem seq_correct {A B C} (ab : den A B) (bc : den B C) : - (seq_den ab bc) ⩰ ab >=> bc. + (link_seq_den ab bc) ⩰ ab >=> bc. Proof. - unfold denote_asm, seq_asm; simpl. - unfold seq_bks. -*) - -(* - Can we prove this without rewire? - In particular, need loop_loop - - (* rewrite rewire_correct. *) - (* rewrite cat_correct. *) - rewrite seq_loop_l. - rewrite tensor_den_loop. - rewrite seq_loop_r_seq. - rewrite seq_loop_l_seq. - rewrite loop_loop. - rewrite (juxta_swap (_ (code bc))). - rewrite (loop_relabel (sum_bimap sum_comm id ∘ sum_assoc_l)). - autorewrite with lift_den. - (* Now everything matches except [lift_den] *) - apply eq_den_loop. - apply eq_den_cat. - - apply eq_lift_den. - intros [[[] | ] | ] ? []; auto. - - apply eq_den_cat. - + reflexivity. - + apply eq_lift_den. - intros [[] | [] ] ? []; auto. - *) - - (* Qed. *) + unfold link_seq_den. + rewrite tensor_den_slide. + rewrite <- compose_den_assoc. + rewrite loop_compose. + rewrite tensor_swap. + repeat rewrite <- compose_den_assoc. + rewrite sym_nilpotent, id_den_left. + rewrite compose_loop. + erewrite yanking_den. + rewrite id_den_right. + reflexivity. + Qed. + +End Linking. From 60dcc775c7ff4f9aa4da415d560ce3d2c83c1797 Mon Sep 17 00:00:00 2001 From: Yannick Date: Sat, 23 Feb 2019 16:12:34 -0500 Subject: [PATCH 066/142] Renaming Imp2AsmBis --- examples/{Imp2AsmBis.v => Linking.v} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename examples/{Imp2AsmBis.v => Linking.v} (100%) diff --git a/examples/Imp2AsmBis.v b/examples/Linking.v similarity index 100% rename from examples/Imp2AsmBis.v rename to examples/Linking.v From 4b8eb4b3360af93dca6346560432d794925a1208 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Sat, 23 Feb 2019 16:21:42 -0500 Subject: [PATCH 067/142] reformulation of translate to not use interp --- theories/Translate.v | 177 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) create mode 100644 theories/Translate.v diff --git a/theories/Translate.v b/theories/Translate.v new file mode 100644 index 00000000..c991b007 --- /dev/null +++ b/theories/Translate.v @@ -0,0 +1,177 @@ +(** This file is about the structure of itree morphisms induced by + event morphisms via the [translate] operation defined herein. + + Translate should be defined separately from the Morphisms because it + is conceptually at a different level and translation always yields + strong bisimulations. We can relate them via the law: + + translate h t ≈ interp (liftE ∘ h) t + *) + +From ExtLib Require + Structures.Monoid. + +From ITree Require Import + Basics + Core + Effect.Sum + OpenSum. + +Open Scope itree_scope. + +(** A plain effect morphism [E ~> F] defines an itree morphism + [itree E ~> itree F]. *) +Definition translateF {E F R} (h : E ~> F) (rec: itree E R -> itree F R) (t : itreeF E R _) : itree F R := + match t with + | RetF x => Ret x + | TauF t => Tau (rec t) + | VisF e k => Vis (h _ e) (fun x => rec (k x)) + end. + +CoFixpoint translate {E F R} (h : E ~> F) (t : itree E R) : itree F R + := translateF h (translate h) (observe t). + +(* SAZ: Should be moved to TranslateFacts.v *) +(* translate facts ---------------------------------------------------------- *) +From ITree Require Import + Eq + UpToTaus. + +From Paco Require Import paco. + +From Coq Require Import + Program + Setoid + Morphisms + RelationClasses. + +Section TranslateFacts. + Context {E F : Type -> Type}. + Context {R : Type}. + Context (h : E ~> F). + +Lemma unfold_translate : forall (t : itree E R), + observe (translate h t) = observe (translateF h (translate h) (observe t)). +Proof. + intros t. reflexivity. +Qed. + +Lemma translate_ret : forall (r:R), translate h (Ret r) ≅ Ret r. +Proof. + intros r. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Lemma translate_tau : forall (t : itree E R), translate h (Tau t) ≅ Tau (translate h t). +Proof. + intros t. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Lemma translate_vis : forall X (e:E X) (k : X -> itree E R), + translate h (Vis e k) ≅ Vis (h _ e) (fun x => translate h (k x)). +Proof. + intros X e k. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Global Instance translate_Proper : Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h). +Proof. + repeat red. + intros x y H. + pupto2_init. + revert x y H. + pcofix CIH. + intros x y H. + rewrite itree_eta. + rewrite (itree_eta (translate h y)). + repeat rewrite unfold_translate. unfold translateF. + rewrite (itree_eta x) in H. + rewrite (itree_eta y) in H. + destruct (observe x); destruct (observe y); pinversion H; subst; cbn. + - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution not working *) + - pupto2_final. pfold. constructor. right. apply CIH. eauto. + - pupto2_final. pfold. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + constructor. + inversion H. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + right. apply CIH. + eapply transitivity. pclearbot. apply REL0. reflexivity. +Qed. +End TranslateFacts. + +Lemma translate_bind : forall {E F R S} (h : E ~> F) (t : itree E S) (k : S -> itree E R), + translate h (x <- t ;; k x) ≅ (x <- (translate h t) ;; translate h (k x)). +Proof. + intros E F R S h t k. + pupto2_init. + revert S t k. + pcofix CIH. + intros s t k. + rewrite itree_eta. + rewrite (itree_eta (x <- translate h t;; translate h (k x))). + rewrite unfold_translate. + repeat rewrite bind_unfold. + rewrite unfold_translate. + unfold translateF. + unfold ITree.bind_match. + destruct (observe t); cbn. + - rewrite unfold_translate. unfold translateF. + pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +(* categorical properties --------------------------------------------------- *) + +Import Sum1. + +Lemma translate_id : forall E R (t : itree E R), translate idE t ≅ t. +Proof. + intros E R t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta t). + rewrite unfold_translate. + unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +Lemma translate_cmpE : forall E F G R (g : F ~> G) (f : E ~> F) (t : itree E R), + translate (cmpE g f) t ≅ translate g (translate f t). +Proof. + intros E F G R g f t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta (translate g (translate f t))). + repeat rewrite unfold_translate. + unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +(* SAZ: TODO - it would be good to allow for rewriting of event morphisms under translate: + + E ~~ F -> translate E t ≅ translate F t + + Where E ~~ F is extensional equality. +*) \ No newline at end of file From b3c85a7fb6bfc48208a4f84cd947c97c01ed2256 Mon Sep 17 00:00:00 2001 From: Yannick Date: Sat, 23 Feb 2019 19:52:54 -0500 Subject: [PATCH 068/142] Rewriting the compiler --- examples/Imp2Asm.v | 433 ++++++++++++--------------------------------- 1 file changed, 114 insertions(+), 319 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 2043d511..d7cee01b 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -71,344 +71,114 @@ Section fmap_block. end. End fmap_block. -Variant WhileBlocks : Set := -| WhileTop -| WhileBottom. - -(* - Compiles a statement given a partially built continuation 'k' expressed as a block. - *) -(* YZ: Need another generator of fresh variables to store the result of conditionals. - Though they should never be reused if I'm not mistaken, so a unique reserved id as currently is might actually simply do the trick. - To double check. - *) - -(* this is what we need for seq *) -Definition link_seq (p1 : program unit) (p2 : program unit) : program unit. -refine - (let transL l := +Definition link_seq (p1: asm unit Empty_set) (p2: asm unit Empty_set): asm unit Empty_set := + let transL l := match l with | inl l => inl (inl l) - | inr tt => inl (inr None) (* *) + | inr _ => inl (inr None) + end + in + let transR l := + match l with + | inl l => inl (inr (Some l)) + | inr l => inr l + end + in + {| internal := p1.(internal) + option p2.(internal) + ; code l := + match l with + | inl (inl l) => (* p1's internal *) + fmap_block transL (p1.(code) (inl l)) + | inl (inr None) => (* p2's entry point *) + fmap_block transR (p2.(code) (inr tt)) + | inl (inr (Some l)) => (* p2's internal *) + fmap_block transR (p2.(code) (inl l)) + | inr tt => (* p1's entry point *) + fmap_block transL (p1.(code) (inr tt)) + end + |}. + +Definition link_if (e : list instr) (lp : asm unit Empty_set) (rp : asm unit Empty_set) : asm unit Empty_set := + let to_left l := + match l with + | inl l => inl (inl (Some l)) + | inr l => inr l + end + in + let to_right l := + match l with + | inl l => inl (inr (Some l)) + | inr l => inr l end in - let transR l := - match l with - | inl l => inl (inr (Some l)) - | inr tt => inr tt - end - in - {| label := p1.(label) + option p2.(label) - ; main := fmap_block transL p1.(main) - ; blocks l := - match l with - | inl l => fmap_block transL (p1.(blocks) l) - | inr None => fmap_block transR p2.(main) - | inr (Some l) => fmap_block transR (p2.(blocks) l) - end - |}). -Defined. - -Definition link_if (b : block bool) (p1 : program unit) (p2 : program unit) -: program unit. -refine - (let to_right x := - match x with - | inl y => inl (inr (Some y)) - | inr y => inr y - end - in - let to_left x := - match x with - | inl y => inl (inl (Some y)) - | inr y => inr y - end - in - let lc := p1 in - let rc := p2 in - - {| label := option lc.(label) + option rc.(label) - ; blocks := fun x => - match x with - | inl None => - fmap_block to_left lc.(main) - | inl (Some x) => - fmap_block to_left (lc.(blocks) x) - | inr None => - fmap_block to_right rc.(main) - | inr (Some x) => - fmap_block to_right (rc.(blocks) x) - end - ; main := - fmap_block (fun l => - match l with - | true => inl (inl None) - | false => inl (inr None) - end) b - |}). -Defined. - -Definition link_while (b : block bool) (p1 : program unit) -: program unit. -Admitted. - - -(* -Record program2 (exports imports : Type) : Type := - { internal2 : Type - ; names : exports -> internal2 - ; blocks2 : internal2 -> block (internal2 + imports) }. - -Definition link2 {A B C} (p1 : program2 A (B + C)) (p2 : program2 B (A + C)) -: program2 (A + B) C. - -rec : program2 a (a + b) -> program a b -*) - -(* we could change this to `stmt -> program unit` and then compile the subterms - * and then replace some of the jumps to do the actual linking. - * - * the type of `program` can not be printed because the type of labels is - * exitentially quantified. it could be replaced with a finite map. - *) -Fixpoint compile2 (s : stmt) {struct s} : program unit. - refine - match s with - - | Skip => - - {| label := Empty_set - ; blocks := fun x => match x with end - ; main := bbb (Bjmp (inr tt)) |} - - | Assign x e => - - {| label := Empty_set - ; blocks := fun x => match x with end - ; main := after (compile_assign x e) - (bbb (Bjmp (inr tt))) |} - - | Seq l r => - - link_seq (compile2 l) (compile2 r) - | If e l r => + {| internal := option lp.(internal) + option rp.(internal) + ; code l := + match l with + | inr tt => (* Entry point to the conditional *) + after e (bbb (Bbrz (gen_tmp 0) (inl (inl None)) (inl (inr None)))) + | inl (inl None) => (* Entry point to the left branch *) + fmap_block to_left (lp.(code) (inr tt)) + | inl (inl (Some l)) => (* Inside the left branch *) + fmap_block to_left (lp.(code) (inl l)) + | inl (inr None) => (* Entry point to the right branch *) + fmap_block to_right (rp.(code) (inr tt)) + | inl (inr (Some l)) => (* Inside the right branch *) + fmap_block to_right (rp.(code) (inl l)) + end + |}. - let to_right x := - match x with - | inl y => inl (inr (Some y)) - | inr y => inr y - end - in - let to_left x := - match x with - | inl y => inl (inl (Some y)) - | inr y => inr y - end - in - let lc := compile2 l in - let rc := compile2 r in - - {| label := option lc.(label) + option rc.(label) - ; blocks := fun x => - match x with - | inl None => - fmap_block to_left lc.(main) - | inl (Some x) => - fmap_block to_left (lc.(blocks) x) - | inr None => - fmap_block to_right rc.(main) - | inr (Some x) => - fmap_block to_right (rc.(blocks) x) - end - ; main := - after (compile_expr 0 e) - (bbb (Bbrz (gen_tmp 0) - (inl (inl None)) - (inl (inr None)))) - |} - - | While e b => - let bc := compile2 b in - {| label := WhileBlocks - + option bc.(label) - ; blocks := - let convert x := - match x with - | inl x => inl (inr (Some x)) - | inr x => inl (inl WhileTop) - end - in fun x => - match x with - | inl WhileTop => (* before evaluating e *) - after (compile_expr 0 e) - (bbb (Bbrz (gen_tmp 0) - (inl (inr None)) - (inl (inl WhileBottom)))) - | inl WhileBottom => (* after the loop exits *) - bbb (Bjmp (inr tt)) - | inr None => - fmap_block convert bc.(main) - | inr (Some x) => - fmap_block convert (bc.(blocks) x) - end - ; main := bbb (Bjmp (inl (inl WhileTop))) - |} - end. -Defined. +Variant WhileBlocks : Set := +| WhileTop +| WhileBottom. +Definition link_loop (e : list instr) (bp : asm unit Empty_set): asm unit Empty_set := + let to_body l := + match l with + | inl l => inl (inr l) + | inr l => inr l + end + in + {| internal := WhileBlocks + bp.(internal) + ; code l := + match l with + | inr tt => (* Entry point to the loop *) + after e (bbb (Bbrz (gen_tmp 0) (inl (inl WhileTop)) (inl (inl WhileBottom)))) + | inl (inl WhileTop) => (* Entry point to the body *) + fmap_block to_body (bp.(code) (inr tt)) + | inl (inl WhileBottom) => (* Exit point *) + bbb Bhalt + | inl (inr l) => (* Inside the body *) + fmap_block to_body (bp.(code) (inl l)) + end + |}. -(* we could change this to `stmt -> program unit` and then compile the subterms - * and then replace some of the jumps to do the actual linking. - * - * the type of `program` can not be printed because the type of labels is - * exitentially quantified. it could be replaced with a finite map. - *) -Fixpoint compile (s : stmt) {L} (k : block L) {struct s} : program L. - refine - match s with - - | Skip => - - {| label := Empty_set - ; blocks := fun x => match x with end - ; main := fmap_block inr k |} - - | Assign x e => - - {| label := Empty_set - ; blocks := fun x => match x with end - ; main := after (compile_assign x e) - (fmap_block inr k) |} - - | Seq l r => - - let reassoc := - (fun x => match x with - | inl x => inl (inl x) - | inr (inl x) => inl (inr x) - | inr (inr x) => inr x - end) - in - let to_right := - (fun x => match x with - | inl x => inl (inr x) - | inr x => inr x - end) - in - - let rc := @compile r L k in - let lc := @compile l (sum rc.(label) L) rc.(main) in - - {| label := lc.(label) + rc.(label) - ; blocks := fun x => - match x with - | inl x => fmap_block reassoc (lc.(blocks) x) - | inr x => fmap_block to_right (rc.(blocks) x) - end - ; main := - fmap_block reassoc lc.(main) |} +Set Nested Proofs Allowed. -(* - let lc := @compile l unit (bbb (Bjmp tt)) in - let rc := @compile r L k in - - {| label := lc.(label) + option rc.(label) - ; blocks := fun x => - match x with - | inr None => fmap_block _ rc.(main) - | inl x => fmap_block _ (lc.(blocks) x) - | inr (Some x) => fmap_block _ (rc.(blocks) x) - end - ; main := - fmap_block _ lc.(main) |} -*) - | If e l r => - let to_right := (fun x => - match x with - | inl y => inl (inr (Some y)) - | inr y => inr y - end) - in - let to_left := (fun x => - match x with - | inl y => inl (inl (Some y)) - | inr y => inr y - end) - in - let lc := @compile l L k in - let rc := @compile r L k in - - {| label := option lc.(label) + option rc.(label) - ; blocks := fun x => - match x with - | inl None => - fmap_block to_left lc.(main) - | inl (Some x) => - fmap_block to_left (lc.(blocks) x) - | inr None => - fmap_block to_right rc.(main) - | inr (Some x) => - fmap_block to_right (rc.(blocks) x) - end - ; main := - after (compile_assign "_jump_var" e) - (bbb (Bbrz "_jump_var" - (inl (inl None)) - (inl (inr None)))) - |} - - | While e b => - let bc := compile b unit (bbb (Bjmp tt)) in - {| label := WhileBlocks - + option bc.(label) - ; blocks := - let convert x := - match x with - | inl x => inl (inr (Some x)) - | inr x => inl (inl WhileTop) - end - in fun x => - match x with - | inl WhileTop => (* before evaluating e *) - after (compile_assign "_jump_var" e) - (bbb (Bbrz "_jump_var" - (inl (inr None)) - (inl (inl WhileBottom)))) - | inl WhileBottom => (* after the loop exits *) - fmap_block inr k - | inr None => - fmap_block convert bc.(main) - | inr (Some x) => - fmap_block convert (bc.(blocks) x) - end - ; main := bbb (Bjmp (inl (inl WhileTop))) - |} +Fixpoint compile (s : stmt) {struct s} : asm unit Empty_set := + match s with - end. -Defined. + | Skip => -Section tests. + {| internal := Empty_set + ; code := fun _ => bbb Bhalt |} - Import ImpNotations. + | Assign x e => - Definition ex1: stmt := - "x" ← 1. + {| internal := Empty_set + ; code := fun _ => after (compile_assign x e) + (bbb Bhalt) |} - (* The result is a bit annoying to read in that it keeps around absurd branches *) - Compute (compile ex1). + | Seq l r => link_seq (compile l) (compile r) - Definition ex_cond: stmt := - "x" ← 1;;; - IF "x" - THEN "res" ← 2 - ELSE "res" ← 3. - Compute (compile ex_cond). + | If e l r => link_if (compile_expr 0 e) (compile l) (compile r) -End tests. + | While e b => link_loop (compile_expr 0 e) (compile b) + + end. Section denote_list. @@ -1503,3 +1273,28 @@ l: [x] l1: ...; jmp[a] l2: ...; jmp[b] *) + +(* + +Section tests. + + Import ImpNotations. + + Definition ex1: stmt := + "x" ← 1. + + (* The result is a bit annoying to read in that it keeps around absurd branches *) + Compute (compile ex1). + + Definition ex_cond: stmt := + "x" ← 1;;; + IF "x" + THEN "res" ← 2 + ELSE "res" ← 3. + + Compute (compile ex_cond). + +End tests. + + +*) \ No newline at end of file From 6bbc01680ce4eb02e23496331f25270c924d2ef0 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 23 Feb 2019 16:17:56 -0500 Subject: [PATCH 069/142] Prove eutt_interp1 and state eutt_interp_state --- examples/Imp2Asm.v | 4 ---- theories/MorphismsFacts.v | 14 ++++++++++++++ 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index d7cee01b..91b19afd 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -285,10 +285,6 @@ Section EUTT. Proof. Admitted. - Lemma interp1_eq_eutt {F: Type -> Type} (h: E ~> itree F) R: - @Proper (itree (E +' F) R -> itree F R) (eutt eq ==> eutt eq) (interp1 h R). - Admitted. - End EUTT. Section GEN_TMP. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 9765d76d..3d04ad49 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -284,6 +284,15 @@ Proof. + intros. pupto2_final. eauto. Qed. +Instance eutt_interp1 {E F: Type -> Type} (h: E ~> itree F) R: + Proper (eutt eq ==> eutt eq) (@interp1 E F F _ h R). +Proof. + repeat intro. + rewrite <- 2 interp_is_interp1. + eapply eutt_interp; auto. + red; reflexivity. +Qed. + (** * [interp_state] *) Lemma unfold_interp_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, @@ -499,6 +508,11 @@ Proof. specialize (CIH _ (k0 v) k s). auto. Qed. +Instance eutt_interp_state {E F: Type -> Type} {S : Type} + (h : E ~> Monads.stateT S (itree F)) R : + Proper (eutt eq ==> eq ==> eutt eq) (@interp_state E F S h R). +Proof. +Admitted. (* Translate facts ---------------------------------------------------------- *) From 22a107038f216ef358a9af3a095defa591ae00fb Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 23 Feb 2019 18:11:19 -0500 Subject: [PATCH 070/142] Shallow itree equivalence --- _CoqConfig | 1 + theories/Eq/Eq.v | 115 +++++++++++++------------------ theories/Eq/Shallow.v | 141 ++++++++++++++++++++++++++++++++++++++ theories/Eq/UpToTaus.v | 53 +++++++------- theories/FixFacts.v | 12 ++-- theories/MorphismsFacts.v | 32 +++++---- 6 files changed, 239 insertions(+), 115 deletions(-) create mode 100644 theories/Eq/Shallow.v diff --git a/_CoqConfig b/_CoqConfig index 9c90ec9c..d8288dbb 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -4,6 +4,7 @@ theories/Basics.v theories/Basics_Functions.v theories/Core.v +theories/Eq/Shallow.v theories/Eq/Eq.v theories/Eq/UpToTaus.v diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 2e45b34f..f9030cfa 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -8,14 +8,16 @@ From Coq Require Import Program Setoid Morphisms - RelationClasses - ProofIrrelevance. + RelationClasses. From Paco Require Import paco. From ITree Require Import Core. +From ITree Require Export + Eq.Shallow. + (* TODO: Send to paco *) Global Instance Symmetric_bot2 (A : Type) : @Symmetric A bot2. Proof. auto. Qed. @@ -23,33 +25,6 @@ Proof. auto. Qed. Global Instance Transitive_bot2 (A : Type) : @Transitive A bot2. Proof. auto. Qed. -Ltac auto_inj_pair2 := - repeat (match goal with - | [ H : _ |- _ ] => apply inj_pair2 in H - end). - -Definition go_sim {E R1 R2} (r : itree E R1 -> itree E R2 -> Prop) : - itreeF E R1 (itree E R1) -> itreeF E R2 (itree E R2) -> Prop := - fun ot1 ot2 => r (go ot1) (go ot2). - -Global Instance Equivalence_go_sim E R sim - (Esim : @Equivalence (itree E R) sim) : - Equivalence (go_sim sim). -Proof. - constructor; red; unfold go_sim. - - reflexivity. - - symmetry; eauto. - - etransitivity; eauto. -Qed. - -Global Instance subrelation_go_sim E R sim sim' : - @subrelation (itree E R) sim sim' -> - subrelation (go_sim sim) (go_sim sim'). -Proof. cbv; eauto. Qed. - -Lemma pointwise_relation_fold {A B} {r: relation B} f g: (forall v:A, r (f v) (g v)) -> pointwise_relation _ r f g. - Proof. red. eauto. Qed. - Section eq_itree. Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). @@ -194,34 +169,22 @@ Proof. constructor; typeclasses eauto. Qed. -Global Instance eq_itree_go : - Proper (go_sim eq_itree ==> eq_itree) (@go E R). -Proof. - repeat intro. eauto. -Qed. - Global Instance eq_itree_observe : - Proper (eq_itree ==> go_sim eq_itree) (@observe E R). + Proper (eq_itree ==> going eq_itree) (@observe E R). Proof. - repeat intro. punfold H. pfold. eapply eq_itreeF_mono; eauto. + constructor; punfold H. pfold. eapply eq_itreeF_mono; eauto. Qed. Global Instance eq_itree_tauF : - Proper (eq_itree ==> go_sim eq_itree) (@TauF E R _). + Proper (eq_itree ==> going eq_itree) (@TauF E R _). Proof. - repeat intro. pfold. econstructor. eauto. + constructor; pfold. econstructor. eauto. Qed. Global Instance eq_itree_VisF {u} (e: E u) : - Proper (pointwise_relation _ eq_itree ==> go_sim eq_itree) (VisF e). + Proper (pointwise_relation _ eq_itree ==> going eq_itree) (VisF e). Proof. - repeat intro. red in H. pfold. econstructor. left. apply H. -Qed. - -Lemma itree_eta (t: itree E R): eq_itree t (go (observe t)). -Proof. - pfold. red. cbn. apply Reflexive_eq_itreeF. - auto using reflexivity. + constructor; red in H. pfold; econstructor. left. apply H. Qed. Inductive eq_itree_trans_clo (r : itree E R -> itree E R -> Prop) : @@ -253,6 +216,26 @@ Proof. econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto using rclo2. Qed. + Global Instance observing_eq_itree_eq_ r `{Reflexive _ r} : + subrelation (observing eq) (eq_itree_ r). + Proof. + repeat red; intros x _ [[]]; destruct observe; auto. + Qed. + + Global Instance observing_eq_itree_eq : + subrelation (observing eq) eq_itree. + Proof. + repeat red; intros; pfold. apply observing_eq_itree_eq_; auto. + left; apply reflexivity. + Qed. + +(* TODO: This should follow from [itree_eta_] and [observing eq] + being a subrelation of [eq_itree], but at the moment instance + resolution is somehow slow for [observing eq]. + (e.g., [interp_bind]) *) +Lemma itree_eta (t: itree E R): eq_itree t (go (observe t)). +Proof. rewrite <- itree_eta_. reflexivity. Qed. + End eq_itree_eq. Arguments eq_itree_clo_trans : clear implicits. @@ -323,27 +306,24 @@ Qed. (**) -Lemma bind_unfold {E R S} - (t : itree E R) (k : R -> itree E S) : - observe (ITree.bind t k) = observe (ITree.bind_match k (ITree.bind' k) (observe t)). -Proof. eauto. Qed. - -Lemma unfold_bind {E R S} +(* TODO (LATER): I keep these [...bind_] lemmas around temporarily + in case I run some issues with slow typeclass resolution. *) +Lemma unfold_bind_ {E R S} (t : itree E R) (k : R -> itree E S) : ITree.bind t k ≅ ITree.bind_match k (fun t => ITree.bind t k) (observe t). -Proof. rewrite itree_eta, bind_unfold, <-itree_eta. reflexivity. Qed. +Proof. rewrite unfold_bind. reflexivity. Qed. -Lemma ret_bind {E R S} (r : R) (k : R -> itree E S) : +Lemma ret_bind_ {E R S} (r : R) (k : R -> itree E S) : ITree.bind (Ret r) k ≅ (k r). -Proof. apply unfold_bind. Qed. +Proof. apply unfold_bind_. Qed. -Lemma tau_bind {E R} U t (k: U -> itree E R) : +Lemma tau_bind_ {E R} U t (k: U -> itree E R) : ITree.bind (Tau t) k ≅ Tau (ITree.bind t k). -Proof. apply @unfold_bind. Qed. +Proof. apply @unfold_bind_. Qed. -Lemma vis_bind {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : +Lemma vis_bind_ {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). -Proof. apply @unfold_bind. Qed. +Proof. apply @unfold_bind_. Qed. Inductive eq_itree_bind_clo_h {E R1 R2} (RR : R1 -> R2 -> Prop) (r : itree E R1 -> itree E R2 -> Prop) : @@ -361,7 +341,7 @@ Proof. econstructor; try pmonauto. intros. dependent destruction PR. punfold EQV. unfold_eq_itree. - rewrite !bind_unfold; inv EQV; simpobs. + rewrite !unfold_bind; inv EQV; simpobs. - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. - simpl. fold_bind. pclearbot. eauto 7 using rclo2. - econstructor. @@ -381,7 +361,7 @@ Proof. econstructor; try pmonauto. intros. dependent destruction PR. punfold EQV. unfold_eq_itree. - rewrite !bind_unfold; inv EQV; simpobs. + rewrite !unfold_bind; inv EQV; simpobs. - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. - simpl. fold_bind. pclearbot. eauto 7 using rclo2. - econstructor. @@ -442,7 +422,7 @@ Lemma bind_ret {E R} : ITree.bind s (fun x => Ret x) ≅ s. Proof. pcofix CIH. intros. - pfold. unfold_eq_itree. rewrite !bind_unfold. simpl. + pfold. unfold_eq_itree. rewrite !unfold_bind. simpl. genobs s os. destruct os; simpl; eauto. Qed. @@ -451,7 +431,8 @@ Lemma bind_bind {E R S T} : ITree.bind (ITree.bind s k) h ≅ ITree.bind s (fun r => ITree.bind (k r) h). Proof. pcofix CIH. intros. - pfold. unfold_eq_itree. rewrite !bind_unfold. + pfold. unfold_eq_itree. + rewrite !unfold_bind. (* TODO: this is a bit slow (0.5s). *) genobs s os; destruct os; unfold_bind; simpl; auto. apply Reflexive_eq_itreeF. auto using reflexivity. Qed. @@ -550,9 +531,9 @@ Proof. Qed. *) +Hint Rewrite @ret_bind_ : itree. +Hint Rewrite @tau_bind_ : itree. +Hint Rewrite @vis_bind_ : itree. Hint Rewrite @map_bind : itree. -Hint Rewrite @ret_bind : itree. -Hint Rewrite @tau_bind : itree. -Hint Rewrite @vis_bind : itree. Hint Rewrite @bind_ret : itree. Hint Rewrite @bind_bind : itree. diff --git a/theories/Eq/Shallow.v b/theories/Eq/Shallow.v new file mode 100644 index 00000000..b6b540f5 --- /dev/null +++ b/theories/Eq/Shallow.v @@ -0,0 +1,141 @@ +(** * Shallow equivalence *) + +(** Equality under [observe]: + +[[ + observing eq t1 t2 <-> t1.(observe) = t2.(observe) +]] + + We actually define a more general relation transformer + [observing] to lift arbitrary relations through [observe]. *) + +From ITree Require Import Core. + +From Coq Require Import + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations + ProofIrrelevance. + +(** ** Misc *) + +(** Rewrite all heterogeneous equalities with the axiom + [inj_pair2 : existT _ T a = existT _ T b -> a = b]. *) +Ltac auto_inj_pair2 := + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). + +Lemma pointwise_relation_fold {A B} {r: relation B} f g : + (forall v:A, r (f v) (g v)) -> pointwise_relation _ r f g. +Proof. red. eauto. Qed. + +(**) + +(** ** [observing]: Lift relations through [observe]. *) +Inductive observing {E R1 R2} + (eq_ : itree' E R1 -> itree' E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := +| observing_intros : + eq_ t1.(observe) t2.(observe) -> observing eq_ t1 t2. +Hint Constructors observing. + +Section observing_relations. + +Context {E : Type -> Type} {R : Type}. +Variable (eq_ : itree' E R -> itree' E R -> Prop). + +Global Instance observing_observe : + Proper (observing eq_ ==> eq_) (@observe E R). +Proof. intros ? ? []; cbv; auto. Qed. + +Global Instance observing_go : Proper (eq_ ==> observing eq_) (@go E R). +Proof. cbv; auto. Qed. + +Global Instance monotonic_observing eq_' : + subrelation eq_ eq_' -> + subrelation (observing eq_) (observing eq_'). +Proof. intros ? ? ? []; cbv; eauto. Qed. + +Global Instance Equivalence_observing : + Equivalence eq_ -> Equivalence (observing eq_). +Proof. + intros []; split; cbv; auto. + - intros ? ? []; auto. + - intros ? ? ? [] []; eauto. +Qed. + +(* TODO: Ideally, this should subsume [Eq.Eq.itree_eta], + see note over there. *) +Lemma itree_eta_ (t : itree E R) : + observing eq t (go (observe t)). +Proof. auto. Qed. + +End observing_relations. + +Lemma unfold_bind {E R S} + (t : itree E R) (k : R -> itree E S) : + observing eq + (ITree.bind t k) + (ITree.bind_match k (fun t => ITree.bind t k) (observe t)). +Proof. eauto. Qed. + +Instance observing_bind {E R S} : + Proper (observing eq ==> eq ==> observing eq) (@ITree.bind E R S). +Proof. + repeat intro; subst. + do 2 rewrite unfold_bind; rewrite H. + reflexivity. +Qed. + +Lemma ret_bind {E R S} (r : R) (k : R -> itree E S) : + observing eq (ITree.bind (Ret r) k) (k r). +Proof. apply unfold_bind. Qed. + +Lemma tau_bind {E R} U t (k: U -> itree E R) : + observing eq (ITree.bind (Tau t) k) (Tau (ITree.bind t k)). +Proof. apply @unfold_bind. Qed. + +Lemma vis_bind {E R U V} (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : + observing eq + (ITree.bind (Vis e ek) k) + (Vis e (fun x => ITree.bind (ek x) k)). +Proof. apply @unfold_bind. Qed. + +(** ** [going]: Lift relations through [go]. *) + +Inductive going {E R1 R2} (r : itree E R1 -> itree E R2 -> Prop) + (ot1 : itree' E R1) (ot2 : itree' E R2) : Prop := +| going_intros : r (go ot1) (go ot2) -> going r ot1 ot2. +Hint Constructors going. + +Lemma observing_going {E R1 R2} (eq_ : itree' E R1 -> itree' E R2 -> Prop) ot1 ot2 : + going (observing eq_) ot1 ot2 <-> eq_ ot1 ot2. +Proof. + split; auto. + intros [[]]; auto. +Qed. + +Section going_relations. + +Context {E : Type -> Type} {R : Type}. +Variable (eq_ : itree E R -> itree E R -> Prop). + +Global Instance going_go : Proper (going eq_ ==> eq_) (@go E R). +Proof. intros ? ? []; auto. Qed. + +Global Instance monotonic_going eq_' : + subrelation eq_ eq_' -> + subrelation (going eq_) (going eq_'). +Proof. intros ? ? ? []; eauto. Qed. + +Global Instance Equivalence_going : + Equivalence eq_ -> Equivalence (going eq_). +Proof. + intros []; constructor; cbv; eauto. + - intros ? ? []; auto. + - intros ? ? ? [] []; eauto. +Qed. + +End going_relations. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index f0e40e04..81a6b2da 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -26,7 +26,11 @@ From Coq Require Import Setoids.Setoid Relations.Relations. -From ITree Require Import Core Eq.Eq. +From ITree Require Import + Core. + +From ITree Require Export + Eq.Eq. Local Open Scope itree. @@ -668,17 +672,17 @@ Proof. constructor; typeclasses eauto. Qed. (**) -Global Instance eutt_go : Proper (go_sim eutt ==> eutt) go. -Proof. repeat intro; eauto. Qed. +Global Instance eutt_go : Proper (going eutt ==> eutt) go. +Proof. intros ? ? []; eauto. Qed. -Global Instance eutt_observe : Proper (eutt ==> go_sim eutt) observe. +Global Instance eutt_observe : Proper (eutt ==> going eutt) observe. Proof. - repeat intro. punfold H. pfold. destruct H. econstructor; eauto. + constructor. punfold H. pfold. destruct H. econstructor; eauto. Qed. -Global Instance eutt_tauF : Proper (eutt ==> go_sim eutt) (fun t => TauF t). +Global Instance eutt_tauF : Proper (eutt ==> going eutt) (fun t => TauF t). Proof. - repeat intro. pfold. punfold H. + constructor; pfold. punfold H. destruct H. econstructor. - split; intros; simpl. + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. @@ -687,9 +691,9 @@ Proof. Qed. Global Instance eutt_VisF {u} (e: E u) : - Proper (pointwise_relation _ eutt ==> go_sim eutt) (VisF e). + Proper (pointwise_relation _ eutt ==> going eutt) (VisF e). Proof. - repeat intro. red in H. pfold. econstructor. + constructor; pfold. red in H. econstructor. - repeat econstructor. - intros. destruct UNTAUS1 as [UNTAUS1 Hnotau1]. @@ -700,17 +704,17 @@ Proof. Qed. Global Instance eq_itree_notauF : - Proper (go_sim (@eq_itree E R _ eq) ==> flip impl) notauF. + Proper (going (@eq_itree E R _ eq) ==> flip impl) notauF. Proof. - repeat intro. punfold H. inv H; simpl in *; subst; eauto. + intros ? ? [] ?; punfold H. inv H; simpl in *; subst; eauto. Qed. (* If [t1] and [t2] are equivalent, then either both start with finitely many taus, or both [spin]. *) Global Instance eutt_finite_taus : - Proper (go_sim eutt ==> flip impl) finite_tausF. + Proper (going eutt ==> flip impl) finite_tausF. Proof. - repeat intro. punfold H. eapply H. eauto. + intros ? ? [] ?; punfold H. eapply H. eauto. Qed. Inductive eutt_trans_clo (r: itree E R -> itree E R -> Prop) : @@ -788,8 +792,8 @@ Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) Proof. intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. induction UNTAUS; intros; subst. - - rewrite !bind_unfold; simpobs; eauto. - - rewrite bind_unfold. simpobs. cbn. eauto. + - rewrite !unfold_bind; simpobs; eauto. + - rewrite unfold_bind. simpobs. cbn. eauto. Qed. Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) @@ -806,10 +810,10 @@ Proof. intros [tf' [TAUS PROP]]. genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. induction TAUS; intros; subst. - - rewrite bind_unfold in PROP. + - rewrite unfold_bind in PROP. genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - rewrite bind_unfold in Heqobtf. simpobs. inv Heqobtf. unfold_bind. + rewrite unfold_bind in Heqobtf. simpobs. inv Heqobtf. unfold_bind. eapply finite_taus_tau; eauto. Qed. @@ -819,7 +823,7 @@ Lemma finite_taus_bind {E R S} (FINk: forall v, finite_tausF (observe (f v))): finite_tausF (observe (ITree.bind t f)). Proof. - rewrite bind_unfold. + rewrite unfold_bind. genobs t ot. clear Heqot t. destruct FINt as [ot' [UNT NOTAU]]. induction UNT; subst. @@ -846,11 +850,11 @@ Proof. assert (FT2 := FT1). apply FTt in FT2. destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. - rewrite bind_unfold. genobs t2 ot2. clear Heqot2 t2. + rewrite unfold_bind. genobs t2 ot2. clear Heqot2 t2. induction FT2. - destruct ot0; inv NT2; simpl; eauto 7. hexploit EQV; eauto. intros EQV'. inv EQV'. - rewrite bind_unfold in FT. eauto. + rewrite unfold_bind in FT. eauto. - subst. eapply finite_taus_tau; eauto. eapply IHFT2; eauto using unalltaus_tau'. Qed. @@ -874,10 +878,10 @@ Proof. hexploit @untaus_unalltaus_rev; [apply UT1| |]. eauto. intros UAT1. hexploit @untaus_unalltaus_rev; [apply UT2| |]; eauto. intros UAT2. inv EQV. - + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. + + rewrite unfold_bind in UAT1, UAT2. simpobs. cbn in *. eapply GF in REL. destruct REL. eapply monotone_eq_notauF; eauto using rclo2. - + rewrite bind_unfold in UAT1, UAT2. simpobs. cbn in *. + + rewrite unfold_bind in UAT1, UAT2. simpobs. cbn in *. destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. dependent destruction UAT1. dependent destruction UAT2. simpobs. econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. @@ -948,11 +952,6 @@ Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). Admitted. -Definition observing {E R} - (f : itree' E R -> itree' E R -> Prop) - (x y : itree E R) := - f x.(observe) y.(observe). - Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : itree' E R -> itree' E R -> Prop := | euttF1_Tau_L : forall t1 t2, diff --git a/theories/FixFacts.v b/theories/FixFacts.v index d78c9a7a..4ed48244 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -275,7 +275,7 @@ Proof. | [ |- _ _ (Tau (loop_ ?f _)) ] => rewrite (unfold_loop' f) end. unfold loop_once_. - rewrite ret_bind. + rewrite ret_bind_. (* TODO: [ret_bind] doesn't work. *) pfold; constructor; auto. - pfold; constructor; auto. Qed. @@ -296,7 +296,7 @@ Proof. rewrite !bind_bind. pupto2 @eq_itree_clo_bind; constructor; try reflexivity. intros [c | b]. - - rewrite ret_bind, tau_bind. + - rewrite ret_bind_, tau_bind_. pfold; constructor; auto. - autorewrite with itree. pupto2_final; apply reflexivity. @@ -330,7 +330,7 @@ Proof. pupto2 eq_itree_clo_bind; constructor; try reflexivity. intros c'. rewrite tau_bind. - rewrite ret_bind. + rewrite ret_bind_. rewrite unfold_loop'; unfold loop_once. rewrite bind_bind. pfold; constructor. @@ -407,18 +407,18 @@ Proof. rewrite 2 unfold_loop'; unfold loop_once. rewrite bind_bind. destruct inra as [c | a]; subst. - - rewrite bind_bind; setoid_rewrite ret_bind. + - rewrite bind_bind; setoid_rewrite ret_bind_. pupto2 eq_itree_clo_bind; constructor; try reflexivity. intros [c' | b]; simpl. + rewrite tau_bind. pfold; constructor. pupto2_final. auto. + rewrite ret_bind. pupto2_final; apply reflexivity. - - rewrite bind_bind; setoid_rewrite ret_bind. + - rewrite bind_bind; setoid_rewrite ret_bind_. pupto2 eq_itree_clo_bind; constructor; try reflexivity. intros [c' | b]; simpl. + rewrite tau_bind. pfold; constructor. pupto2_final. auto. - + rewrite ret_bind. pupto2_final; apply reflexivity. + + rewrite ret_bind_. pupto2_final; apply reflexivity. Qed. Lemma superposing2 {E A B C D D'} (f : C + A -> itree E (C + B)) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 3d04ad49..871a0413 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -49,7 +49,7 @@ Proof. eauto. Qed. Lemma unfold_interp {E F R} {f : E ~> itree F} (t : itree E R) : interp f _ t ≅ interp_u f _ (observe t). -Proof. rewrite itree_eta, interp_unfold, <-itree_eta. reflexivity. Qed. +Proof. rewrite itree_eta_, interp_unfold, <-itree_eta_. reflexivity. Qed. (** ** [interp] and constructors *) @@ -111,8 +111,9 @@ Proof. revert R t k. pcofix CIH. intros. rewrite (itree_eta t). destruct (observe t). - - rewrite ret_interp, !ret_bind. pupto2_final. apply reflexivity. - - rewrite tau_interp, !tau_bind, tau_interp. + (* TODO: [ret_bind] (0.8s) is much slower than [ret_bind_] (0.02s) *) + - rewrite ret_interp. rewrite !ret_bind_. pupto2_final. apply reflexivity. + - rewrite tau_interp, !tau_bind_, tau_interp. pupto2_final. pfold. econstructor. eauto. - rewrite vis_interp, tau_bind. rewrite bind_bind. pfold. do 2 red; cbn. constructor. @@ -158,7 +159,7 @@ Proof. assert (ITree.bind' (fun x0 : u => interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0)) (Ret x) = (x0 <- Ret x ;; interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0))). { intros; reflexivity. } rewrite H. - rewrite ret_bind. + rewrite ret_bind_. (* TODO: Why does [ret_bind] not work at all. *) pupto2_final. right. apply CIH. Qed. @@ -239,9 +240,9 @@ Proof. genobs t ot. clear Heqot t. destruct ot; simpl; eauto. destruct e; simpl; eauto. - econstructor. rewrite bind_unfold. + econstructor. rewrite unfold_bind. econstructor. intros. - fold_bind. rewrite bind_unfold. simpl. eauto. + fold_bind. rewrite unfold_bind. simpl. eauto. Qed. Lemma interp_is_interp1 E F R (f: E ~> itree F) (t: itree _ R) : @@ -258,7 +259,7 @@ Proof. - pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. eapply upaco2_mon; eauto. intros. eapply (CIH' (go x2) (go x3)); eauto. - - rewrite !bind_unfold. fold_bind. + - rewrite !unfold_bind. fold_bind. genobs t ot. clear Heqot t. destruct ot; simpl; eauto 10. pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. @@ -468,11 +469,12 @@ Proof. intros A t k s. rewrite (itree_eta t). destruct (observe t). - - cbn. rewrite interp_state_ret. rewrite !ret_bind. simpl. + (* TODO: performance issues with [ret|tau|vis_bind] here too. *) + - cbn. rewrite interp_state_ret. rewrite !ret_bind_. simpl. pupto2_final. apply reflexivity. - - cbn. rewrite interp_state_tau, !tau_bind, interp_state_tau. + - cbn. rewrite interp_state_tau, !tau_bind_, interp_state_tau. pupto2_final. pfold. econstructor. right. apply CIH. - - cbn. rewrite interp_state_vis, tau_bind, vis_bind, bind_bind, interp_state_vis. + - cbn. rewrite interp_state_vis, tau_bind_, vis_bind_, bind_bind, interp_state_vis. pfold. red. constructor. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. @@ -493,17 +495,17 @@ Proof. intros A t k s. rewrite (itree_eta t). destruct (observe t). - - cbn. rewrite interp1_state_ret. rewrite !ret_bind. simpl. + - cbn. rewrite interp1_state_ret. rewrite !ret_bind_. simpl. pupto2_final. apply reflexivity. - - cbn. rewrite interp1_state_tau, !tau_bind, interp1_state_tau. + - cbn. rewrite interp1_state_tau, !tau_bind_, interp1_state_tau. pupto2_final. pfold. econstructor. right. apply CIH. - cbn. destruct e. - * rewrite interp1_state_vis1, tau_bind, vis_bind, bind_bind, interp1_state_vis1. + * rewrite interp1_state_vis1, tau_bind_, vis_bind_, bind_bind, interp1_state_vis1. pfold. red. constructor. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. + intros. specialize (CIH _ (k0 (snd v)) k (fst v)). auto. - * rewrite interp1_state_vis2, !vis_bind. rewrite itree_eta. rewrite unfold_interp1_state. + * rewrite interp1_state_vis2, !vis_bind_. rewrite itree_eta. rewrite unfold_interp1_state. cbn. pfold. constructor. intros. specialize (CIH _ (k0 v) k s). auto. Qed. @@ -625,7 +627,7 @@ Proof. - pfold. econstructor. cbn. econstructor. intros. assert (ITree.bind' (fun x0 : u => interp eh_id R (k x0)) (Ret x) = (x0 <- Ret x ;; interp eh_id R (k x0))). { intros; reflexivity. } - rewrite H. rewrite ret_bind. + rewrite H. rewrite ret_bind_. (* TODO: [ret_bind] doesn't work *) pupto2_final. right. apply CIH. Qed. From a86d3e1d088aa5d6018f1f0890d632ee9ddb5ccf Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 23 Feb 2019 19:45:30 -0500 Subject: [PATCH 071/142] Add SimUpToTaus (eutt preorder) --- theories/Eq/SimUpToTaus.v | 75 +++++++++++++++++++++++++++++++++++++++ theories/Eq/UpToTaus.v | 23 ++++++++++++ theories/FixFacts.v | 2 +- 3 files changed, 99 insertions(+), 1 deletion(-) create mode 100644 theories/Eq/SimUpToTaus.v diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v new file mode 100644 index 00000000..a9f8b844 --- /dev/null +++ b/theories/Eq/SimUpToTaus.v @@ -0,0 +1,75 @@ +(** * Simulation Up To Tau *) + +Require Import Paco.paco. + +From Coq Require Import + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations. + +From ITree Require Import + Core. + +From ITree Require Import + Eq.UpToTaus. + +Section SUTT. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Inductive suttF (eutt : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| suttF_ (FIN: finite_tausF ot1 -> finite_tausF ot2) + (EQV: forall ot1' ot2' + (UNTAUS1: unalltausF ot1 ot1') + (UNTAUS2: unalltausF ot2 ot2'), + eq_notauF RR eutt ot1' ot2') +. +Hint Constructors suttF. + +Definition sutt_ (eutt : itree E R1 -> itree E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := + suttF eutt (observe t1) (observe t2). +Hint Unfold sutt_. + +(* [sutt_] is monotone. *) +Lemma monotone_sutt_ : monotone2 sutt_. +Proof. pmonauto. Qed. +Hint Resolve monotone_sutt_ : paco. + +(* We now take the greatest fixpoint of [eutt_]. *) + +(* Equivalence Up To Taus. + + [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) +Definition sutt : itree E R1 -> itree E R2 -> Prop := paco2 sutt_ bot2. + +Global Arguments sutt t1%itree t2%itree. + +End SUTT. + +Hint Constructors suttF. +Hint Unfold sutt_. +Hint Resolve monotone_sutt_ : paco. + +Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) : + forall (t1 : itree E R1) (t2 : itree E R2), + sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2. +Proof. + pcofix self; intros t1 t2 H1 H2. + punfold H1. punfold H2. + destruct H1 as [FIN1 EQV1], H2 as [FIN2 EQV2]. + pfold; constructor. + - split; auto. + - intros. + eapply eq_notauF_and. + + intros ? ? I1 I2; right. + apply self; [ apply I1 | apply I2 ]. + + eapply monotone_eq_notauF; auto using EQV1. + intros; pclearbot; auto. + + apply eq_notauF_flip. + eapply monotone_eq_notauF; auto using EQV2. + intros; pclearbot; auto. +Qed. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 81a6b2da..dde03b3e 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -534,10 +534,33 @@ Qed. End EUTT. +Hint Resolve monotone_eq_notauF. Hint Constructors eq_notauF. Hint Constructors euttF. Hint Resolve monotone_eutt_ : paco. +(** *** [eq_notauF] lemmas *) + +Lemma eq_notauF_and {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (eutt1 eutt2 eutt : I -> J -> Prop) : + (forall t1 t2, eutt1 t1 t2 -> eutt2 t1 t2 -> eutt t1 t2) -> + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF RR eutt1 ot1 ot2 -> eq_notauF RR eutt2 ot1 ot2 -> + eq_notauF RR eutt ot1 ot2. +Proof. + intros ? ? ? [] Hen2; inversion Hen2; auto. + auto_inj_pair2; subst; auto. +Qed. + +Lemma eq_notauF_flip {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (eutt : I -> J -> Prop) : + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF (flip RR) (flip eutt) ot2 ot1 -> + eq_notauF RR eutt ot1 ot2. +Proof. + intros ? ? []; auto. +Qed. + Delimit Scope eutt_scope with eutt. Section EUTT_rel. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 4ed48244..f8e14e82 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -17,7 +17,7 @@ From ITree Require Import MorphismsFacts Fix Effect.Sum - Eq.Eq Eq.UpToTaus. + Eq.Eq Eq.UpToTaus Eq.SimUpToTaus. Section Facts. From 8d70246e7bc170893baefb05a00278191b3397a5 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 00:09:45 -0500 Subject: [PATCH 072/142] Refactor eutt_loop with sutt --- theories/Eq/SimUpToTaus.v | 139 ++++++++++++++++ theories/FixFacts.v | 337 ++++++++++++++------------------------ 2 files changed, 263 insertions(+), 213 deletions(-) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index a9f8b844..2579fcda 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -29,6 +29,21 @@ Inductive suttF (eutt : itree E R1 -> itree E R2 -> Prop) . Hint Constructors suttF. +Lemma suttF_unpack eutt ot1 ot2 : + suttF eutt ot1 ot2 <-> + forall ot1', unalltausF ot1 ot1' -> + exists ot2', unalltausF ot2 ot2' /\ eq_notauF RR eutt ot1' ot2'. +Proof. + split. + - intros [] ot1' H1. + edestruct FIN; eauto. + - intros. constructor. + + intros []; auto. edestruct H as [? []]; eauto. + + intros; edestruct H as [y []]; eauto. + replace ot2' with y; auto. + eapply unalltaus_injective; eauto. +Qed. + Definition sutt_ (eutt : itree E R1 -> itree E R2 -> Prop) (t1 : itree E R1) (t2 : itree E R2) : Prop := suttF eutt (observe t1) (observe t2). @@ -54,6 +69,23 @@ Hint Constructors suttF. Hint Unfold sutt_. Hint Resolve monotone_sutt_ : paco. +Lemma monotone_eq_notauF_RR {E R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) + {I J} (r : I -> J -> Prop) : + (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> + forall t1 t2, eq_notauF RR1 r t1 t2 -> @eq_notauF E _ _ RR2 _ _ r t1 t2. +Proof. intros ? ? ? []; auto. Qed. + +Lemma monotone_sutt_RR {E R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) r : + (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> + forall t1 t2, sutt_ RR1 r t1 t2 -> @sutt_ E _ _ RR2 r t1 t2. +Proof. + intros. induction H0. + constructor; auto. + intros. + edestruct EQV; eauto; + eapply monotone_eq_notauF_RR; eauto. +Qed. + Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) : forall (t1 : itree E R1) (t2 : itree E R2), sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2. @@ -73,3 +105,110 @@ Proof. eapply monotone_eq_notauF; auto using EQV2. intros; pclearbot; auto. Qed. + +Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) : + forall (t1 : itree E R1) (t2 : itree E R2), + eutt RR t1 t2 -> sutt RR t1 t2. +Proof. + pcofix self; intros t1 t2 H1. + punfold H1. + destruct H1 as [FIN1 EQV1]. + pfold; constructor. + - apply FIN1. + - intros. + eapply monotone_eq_notauF; eauto. + intros; pclearbot; auto. +Qed. + +Inductive suttF' {E R} (sutt: relation (itree E R)) : + relation (itree' E R) := +| suttF'_notau ot1 ot2 ot2' : + unalltausF ot2 ot2' -> + eq_notauF eq sutt ot1 ot2' -> + suttF' sutt ot1 ot2 +| suttF'_tau_left t1 ot2 + (EQTAUS: suttF' sutt (observe t1) ot2): + suttF' sutt (TauF t1) ot2 +. +Hint Constructors suttF'. + +Theorem suttF_suttF' {E R} (sutt : relation (itree E R)) : + forall ot1 ot2, + suttF eq sutt ot1 ot2 <-> suttF' sutt ot1 ot2. +Proof. +Admitted. + +Inductive suttF1 {E R} (sutt: itree' E R -> itree' E R -> Prop) : + itree' E R -> itree' E R -> Prop := +| suttF1_ret r : suttF1 sutt (RetF r) (RetF r) +| suttF1_vis u (e : E u) k1 k2 + (SUTTK: forall x, sutt (observe (k1 x)) (observe (k2 x))): + suttF1 sutt (VisF e k1) (VisF e k2) +| suttF1_tau_right ot1 t2 + (EQTAUS: suttF1 sutt ot1 (observe t2)): + suttF1 sutt ot1 (TauF t2) +| suttF1_tau_left t1 ot2 + (EQTAUS: sutt (observe t1) ot2): + suttF1 sutt (TauF t1) ot2 +. +Hint Constructors suttF1. + +Definition sutt1 {E R} (t1 t2 : itree E R) := + paco2 (@suttF1 E R) bot2 (observe t1) (observe t2). +Hint Unfold sutt1. + +Lemma reflexive_suttF1 {E R} sutt (r1:Reflexive sutt) : Reflexive (@suttF1 E R sutt). +Proof. + unfold Reflexive. intros x. + destruct x; eauto. +Qed. + +Lemma monotone_suttF1 {E R} : monotone2 (@suttF1 E R). +Proof. repeat red; intros. induction IN; eauto. Qed. +Hint Resolve monotone_suttF1 : paco. + +Lemma sutt_is_sutt1 {E R} (t1 t2: itree E R) : + sutt eq t1 t2 <-> sutt1 t1 t2. +Proof. + split; revert t1 t2; pcofix self; intros t1 t2 SUTT. + - punfold SUTT. pfold. + apply suttF_suttF' in SUTT. + induction SUTT; auto. + destruct H as [Huntaus Hnotau]. + induction Huntaus. + + inversion H0; subst; constructor. + pclearbot. right; apply self; red; auto. + + subst; auto. + - punfold SUTT. pfold. + red. + induction SUTT. + + constructor; eauto. intros. + apply unalltausF_ret in UNTAUS1. + apply unalltausF_ret in UNTAUS2. + subst; auto. + + constructor; eauto 7. intros. + apply unalltausF_vis in UNTAUS1. + apply unalltausF_vis in UNTAUS2. + pclearbot; subst; auto. + constructor. right; auto. + + destruct IHSUTT; constructor; intros. + * apply finite_taus_tau; auto. + * apply EQV. auto. eapply unalltaus_tau; eauto. + + pclearbot; punfold EQTAUS. + eapply suttF_unpack. + intros t0' Hunalltaus. + eapply unalltaus_tau in Hunalltaus; eauto. + destruct Hunalltaus as [Huntaus Hnotau]. + revert ot2 EQTAUS. + induction Huntaus; intros. + * induction EQTAUS; + contradiction + eauto 6. + { pclearbot. econstructor. repeat (constructor; auto). } + { destruct IHEQTAUS as [ot2' []]; auto. + eexists; split; eauto using unalltaus_tau'. } + * induction EQTAUS; + discriminate + eauto 6. + { destruct IHEQTAUS as [? []]; auto. + eexists; eauto using unalltaus_tau'. } + { pclearbot. inv OBS. punfold EQTAUS; auto. } +Qed. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index f8e14e82..a2f03173 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -475,7 +475,7 @@ Section eutt_loop. Context {E : Type -> Type} {A B C : Type}. Variables f1 f2 : C + A -> itree E (C + B). -Hypothesis eutt_f : forall ca, f1 ca ≈ f2 ca. +Hypothesis eutt_f : forall ca, sutt eq (f1 ca) (f2 ca). Inductive loop_preinv (t1 t2 : itree E B) : Prop := | loop_inv_main ca : @@ -483,7 +483,7 @@ Inductive loop_preinv (t1 t2 : itree E B) : Prop := t2 ≅ loop_ f2 ca -> loop_preinv t1 t2 | loop_inv_bind u1 u2 : - eutt eq u1 u2 -> + sutt eq u1 u2 -> t1 ≅ (cb <- u1;; match cb with | inl c => Tau (loop_ f1 (inl c)) @@ -498,250 +498,161 @@ Inductive loop_preinv (t1 t2 : itree E B) : Prop := . Hint Constructors loop_preinv. -(* TODO: Make this proof less ugly. *) Lemma eutt_loop_inv_main_step (ca : C + A) t1 t2 : t1 ≅ loop_ f1 ca -> t2 ≅ loop_ f2 ca -> - euttF' loop_preinv - (fun ot1 ot2 => loop_preinv (go ot1) (go ot2)) - (observe t1) (observe t2). + suttF1 (going loop_preinv) (observe t1) (observe t2). Proof. intros H1 H2. rewrite unfold_loop' in H1. rewrite unfold_loop' in H2. unfold loop_once. specialize (eutt_f ca). + apply sutt_is_sutt1 in eutt_f. punfold eutt_f. - destruct eutt_f. unfold loop_once in H1. + unfold loop_once in H2. rewrite unfold_bind in H1. - destruct (observe (f1 ca)) eqn:Ef1. - - 1:{ (* f1 ca = Ret _ *) - assert (H1unalltaus : @unalltausF E _ (RetF r) (RetF r)). - { apply untaus_all; constructor. } - assert (H2unalltaus : finite_taus (f2 ca)). - { apply FIN; eauto. } - destruct H2unalltaus as [ot2 H2unalltaus]. - specialize (EQV _ _ H1unalltaus H2unalltaus). - destruct H2unalltaus as [H2untaus _]. - unfold loop_once in H2. - remember (f2 ca) as t2' eqn:Et2; clear Et2. - rewrite unfold_bind in H2. - genobs t2' ot2'. - revert t2 H2 t2' eutt_f Heqot2'. - induction H2untaus; intros. - + inversion EQV; subst. rewrite <- H3 in H2; simpl in H1, H2. - destruct r2. - * apply eq_itree_tau_inv1 in H1. - apply eq_itree_tau_inv1 in H2. - destruct H1 as [t01 [Ht01 Ht01']]. - destruct H2 as [t02 [Ht02 Ht02']]. - rewrite Ht01, Ht02. - constructor. - econstructor. - { rewrite Ht01'. rewrite <- itree_eta. reflexivity. } - { rewrite Ht02'. rewrite <- itree_eta. reflexivity. } - * apply eq_itree_ret_inv1 in H1. - apply eq_itree_ret_inv1 in H2. - rewrite H1, H2. auto. - + rewrite <- OBS in H2. apply eq_itree_tau_inv1 in H2. - destruct H2 as [t02 [Ht02 Ht02']]. - rewrite Ht02. - constructor. - eapply IHH2untaus; auto. - erewrite <- (untaus_finite_taus _ (observe t')); eauto. - rewrite <- unfold_bind; auto. - eapply euttF_tau_right; subst; eauto. } - - 2:{ (* f1 ca = Vis _ _ *) - assert (H1unalltaus : @unalltausF E _ (VisF e k) (VisF e k)). - { apply untaus_all; constructor. } - assert (H2unalltaus : finite_taus (f2 ca)). - { apply FIN; eauto. } - destruct H2unalltaus as [ot2 H2unalltaus]. - specialize (EQV _ _ H1unalltaus H2unalltaus). - destruct H2unalltaus as [H2untaus _]. - unfold loop_once in H2. - remember (f2 ca) as t2' eqn:Et2; clear Et2. - rewrite unfold_bind in H2. - genobs t2' ot2'. - revert t2 H2 t2' eutt_f Heqot2'. - induction H2untaus; intros. - + inversion EQV; auto_inj_pair2; subst. - rewrite <- H0 in H2; simpl in H1, H2. - apply eq_itree_vis_inv1 in H1. - apply eq_itree_vis_inv1 in H2. - destruct H1 as [k01 [Hk1 Ht1]]. - destruct H2 as [k02 [Hk2 Ht2]]. - rewrite Hk1, Hk2. - pclearbot. - constructor. - intros; eapply loop_inv_bind; [ eapply H5 | | ]; eauto. - + rewrite <- OBS in H2. apply eq_itree_tau_inv1 in H2. - destruct H2 as [t02 [Ht02 Ht02']]. - rewrite Ht02. - constructor. - eapply IHH2untaus; auto. - erewrite <- (untaus_finite_taus _ (observe t')); eauto. - rewrite <- unfold_bind; auto. - eapply euttF_tau_right; subst; eauto. } + rewrite unfold_bind in H2. - 1:{ (* f1 ca = Tau _ *) - unfold loop_once in H2. - rewrite unfold_bind in H2. - destruct (observe (f2 ca)) eqn:Ef2. - - 1:{ (* f2 ca = Ret _ *) - rewrite <- Ef1 in *; clear Ef1 t. - assert (H2unalltaus : @unalltausF E _ (RetF r) (RetF r)). - { apply untaus_all; constructor. } - assert (H1unalltaus : finite_taus (f1 ca)). - { apply FIN; eauto. } - destruct H1unalltaus as [ot1 H1unalltaus]. - specialize (EQV _ _ H1unalltaus H2unalltaus). - destruct H1unalltaus as [H1untaus _]. - remember (f1 ca) as t1' eqn:Et1; clear Et1. - genobs t1' ot1'. - revert t1 H1 t1' eutt_f Heqot1'. - induction H1untaus; intros. - + inversion EQV; subst. rewrite <- H0 in H1; simpl in H1, H2. - destruct r. - * apply eq_itree_tau_inv1 in H1. - apply eq_itree_tau_inv1 in H2. - destruct H1 as [t01 [Ht01 Ht01']]. - destruct H2 as [t02 [Ht02 Ht02']]. - rewrite Ht01, Ht02. - constructor. - econstructor. - { rewrite Ht01'. rewrite <- itree_eta. reflexivity. } - { rewrite Ht02'. rewrite <- itree_eta. reflexivity. } - * apply eq_itree_ret_inv1 in H1. - apply eq_itree_ret_inv1 in H2. - rewrite H1, H2. auto. - + rewrite <- OBS in H1. apply eq_itree_tau_inv1 in H1. - destruct H1 as [t01 [Ht01 Ht01']]. - rewrite Ht01. - constructor. - eapply IHH1untaus; auto. - erewrite <- (untaus_finite_taus _ (observe t')); eauto. - rewrite <- unfold_bind; auto. - eapply euttF_tau_left; subst; eauto. } - - 2:{ (* f2 ca = Vis _ _ *) - rewrite <- Ef1 in *; clear Ef1 t. - assert (H2unalltaus : @unalltausF E _ (VisF e k) (VisF e k)). - { apply untaus_all; constructor. } - assert (H1unalltaus : finite_taus (f1 ca)). - { apply FIN; eauto. } - destruct H1unalltaus as [ot1 H1unalltaus]. - specialize (EQV _ _ H1unalltaus H2unalltaus). - destruct H1unalltaus as [H1untaus _]. - remember (f1 ca) as t1' eqn:Et1; clear Et1. - genobs t1' ot1'. - revert t1 H1 t1' eutt_f Heqot1'. - apply eq_notauF_vis_inv1 in EQV. - destruct EQV as [k' [Hot0 Hk']]. - induction H1untaus; intros. - + rewrite Hot0 in H1; simpl in H1, H2. - apply eq_itree_vis_inv1 in H1. - apply eq_itree_vis_inv1 in H2. - destruct H1 as [k01 [Hk1 Ht1]]. - destruct H2 as [k02 [Hk2 Ht2]]. - rewrite Hk1, Hk2. - pclearbot. - constructor. - intros; eapply loop_inv_bind; [ eapply Hk' | | ]; eauto. - + rewrite <- OBS in H1. apply eq_itree_tau_inv1 in H1. - destruct H1 as [t01 [Ht01 Ht01']]. - rewrite Ht01. - constructor. - eapply IHH1untaus; auto. - erewrite <- (untaus_finite_taus _ (observe t')); eauto. - rewrite <- unfold_bind; auto. - eapply euttF_tau_left; subst; eauto. } + revert t1 t2 H1 H2. + induction eutt_f; intros z1 z2 H1 H2. - 1:{ (* f2 ca = Tau _ *) - apply eq_itree_tau_inv1 in H1. - apply eq_itree_tau_inv1 in H2. - destruct H1 as [t01 [Ht01 Ht01']]. - destruct H2 as [t02 [Ht02 Ht02']]. - rewrite Ht01, Ht02. + - destruct r. + + apply eq_itree_tau_inv1 in H1. + destruct H1 as [t1' [Ht1 Ht1']]. + apply eq_itree_tau_inv1 in H2. + destruct H2 as [t2' [Ht2 Ht2']]. + rewrite Ht1, Ht2. + repeat constructor. + econstructor; try rewrite <- itree_eta; eassumption. + + apply eq_itree_ret_inv1 in H1. + apply eq_itree_ret_inv1 in H2. + rewrite H1, H2. + auto. + + - pclearbot. apply eq_itree_vis_inv1 in H1. + apply eq_itree_vis_inv1 in H2. + destruct H1 as [k01 [Hk1 Hk1']]. + destruct H2 as [k02 [Hk2 Hk2']]. + rewrite Hk1, Hk2. + constructor; intros. + repeat constructor. + eapply loop_inv_bind. + + apply sutt_is_sutt1, SUTTK. + + rewrite <- itree_eta; auto. + + rewrite <- itree_eta; auto. + + - apply eq_itree_tau_inv1 in H2. + destruct H2 as [t2' [Ht2 Ht2']]. + rewrite Ht2. constructor. - eapply loop_inv_bind; try (rewrite <- itree_eta; eauto). - + erewrite <- (tauF_eutt _ t), <- (tauF_eutt _ t0); try eauto. - pfold; auto. } - } + apply IHs; auto. rewrite <- unfold_bind; auto. + - pclearbot. + replace ot2 with (observe (go ot2)) in *. + rewrite <- unfold_bind in H2. + apply eq_itree_tau_inv1 in H1. + destruct H1 as [t1' [Ht1 Ht1']]. + rewrite Ht1. + repeat constructor. + eapply loop_inv_bind. + + apply sutt_is_sutt1. eauto. + + rewrite <- itree_eta; auto. + + rewrite <- itree_eta; auto. + + auto. Qed. -Lemma eutt_loop_inv t1 t2 : - loop_preinv t1 t2 -> eutt eq t1 t2. +Lemma eutt_loop_inv ot1 ot2 : + loop_preinv (go ot1) (go ot2) -> paco2 suttF1 bot2 ot1 ot2. Proof. intros HH. - apply eutt_is_eutt'. - revert t1 t2 HH; pcofix self; intros. pfold. - revert t1 t2 HH; pcofix self_tau; intros. + revert ot1 ot2 HH; pcofix self; intros. pfold. destruct HH as [ca H1 H2 | u1 u2 Hu H1 H2]. - - pfold. eapply euttF'_mon. - + eapply eutt_loop_inv_main_step; eauto. - + intros. right. eapply self; eauto; try reflexivity. - + simpl; intros. right. - replace x0 with (observe (go x0)) by reflexivity. - replace x1 with (observe (go x1)) by reflexivity. - eapply self_tau; eauto; try reflexivity. - - apply eutt_is_eutt' in Hu. punfold Hu. punfold Hu. + - eapply monotone_suttF1. + + eapply (eutt_loop_inv_main_step ca (go ot1) (go ot2)); eauto. + + intros ? ? []. right. eapply self; eauto. + - apply sutt_is_sutt1 in Hu. + punfold Hu. rewrite unfold_bind in H1. rewrite unfold_bind in H2. - pfold. - genobs t1 ot1. genobs t2 ot2. - revert ot1 ot2 t1 t2 Heqot1 Heqot2 H1 H2. - induction Hu; intros; cbn in H1, H2; subst. - + destruct r1 as [ c | b ]. + revert ot1 ot2 H1 H2; induction Hu; intros. + + + destruct r0. * apply eq_itree_tau_inv1 in H1. apply eq_itree_tau_inv1 in H2. - destruct H1 as [t1'' [H1 H1']]. - destruct H2 as [t2'' [H2 H2']]. - rewrite H1, H2. constructor; eauto. - * apply eq_itree_ret_inv1 in H1. apply eq_itree_ret_inv1 in H2. - rewrite H1, H2. auto. - + apply eq_itree_vis_inv1 in H1. apply eq_itree_vis_inv1 in H2. - destruct H1 as [k1' [H1 H1']]. - destruct H2 as [k2' [H2 H2']]. - rewrite H1, H2. pclearbot. eauto. - constructor; intro z; right. - eapply self; eauto. - econstructor 2. - apply eutt_is_eutt'; apply EUTTK. - eauto. eauto. + simpl in H1, H2. + destruct H1 as [? []], H2 as [? []]. + subst. + do 2 constructor. right. + apply self. + eapply loop_inv_main; rewrite <- itree_eta; eauto. + * apply eq_itree_ret_inv1 in H1. + apply eq_itree_ret_inv1 in H2. + simpl in H1, H2. subst; constructor. + + pclearbot. - apply eq_itree_tau_inv1 in H1. apply eq_itree_tau_inv1 in H2. - destruct H1 as [t1'' [H1 H1']]. - destruct H2 as [t2'' [H2 H2']]. - rewrite H1, H2. constructor. right. - eapply self_tau; eauto. - econstructor 2. - apply eutt_is_eutt'; eauto. - eauto. eauto. - + apply eq_itree_tau_inv1 in H1. - destruct H1 as [t1'' [H1 H1']]. - rewrite H1. constructor. - eapply IHHu; eauto. - rewrite <- unfold_bind. auto. + apply eq_itree_vis_inv1 in H1. + apply eq_itree_vis_inv1 in H2. + simpl in H1, H2. + destruct H1 as [? []], H2 as [? []]. + subst; constructor. + right. apply self. + eapply loop_inv_bind. + * apply sutt_is_sutt1. eapply SUTTK. + * rewrite <- itree_eta; auto. + * rewrite <- itree_eta; auto. + + apply eq_itree_tau_inv1 in H2. - destruct H2 as [t2'' [H2 H2']]. - rewrite H2. constructor. - eapply IHHu; eauto. - rewrite <- unfold_bind. auto. + simpl in H2. + destruct H2 as [t2' [Ht2 Ht2']]. + rewrite Ht2. + constructor. + apply IHHu; auto. + rewrite <- itree_eta, <- unfold_bind; auto. + + + pclearbot. + replace ot2 with (observe (go ot2)) in *. + rewrite <- unfold_bind in H2. + apply eq_itree_tau_inv1 in H1. + simpl in H1. + destruct H1 as [t1' [Ht1 Ht1']]. + rewrite Ht1. + constructor. + right; apply self. + eapply loop_inv_bind. + * apply sutt_is_sutt1. + eapply EQTAUS. + * rewrite <- itree_eta; auto. + * auto. + * auto. Qed. End eutt_loop. +Instance sutt_loop {E A B C} : + Proper ((eq ==> sutt eq) ==> eq ==> sutt eq) (@loop E A B C). +Proof. + repeat intro; subst. apply sutt_is_sutt1. + + eapply eutt_loop_inv. + - eauto. + - unfold loop; econstructor; rewrite <- itree_eta; reflexivity. +Qed. + Instance eutt_loop {E A B C} : Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B C). Proof. repeat intro; subst. - eapply eutt_loop_inv. - - eauto. - - unfold loop; econstructor; reflexivity. + eapply sutt_eutt. + - eapply sutt_loop; auto. + repeat intro; subst. + apply eutt_sutt; auto. + - eapply paco2_mon_gen. + + eapply sutt_loop; auto. + repeat intro. + apply eutt_sutt; symmetry; auto. + + intros. eapply monotone_sutt_RR; try eassumption. + red; auto. + + auto. Qed. From c1431d4b1ee92e2f029cfe27f7e535ae7c76fd3c Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 00:18:17 -0500 Subject: [PATCH 073/142] Add SimUpToTaus to _CoqConfig --- _CoqConfig | 1 + 1 file changed, 1 insertion(+) diff --git a/_CoqConfig b/_CoqConfig index d8288dbb..232e4901 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -7,6 +7,7 @@ theories/Core.v theories/Eq/Shallow.v theories/Eq/Eq.v theories/Eq/UpToTaus.v +theories/Eq/SimUpToTaus.v theories/Effect/Sum.v theories/Effect/Std.v From 13978f22ca469b5dd4bbc233d93162feb98ae000 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Sun, 24 Feb 2019 10:26:19 -0500 Subject: [PATCH 074/142] factor out Translate (step 1) --- _CoqConfig | 2 + theories/Translate.v | 163 +++----------------------------------- theories/TranslateFacts.v | 151 +++++++++++++++++++++++++++++++++++ 3 files changed, 163 insertions(+), 153 deletions(-) create mode 100644 theories/TranslateFacts.v diff --git a/_CoqConfig b/_CoqConfig index 232e4901..7d3fff29 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -19,6 +19,8 @@ theories/OpenSum.v theories/Fix.v theories/FixFacts.v +theories/Translate.v +theories/TranslateFacts.v theories/Morphisms.v theories/MorphismsFacts.v diff --git a/theories/Translate.v b/theories/Translate.v index c991b007..9fc1cf08 100644 --- a/theories/Translate.v +++ b/theories/Translate.v @@ -1,12 +1,14 @@ -(** This file is about the structure of itree morphisms induced by - event morphisms via the [translate] operation defined herein. +(** An event morphism [E ~> F] lifts to an itree morphism [itree E ~> itree F] + by mapping the event morphism across each visible event. We call this + process _event translation_. - Translate should be defined separately from the Morphisms because it - is conceptually at a different level and translation always yields - strong bisimulations. We can relate them via the law: + + Translate is defined separately from the itree Morphisms because it is + conceptually at a different level: translation always yields strong + bisimulations. We can relate translation and interpretation via the law: - translate h t ≈ interp (liftE ∘ h) t - *) + translate h t ≈ interp (liftE ∘ h) t +*) From ExtLib Require Structures.Monoid. @@ -14,8 +16,7 @@ From ExtLib Require From ITree Require Import Basics Core - Effect.Sum - OpenSum. + Effect.Sum. Open Scope itree_scope. @@ -31,147 +32,3 @@ Definition translateF {E F R} (h : E ~> F) (rec: itree E R -> itree F R) (t : it CoFixpoint translate {E F R} (h : E ~> F) (t : itree E R) : itree F R := translateF h (translate h) (observe t). -(* SAZ: Should be moved to TranslateFacts.v *) -(* translate facts ---------------------------------------------------------- *) -From ITree Require Import - Eq - UpToTaus. - -From Paco Require Import paco. - -From Coq Require Import - Program - Setoid - Morphisms - RelationClasses. - -Section TranslateFacts. - Context {E F : Type -> Type}. - Context {R : Type}. - Context (h : E ~> F). - -Lemma unfold_translate : forall (t : itree E R), - observe (translate h t) = observe (translateF h (translate h) (observe t)). -Proof. - intros t. reflexivity. -Qed. - -Lemma translate_ret : forall (r:R), translate h (Ret r) ≅ Ret r. -Proof. - intros r. - rewrite itree_eta. - rewrite unfold_translate. cbn. reflexivity. -Qed. - -Lemma translate_tau : forall (t : itree E R), translate h (Tau t) ≅ Tau (translate h t). -Proof. - intros t. - rewrite itree_eta. - rewrite unfold_translate. cbn. reflexivity. -Qed. - -Lemma translate_vis : forall X (e:E X) (k : X -> itree E R), - translate h (Vis e k) ≅ Vis (h _ e) (fun x => translate h (k x)). -Proof. - intros X e k. - rewrite itree_eta. - rewrite unfold_translate. cbn. reflexivity. -Qed. - -Global Instance translate_Proper : Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h). -Proof. - repeat red. - intros x y H. - pupto2_init. - revert x y H. - pcofix CIH. - intros x y H. - rewrite itree_eta. - rewrite (itree_eta (translate h y)). - repeat rewrite unfold_translate. unfold translateF. - rewrite (itree_eta x) in H. - rewrite (itree_eta y) in H. - destruct (observe x); destruct (observe y); pinversion H; subst; cbn. - - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution not working *) - - pupto2_final. pfold. constructor. right. apply CIH. eauto. - - pupto2_final. pfold. - repeat (match goal with - | [ H : _ |- _ ] => apply inj_pair2 in H - end). subst. - constructor. - inversion H. - repeat (match goal with - | [ H : _ |- _ ] => apply inj_pair2 in H - end). subst. - right. apply CIH. - eapply transitivity. pclearbot. apply REL0. reflexivity. -Qed. -End TranslateFacts. - -Lemma translate_bind : forall {E F R S} (h : E ~> F) (t : itree E S) (k : S -> itree E R), - translate h (x <- t ;; k x) ≅ (x <- (translate h t) ;; translate h (k x)). -Proof. - intros E F R S h t k. - pupto2_init. - revert S t k. - pcofix CIH. - intros s t k. - rewrite itree_eta. - rewrite (itree_eta (x <- translate h t;; translate h (k x))). - rewrite unfold_translate. - repeat rewrite bind_unfold. - rewrite unfold_translate. - unfold translateF. - unfold ITree.bind_match. - destruct (observe t); cbn. - - rewrite unfold_translate. unfold translateF. - pupto2_final. apply Reflexive_eq_itree. - - pfold. econstructor. pupto2_final. right. apply CIH. - - pfold. econstructor. intros. pupto2_final. right. apply CIH. -Qed. - -(* categorical properties --------------------------------------------------- *) - -Import Sum1. - -Lemma translate_id : forall E R (t : itree E R), translate idE t ≅ t. -Proof. - intros E R t. - pupto2_init. - revert t. - pcofix CIH. - intros t. - rewrite itree_eta. - rewrite (itree_eta t). - rewrite unfold_translate. - unfold translateF. - destruct (observe t); cbn. - - pupto2_final. apply Reflexive_eq_itree. - - pfold. econstructor. pupto2_final. right. apply CIH. - - pfold. econstructor. intros. pupto2_final. right. apply CIH. -Qed. - -Lemma translate_cmpE : forall E F G R (g : F ~> G) (f : E ~> F) (t : itree E R), - translate (cmpE g f) t ≅ translate g (translate f t). -Proof. - intros E F G R g f t. - pupto2_init. - revert t. - pcofix CIH. - intros t. - rewrite itree_eta. - rewrite (itree_eta (translate g (translate f t))). - repeat rewrite unfold_translate. - unfold translateF. - destruct (observe t); cbn. - - pupto2_final. apply Reflexive_eq_itree. - - pfold. econstructor. pupto2_final. right. apply CIH. - - pfold. econstructor. intros. pupto2_final. right. apply CIH. -Qed. - -(* SAZ: TODO - it would be good to allow for rewriting of event morphisms under translate: - - E ~~ F -> translate E t ≅ translate F t - - Where E ~~ F is extensional equality. -*) \ No newline at end of file diff --git a/theories/TranslateFacts.v b/theories/TranslateFacts.v new file mode 100644 index 00000000..fee8ab5b --- /dev/null +++ b/theories/TranslateFacts.v @@ -0,0 +1,151 @@ +(* translate facts ---------------------------------------------------------- *) + +From ExtLib Require + Structures.Monoid. + +From ITree Require Import + Basics + Core + Effect.Sum + Translate + Eq + UpToTaus. + +From Paco Require Import paco. + +From Coq Require Import + Program + Setoid + Morphisms + RelationClasses. + +Section TranslateFacts. + Context {E F : Type -> Type}. + Context {R : Type}. + Context (h : E ~> F). + +Lemma unfold_translate : forall (t : itree E R), + observe (translate h t) = observe (translateF h (translate h) (observe t)). +Proof. + intros t. reflexivity. +Qed. + +Lemma translate_ret : forall (r:R), translate h (Ret r) ≅ Ret r. +Proof. + intros r. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Lemma translate_tau : forall (t : itree E R), translate h (Tau t) ≅ Tau (translate h t). +Proof. + intros t. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Lemma translate_vis : forall X (e:E X) (k : X -> itree E R), + translate h (Vis e k) ≅ Vis (h _ e) (fun x => translate h (k x)). +Proof. + intros X e k. + rewrite itree_eta. + rewrite unfold_translate. cbn. reflexivity. +Qed. + +Global Instance translate_Proper : Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h). +Proof. + repeat red. + intros x y H. + pupto2_init. + revert x y H. + pcofix CIH. + intros x y H. + rewrite itree_eta. + rewrite (itree_eta (translate h y)). + repeat rewrite unfold_translate. unfold translateF. + rewrite (itree_eta x) in H. + rewrite (itree_eta y) in H. + destruct (observe x); destruct (observe y); pinversion H; subst; cbn. + - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution not working *) + - pupto2_final. pfold. constructor. right. apply CIH. eauto. + - pupto2_final. pfold. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + constructor. + inversion H. + repeat (match goal with + | [ H : _ |- _ ] => apply inj_pair2 in H + end). subst. + right. apply CIH. + eapply transitivity. pclearbot. apply REL0. reflexivity. +Qed. +End TranslateFacts. + +Lemma translate_bind : forall {E F R S} (h : E ~> F) (t : itree E S) (k : S -> itree E R), + translate h (x <- t ;; k x) ≅ (x <- (translate h t) ;; translate h (k x)). +Proof. + intros E F R S h t k. + pupto2_init. + revert S t k. + pcofix CIH. + intros s t k. + rewrite itree_eta. + rewrite (itree_eta (x <- translate h t;; translate h (k x))). + rewrite unfold_translate. + rewrite !unfold_bind. + rewrite unfold_translate. + unfold translateF. + unfold ITree.bind_match. + destruct (observe t); cbn. + - rewrite unfold_translate. unfold translateF. + pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +(* categorical properties --------------------------------------------------- *) + +Import Sum1. + +Lemma translate_id : forall E R (t : itree E R), translate idE t ≅ t. +Proof. + intros E R t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta t). + rewrite unfold_translate. + unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +Lemma translate_cmpE : forall E F G R (g : F ~> G) (f : E ~> F) (t : itree E R), + translate (cmpE g f) t ≅ translate g (translate f t). +Proof. + intros E F G R g f t. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta (translate g (translate f t))). + repeat rewrite unfold_translate. + unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. + - pfold. econstructor. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. +Qed. + +(* SAZ: TODO - it would be good to allow for rewriting of event morphisms under translate: + + E ~~ F -> translate E t ≅ translate F t + + Where E ~~ F is extensional equality. +*) \ No newline at end of file From 823f2a223d01678f4efe36774457c0db575be576 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Sun, 24 Feb 2019 10:59:35 -0500 Subject: [PATCH 075/142] fix up for changes to library? --- examples/Den.v | 14 +++++-- examples/Imp.v | 2 +- examples/Imp2Asm.v | 30 +++++++-------- theories/ITree.v | 1 + theories/Morphisms.v | 14 ++----- theories/MorphismsFacts.v | 78 +++------------------------------------ 6 files changed, 37 insertions(+), 102 deletions(-) diff --git a/examples/Den.v b/examples/Den.v index 3d3aba0c..975e7670 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -132,14 +132,16 @@ Section Den. rewrite bind_bind. apply eutt_bind; try reflexivity. intros []; try reflexivity. - rewrite ret_bind; reflexivity. + rewrite itree_eta. + rewrite ret_bind. reflexivity. Qed. (** *** [id_den] respect identity laws *) Lemma id_den_left {A B}: forall (f: denE A B), id_den >=> f ⩰ f. Proof. - intros f a; unfold compose_den, id_den; rewrite ret_bind; reflexivity. + intros f a; unfold compose_den, id_den. + rewrite itree_eta; rewrite ret_bind. rewrite <- itree_eta; reflexivity. Qed. Lemma id_den_right {A B}: forall (f: denE A B), @@ -165,6 +167,7 @@ Section Den. Proof. intros a. unfold lift_den, compose_den. + rewrite itree_eta. rewrite ret_bind. reflexivity. Qed. @@ -190,7 +193,8 @@ Section Den. Proof. intros; intro a. unfold lift_den, compose_den. - rewrite ret_bind; reflexivity. + rewrite itree_eta. + rewrite ret_bind. rewrite <- itree_eta; reflexivity. Qed. Fact compose_den_lift {A B C}: forall (ab: den A B) (g:B -> C), @@ -282,7 +286,9 @@ Section Den. intros. unfold compose_den, lift_den. intros ?. + rewrite itree_eta. rewrite ret_bind. + rewrite <- itree_eta. reflexivity. Qed. @@ -293,7 +299,9 @@ Section Den. intros. unfold compose_den, lift_den. intros ?. + rewrite itree_eta. rewrite ret_bind. + rewrite <- itree_eta. reflexivity. Qed. diff --git a/examples/Imp.v b/examples/Imp.v index 17b831de..6a52f9ad 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -96,7 +96,7 @@ Section Denote. Definition while {eff} (t : itree eff bool) : itree eff unit := rec (fun _ : unit => - continue <- translate (fun _ x => inr1 x) _ t ;; + continue <- translate (fun _ x => inr1 x) t ;; if continue : bool then lift (Call tt) else Monad.ret tt) tt. (* the meaning of a statement *) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 91b19afd..ee7c45ce 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -229,7 +229,6 @@ Section Correctness. Make the keys of the second env monad as the sum of the two initial ones. *) - Arguments denote_program {_ _ _}. Import ITree.Core. @@ -673,6 +672,7 @@ Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} | Some (inl next) => lift (Call next) | Some (inr next) => ret (Some next) end). + Arguments denote_program {_ _ _}. Require Import ITree.MorphismsFacts. Require Import ITree.FixFacts. @@ -710,13 +710,13 @@ end. Proof. destruct x; reflexivity. Qed. Lemma translate_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> F) (Z : _ -> itree _ U) Y, - translate h _ match x with + translate h match x with | inl x => Z x | inr x => Y x end = match x with -| inl x => translate h _ (Z x) -| inr x => translate h _ (Y x) +| inl x => translate h (Z x) +| inr x => translate h (Y x) end. Proof. destruct x; reflexivity. Qed. Lemma translate_match_option : forall {B U} (x : option B) {E F} (h : E ~> F) (Z : itree _ U) Y, @@ -725,8 +725,8 @@ Lemma translate_match_option : forall {B U} (x : option B) {E F} (h : E ~> F) (Z | Some x => Y x end = match x with -| None => translate h _ Z -| Some x => translate h _ (Y x) +| None => translate h Z +| Some x => translate h (Y x) end. Proof. destruct x; reflexivity. Qed. @@ -793,7 +793,7 @@ Lemma rec_fuse : forall {E : Type -> Type} {dom1 codom1 dom2 codom2 : Type} | Call x => inl1 (EnterL x) end | inr1 x => inr1 x - end) _ (f x) + end) (f x) | EnterR x => translate (fun Z x => match x with @@ -802,7 +802,7 @@ Lemma rec_fuse : forall {E : Type -> Type} {dom1 codom1 dom2 codom2 : Type} | Call x => inl1 (EnterR x) end | inr1 x => inr1 x - end) _ (g x) + end) (g x) end) _ Entry. Proof. Admitted. @@ -823,7 +823,7 @@ Lemma rec_fuse' : forall {E : Type -> Type} {dom1 codom1 T : Type} (fun _ elr => match elr with | EnterI => l <- ITree.liftE (inl1 (EnterF x)) ;; - translate (fun _ x => inr1 x) _ (k l) + translate (fun _ x => inr1 x) (k l) | EnterF x => translate (fun Z x => match x with @@ -832,7 +832,7 @@ Lemma rec_fuse' : forall {E : Type -> Type} {dom1 codom1 T : Type} | Call x => inl1 (EnterF x) end | inr1 x => inr1 x - end) _ (f x) + end) (f x) end) _ EnterI. Proof. Admitted. @@ -903,7 +903,7 @@ Lemma lem : forall {E : Type -> Type} {dom1 codom1 U : Type} | Call x => inl1 (EnterF x) end | inr1 x => inr1 x - end) _ Z + end) Z | EnterF x => f x end) _ (EnterF l). Abort. @@ -926,8 +926,8 @@ Lemma lift_sum_rec : forall {A B C : Type} {E} rec (A:=A + B)%type (fun x => match x with - | inl x => translate (fun _ x => inr1 x) _ (L x) - | inr x => translate (fun _ x => inr1 x) _ (R x) + | inl x => translate (fun _ x => inr1 x) (L x) + | inr x => translate (fun _ x => inr1 x) (R x) end) l. Proof. Admitted. @@ -953,10 +953,10 @@ Lemma lift_sum_rec_left match x with | inl1 x => inl1 (inl1 (WithIt t x)) | inr1 x => inr1 x - end) _ (L t _ y) + end) (L t _ y) | inr1 x => match x with - | Call x => translate (fun _ x => inr1 x) _ (R x) + | Call x => translate (fun _ x => inr1 x) (R x) end end) _ match l with | inl x => inl1 (WithIt x (f x)) diff --git a/theories/ITree.v b/theories/ITree.v index e5483705..733a7f35 100644 --- a/theories/ITree.v +++ b/theories/ITree.v @@ -5,6 +5,7 @@ From ITree Require Export Eq.UpToTaus Effect.Sum OpenSum + Translate Morphisms Fix . diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 151c59bf..9f7ab215 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -35,6 +35,7 @@ From ITree Require Import Basics Core Effect.Sum + Translate OpenSum. Open Scope itree_scope. @@ -174,15 +175,6 @@ Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : end) (observe t). -(** A plain effect morphism [E ~> F] defines an itree morphism - [itree E ~> itree F]. *) -Definition translate {E F : Type -> Type} (h : E ~> F) : - itree E ~> itree F := fun R => - cofix translate_ t := - handleF translate_ - (fun _ e k => Vis (h _ e) (fun x => translate_ (k x))) - (observe t). - (** Effects [E, F : Type -> Type] and itree [E ~> itree F] form a category. *) (* todo(gmm): it would be good to have notation for this. @@ -201,8 +193,8 @@ Definition eh_id {A} : A ~> itree A := @ITree.liftE A. Definition eh_par {A B C D} (f : A ~> itree B) (g : C ~> itree D) : (A +' C) ~> itree (B +' D) := fun _ e => match e with - | inl1 e1 => translate (@inl1 _ _) _ (f _ e1) - | inr1 e2 => translate (@inr1 _ _) _ (g _ e2) + | inl1 e1 => translate (@inl1 _ _) (f _ e1) + | inr1 e2 => translate (@inr1 _ _) (g _ e2) end. Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) : (A +' C) ~> itree B := diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 871a0413..0e713fa1 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -11,9 +11,11 @@ From ITree Require Import Core Effect.Sum OpenSum + Translate Morphisms Eq.Eq - Eq.UpToTaus. + Eq.UpToTaus + TranslateFacts. (** * [interp] *) @@ -516,79 +518,11 @@ Instance eutt_interp_state {E F: Type -> Type} {S : Type} Proof. Admitted. -(* Translate facts ---------------------------------------------------------- *) - -Definition translate_u {E F} (h : E ~> F) R : - itreeF E R _ -> itree F R := - handleF (translate h _) - (fun _ e k => Vis (h _ e) (fun x => translate h _ (k x))). - -Lemma translate_unfold {E F R} {h : E ~> F} (t : itree E R) : - observe (translate h _ t) = observe (translate_u h _ (observe t)). -Proof. eauto. Qed. - -Lemma unfold_translate {E F R} {h : E ~> F} (t : itree E R) : - translate h _ t ≅ translate_u h _ (observe t). -Proof. rewrite itree_eta, translate_unfold, <-itree_eta. reflexivity. Qed. - - -Instance translate_Proper : forall {A B R} (h : A ~> B), Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h _). -Proof. - repeat red. - intros A B R h x y H. - pupto2_init. - revert x y H. - pcofix CIH. - intros x y H. - rewrite itree_eta. - rewrite (itree_eta (translate h R y)). - repeat rewrite translate_unfold. unfold translate_u. - rewrite (itree_eta x) in H. - rewrite (itree_eta y) in H. - destruct (observe x); destruct (observe y); pinversion H; subst; cbn. - - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution not working *) - - pupto2_final. pfold. constructor. right. apply CIH. eauto. - - pupto2_final. pfold. - repeat (match goal with - | [ H : _ |- _ ] => apply inj_pair2 in H - end). subst. - constructor. - inversion H. - repeat (match goal with - | [ H : _ |- _ ] => apply inj_pair2 in H - end). subst. - right. apply CIH. - eapply transitivity. pclearbot. apply REL0. reflexivity. -Qed. - -Lemma translate_ret : forall {A B R} (h : A ~> B) (r:R), - translate h _ (Ret r) ≅ Ret r. -Proof. - intros A B R h r. - rewrite itree_eta. - cbn. reflexivity. -Qed. - -Lemma translate_tau : forall {A B R} (h : A ~> B) (t: itree A R), - translate h _ (Tau t) ≅ Tau (translate h _ t). -Proof. - intros A B R h t. - rewrite itree_eta. - cbn. reflexivity. -Qed. - -Lemma translate_vis : forall {A B R} (h : A ~> B) X (e : A X) (k: X -> itree A R), - translate h _ (Vis e k) ≅ Vis (h _ e) (fun x => translate h _ (k x)). -Proof. - intros A B R h X e k. - rewrite itree_eta. - cbn. reflexivity. -Qed. (* Commuting interpreters --------------------------------------------------- *) Lemma interp_translate {E F G} (f : E ~> F) (g : F ~> itree G) {R} (t : itree E R) : - interp g _ (translate f _ t) ≅ interp (fun _ e => g _ (f _ e)) _ t. + interp g _ (translate f t) ≅ interp (fun _ e => g _ (f _ e)) _ t. Proof. pupto2_init. revert t. @@ -680,12 +614,12 @@ Proof. destruct e. - unfold ITree.liftE. rewrite translate_vis. - assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inl1 (E2:=B)) X (Ret x)) (fun x : X => Ret x)). + assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inl1 (E2:=B)) (Ret x)) (fun x : X => Ret x)). { intros x. rewrite translate_ret. reflexivity. } rewrite H. reflexivity. - unfold ITree.liftE. rewrite translate_vis. - assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inr1 (E2:=B)) X (Ret x)) (fun x : X => Ret x)). + assert (pointwise_relation X (@eq_itree (A +' B) _ _ eq) (fun x : X => translate (inr1 (E2:=B)) (Ret x)) (fun x : X => Ret x)). { intros x. rewrite translate_ret. reflexivity. } rewrite H. reflexivity. Qed. From 996403070f940a51989a4550186fdea4d7b99f44 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Sun, 24 Feb 2019 11:45:35 -0500 Subject: [PATCH 076/142] finish relating the (new) translate and interp --- theories/MorphismsFacts.v | 44 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 0e713fa1..3f1bc748 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -531,7 +531,49 @@ Proof. rewrite (itree_eta). rewrite (itree_eta (interp (fun (T : Type) (e : E T) => g T (f T e)) R t)). rewrite !unfold_interp. unfold interp_u. -Admitted. + unfold handleF. rewrite unfold_translate. unfold translateF. + destruct (observe t); cbn. + - pupto2_final. apply Reflexive_eq_itree. (* SAZ: typeclass resolution failure? *) + - pfold. constructor. pupto2_final. right. apply CIH. + - pfold. constructor. + pupto2 eq_itree_clo_bind. + econstructor. + + reflexivity. + + intros. pupto2_final. right. apply CIH. +Qed. + +Lemma translate_to_interp {E F R} (f : E ~> F) (t : itree E R) : + translate f t ≈ interp (fun _ e => ITree.liftE (f _ e)) _ t. +Proof. + pupto2_init. + revert t. + pcofix CIH. + intros t. + rewrite itree_eta. + rewrite (itree_eta (interp (fun (T : Type) (e : E T) => ITree.liftE (f T e)) R t)). + rewrite unfold_translate. + rewrite unfold_interp. + unfold translateF, interp_u, handleF. + rewrite eutt_is_eutt'_gres. + pfold. revert t. pcofix CIH'. + intros t. + destruct (observe t). + - pfold. econstructor. + - pfold. econstructor. + right. rewrite unfold_translate. unfold translateF. + rewrite interp_unfold. unfold interp_u. apply CIH'. + - pfold. econstructor. unfold ITree.liftE. rewrite vis_bind. + econstructor. intros. + rewrite (itree_eta (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))). + assert ((observe (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))) + = observe (interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x))). + { reflexivity. } + rewrite H. + unfold ITree.liftE in CIH. + rewrite <- itree_eta. + pupto2_final. right. + apply CIH. +Qed. (* Morphism Category -------------------------------------------------------- *) From 7e834e56a67f152b3ff554b8dde14d4c87ea3296 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 09:14:08 -0500 Subject: [PATCH 077/142] Resolve admits in SimUpToTaus --- theories/Eq/SimUpToTaus.v | 153 +++++++++++++++++++++++--------------- theories/Eq/UpToTaus.v | 10 +++ 2 files changed, 104 insertions(+), 59 deletions(-) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index 2579fcda..d6866610 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -44,6 +44,52 @@ Proof. eapply unalltaus_injective; eauto. Qed. +Inductive suttF0 (eutt : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| suttF0_notau ot2' : + notauF ot1 -> + unalltausF ot2 ot2' -> + eq_notauF RR eutt ot1 ot2' -> + suttF0 eutt ot1 ot2 +| suttF0_tau t1 : + ot1 = TauF t1 -> + suttF eutt (observe t1) ot2 -> + suttF0 eutt ot1 ot2 +. +Hint Constructors suttF0. + +Lemma sutt_inv eutt ot1 ot2 : + suttF eutt ot1 ot2 <-> + suttF0 eutt ot1 ot2. +Proof. + split; intros SUTT. + - destruct SUTT. destruct ot1. + + assert (Iuat1 : @unalltausF E _ (RetF r) (RetF r)). + { repeat constructor. } + edestruct FIN as [ot2' [Iuntaus Inotau]]. + { eauto. } + eapply suttF0_notau; eauto. + + eapply suttF0_tau; auto. + constructor. + * rewrite finite_taus_tau in FIN; auto. + * intros. apply EQV; auto. + eapply unalltaus_tau'; auto. + + assert (Iuat1 : @unalltausF E _ (VisF e k) (VisF e k)). + { repeat constructor. } + edestruct FIN as [ot2' [Iuntaus Inotau]]. + { eauto. } + eapply suttF0_notau; eauto. + - destruct SUTT. + + constructor; eauto. + intros; auto_untaus. + + subst; destruct H0; constructor. + * rewrite finite_taus_tau; auto. + * intros; auto_untaus. + eapply unalltaus_tau in UNTAUS1; auto. + apply EQV; auto. +Qed. + Definition sutt_ (eutt : itree E R1 -> itree E R2 -> Prop) (t1 : itree E R1) (t2 : itree E R2) : Prop := suttF eutt (observe t1) (observe t2). @@ -69,6 +115,8 @@ Hint Constructors suttF. Hint Unfold sutt_. Hint Resolve monotone_sutt_ : paco. +Hint Constructors suttF0. + Lemma monotone_eq_notauF_RR {E R1 R2} (RR1 RR2 : R1 -> R2 -> Prop) {I J} (r : I -> J -> Prop) : (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) -> @@ -120,24 +168,6 @@ Proof. intros; pclearbot; auto. Qed. -Inductive suttF' {E R} (sutt: relation (itree E R)) : - relation (itree' E R) := -| suttF'_notau ot1 ot2 ot2' : - unalltausF ot2 ot2' -> - eq_notauF eq sutt ot1 ot2' -> - suttF' sutt ot1 ot2 -| suttF'_tau_left t1 ot2 - (EQTAUS: suttF' sutt (observe t1) ot2): - suttF' sutt (TauF t1) ot2 -. -Hint Constructors suttF'. - -Theorem suttF_suttF' {E R} (sutt : relation (itree E R)) : - forall ot1 ot2, - suttF eq sutt ot1 ot2 <-> suttF' sutt ot1 ot2. -Proof. -Admitted. - Inductive suttF1 {E R} (sutt: itree' E R -> itree' E R -> Prop) : itree' E R -> itree' E R -> Prop := | suttF1_ret r : suttF1 sutt (RetF r) (RetF r) @@ -167,48 +197,53 @@ Lemma monotone_suttF1 {E R} : monotone2 (@suttF1 E R). Proof. repeat red; intros. induction IN; eauto. Qed. Hint Resolve monotone_suttF1 : paco. -Lemma sutt_is_sutt1 {E R} (t1 t2: itree E R) : - sutt eq t1 t2 <-> sutt1 t1 t2. +Lemma sutt_to_sutt1 {E R} : + forall (t1 t2: itree E R), sutt eq t1 t2 -> sutt1 t1 t2. Proof. - split; revert t1 t2; pcofix self; intros t1 t2 SUTT. - - punfold SUTT. pfold. - apply suttF_suttF' in SUTT. - induction SUTT; auto. - destruct H as [Huntaus Hnotau]. + pcofix self; intros t1 t2 SUTT. + punfold SUTT. pfold. + apply sutt_inv in SUTT. + destruct SUTT. + - destruct H0 as [Huntaus Hnotau]. induction Huntaus. - + inversion H0; subst; constructor. - pclearbot. right; apply self; red; auto. + + destruct H1; subst; auto. + pclearbot; constructor; right; apply self; apply H0. + subst; auto. - - punfold SUTT. pfold. - red. - induction SUTT. - + constructor; eauto. intros. - apply unalltausF_ret in UNTAUS1. - apply unalltausF_ret in UNTAUS2. - subst; auto. - + constructor; eauto 7. intros. - apply unalltausF_vis in UNTAUS1. - apply unalltausF_vis in UNTAUS2. - pclearbot; subst; auto. - constructor. right; auto. - + destruct IHSUTT; constructor; intros. - * apply finite_taus_tau; auto. - * apply EQV. auto. eapply unalltaus_tau; eauto. - + pclearbot; punfold EQTAUS. - eapply suttF_unpack. - intros t0' Hunalltaus. - eapply unalltaus_tau in Hunalltaus; eauto. - destruct Hunalltaus as [Huntaus Hnotau]. - revert ot2 EQTAUS. - induction Huntaus; intros. - * induction EQTAUS; - contradiction + eauto 6. - { pclearbot. econstructor. repeat (constructor; auto). } - { destruct IHEQTAUS as [ot2' []]; auto. - eexists; split; eauto using unalltaus_tau'. } - * induction EQTAUS; - discriminate + eauto 6. - { destruct IHEQTAUS as [? []]; auto. - eexists; eauto using unalltaus_tau'. } - { pclearbot. inv OBS. punfold EQTAUS; auto. } + - rewrite H; constructor. right; apply self. pfold; auto. +Qed. + +Lemma sutt1_to_sutt {E R} : + forall (t1 t2: itree E R), sutt1 t1 t2 -> sutt eq t1 t2. +Proof. + pcofix self; intros t1 t2 SUTT. + punfold SUTT. pfold. red. + induction SUTT. + - apply sutt_inv; eauto 7. + - pclearbot. apply sutt_inv; eapply suttF0_notau; eauto. + constructor; auto. + - destruct IHSUTT. constructor. + + rewrite finite_taus_tau; auto. + + intros. eapply unalltaus_tau in UNTAUS2; eauto. + - pclearbot. apply suttF_unpack. + intros. eapply unalltaus_tau in H; eauto. + destruct H as [Huntaus Hnotau]. + revert ot2 EQTAUS; induction Huntaus; intros. + + punfold EQTAUS. induction EQTAUS. + * eauto 9. + * eexists; split. + { repeat constructor. } + { pclearbot; constructor; auto. } + * destruct IHEQTAUS as [? []]; auto. + eauto using unalltaus_tau'. + * contradiction. + + punfold EQTAUS. induction EQTAUS; try discriminate. + * destruct IHEQTAUS as [? []]; auto. + eauto using unalltaus_tau'. + * pclearbot; inv OBS. eauto. +Qed. + +Lemma sutt_is_sutt1 {E R} (t1 t2 : itree E R) : + sutt eq t1 t2 <-> sutt1 t1 t2. +Proof. + split. apply sutt_to_sutt1. apply sutt1_to_sutt. Qed. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index dde03b3e..cab226b5 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -291,6 +291,16 @@ Notation finite_taus t := (finite_tausF (observe t)). Notation untaus t t' := (untausF (observe t) (observe t')). Notation unalltaus t t' := (unalltausF (observe t) (observe t')). +Ltac auto_untaus := + repeat match goal with + | [ H1 : notauF ?X, H2 : unalltausF ?X ?Y |- _ ] => + assert_fails (unify X Y); + replace Y with X in * by apply (unalltaus_notau_id _ _ H2 H1) + | [ H1 : unalltausF ?X ?Y, H2 : unalltausF ?X ?Z |- _ ] => + assert_fails (unify Y Z); + replace Z with Y in * by apply (unalltaus_injective _ _ _ H1 H2) + end; auto. + Section EUTT. Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). From d1aed6b40b083c4b189cc8a6c3b55729e4949c47 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 10:12:20 -0500 Subject: [PATCH 078/142] eutt: generalize symmetry and transitivity to heterogeneous relations --- theories/Eq/UpToTaus.v | 175 +++++++++++++++++++++++++++++++---------- 1 file changed, 134 insertions(+), 41 deletions(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index cab226b5..c6b949d6 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -573,17 +573,125 @@ Qed. Delimit Scope eutt_scope with eutt. +(** ** Generalized symmetry and transitivity *) + +Lemma Symmetric_eq_notauF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + {I J} (r1 : I -> J -> Prop) (r2 : J -> I -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J) : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot1. +Proof. intros []; auto. Qed. + +Lemma Transitive_eq_notauF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + {I J K} (r1 : I -> J -> Prop) (r2 : J -> K -> Prop) + (r3 : I -> K -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itreeF E R1 I) ot2 ot3 : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot3 -> + eq_notauF RR3 r3 ot1 ot3. +Proof. + intros [] I2; inversion I2; eauto. + auto_inj_pair2; subst; eauto. +Qed. + +Lemma Symmetric_euttF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itree' E R1) (ot2 : itree' E R2) : + euttF RR1 r1 ot1 ot2 -> + euttF RR2 r2 ot2 ot1. +Proof. + intros []; split. + - split; apply FIN. + - intros. specialize (EQV _ _ UNTAUS2 UNTAUS1). + eapply Symmetric_eq_notauF_; eauto. +Qed. + +Lemma Transitive_euttF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (r3 : _ -> _ -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itree' E R1) ot2 ot3 : + euttF RR1 r1 ot1 ot2 -> + euttF RR2 r2 ot2 ot3 -> + euttF RR3 r3 ot1 ot3. +Proof. + intros [] []. + constructor. + - etransitivity; eauto. + - intros t1' t3' H1 H3. + assert (FIN2 : finite_tausF ot2). + { apply FIN; eauto. } + destruct FIN2 as [t2' []]. + eapply Transitive_eq_notauF_; eauto. +Qed. + +Lemma Symmetric_eutt_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (eutt_ RR1) r1 t1 t2 -> paco2 (eutt_ RR2) r2 t2 t1. +Proof. + pcofix self. + intros t1 t2 H12. + punfold H12. + pfold. + eapply Symmetric_euttF_; try eassumption. + intros ? ? []; auto. +Qed. + +Lemma Transitive_eutt_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) : + forall (t1 : itree E R1) t2 t3, + eutt RR1 t1 t2 -> eutt RR2 t2 t3 -> eutt RR3 t1 t3. +Proof. + pcofix self. + intros t1 t2 t3 H12 H23. + punfold H12; punfold H23; pfold. + eapply Transitive_euttF_; try eassumption. + intros; pclearbot; eauto. +Qed. + Section EUTT_rel. Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). (* Reflexivity of [eq_notauF], modulo a few assumptions. *) -Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) (ot : itreeF E R I) : - Reflexive eq_ -> notauF ot -> eq_notauF RR eq_ ot ot. +Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) : + Reflexive eq_ -> + forall (ot : itreeF E R I), notauF ot -> eq_notauF RR eq_ ot ot. Proof. intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. Qed. +Global Instance Symmetric_eq_notauF `{Symmetric _ RR} I (eq_ : I -> I -> Prop) : + Symmetric eq_ -> Symmetric (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Symmetric_eq_notauF_; eauto. +Qed. + +Global Instance Transitive_eq_notauF `{Transitive _ RR} I (eq_ : I -> I -> Prop) : + Transitive eq_ -> Transitive (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Transitive_eq_notauF_; eauto. +Qed. + Global Instance subrelation_eq_eutt : @subrelation (itree E R) (eq_itree RR) (eutt RR). Proof. @@ -597,14 +705,7 @@ Proof. eapply unalltaus_notau in UNTAUS1. contradiction. Qed. -End EUTT_rel. - -Section EUTT_eq. - -Context {E : Type -> Type} {R : Type}. - -Global Instance Reflexive_euttF - {RR : R -> R -> Prop} `{Reflexive _ RR} +Global Instance Reflexive_euttF `{Reflexive _ RR} (r : itree E R -> itree E R -> Prop) : Reflexive r -> Reflexive (euttF RR r). Proof. @@ -615,6 +716,26 @@ Proof. apply Reflexive_eq_notauF; eauto. Qed. +Global Instance Symmetric_euttF `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) : + Symmetric r -> Symmetric (euttF RR r). +Proof. + intros SYM x y. apply Symmetric_euttF_; auto. +Qed. + +Global Instance Transitive_euttF `{Transitive _ RR} + (r : itree E R -> itree E R -> Prop) : + Transitive r -> Transitive (euttF RR r). +Proof. + intros TRANS x y z. apply Transitive_euttF_; auto. +Qed. + +End EUTT_rel. + +Section EUTT_eq. + +Context {E : Type -> Type} {R : Type}. + Global Instance Reflexive_eutt {RR : R -> R -> Prop} `{Reflexive _ RR} (r : itree E R -> itree E R -> Prop) : @@ -631,40 +752,12 @@ Infix "≈" := eutt (at level 70) : itree_scope. Global Instance Symmetric_eutt (r : itree E R -> itree E R -> Prop) (Sr : Symmetric r) : Symmetric (paco2 (eutt_ eq) r). -Proof. - pcofix Symmetric_eutt. - intros t1 t2 H12. - punfold H12. - pfold. - destruct H12 as [I12 H12]. - split. - - symmetry; assumption. - - intros. hexploit H12; eauto. intros. - inv H; eauto. - econstructor. intros. destruct (H0 x); eauto. -Qed. +Proof. red; eapply Symmetric_eutt_; eauto. Qed. Global Instance Transitive_eutt : Transitive eutt. Proof. - pcofix Transitive_eutt. - intros t1 t2 t3 H12 H23. - punfold H12. - punfold H23. - pfold. - destruct H12 as [I12 H12]. - destruct H23 as [I23 H23]. - split. - - etransitivity; eauto. - - intros t1' t3' H1 H3. - destruct I12 as [I1 I2]. - destruct I1 as [n2' [t2' TAUS2]]; eauto. - hexploit H12; eauto. intros REL1. - hexploit H23; eauto. intros REL2. - destruct REL1; inversion REL2; clear REL2. - + subst; eauto. - + auto_inj_pair2; subst. - econstructor; auto. intros. - specialize (H x); specialize (H6 x). pclearbot. eauto. + red; eapply Transitive_eutt_; eauto. + intros; subst; eauto. Qed. (**) From e73f9317825cc33bf4b1dc2ff1ab91e2b82f8e81 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 10:18:06 -0500 Subject: [PATCH 079/142] Prove eutt_eq_under_rr --- theories/Eq/UpToTaus.v | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index c6b949d6..2a0db390 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -1065,10 +1065,25 @@ Proof. apply subrelation_eq_eutt, map_map. Qed. +Lemma eutt_eq_under_rr_impl {E : Type -> Type} + {R1 R2 : Type} (RR: R1 -> R2 -> Prop): + Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> impl) (eutt RR). +Proof. + repeat intro. + symmetry in H. + eapply Transitive_eutt_; try eassumption. + 2: eapply Transitive_eutt_; try eassumption. + all: intros; subst; eauto. +Qed. + Global Instance eutt_eq_under_rr {E : Type -> Type} {R1 R2 : Type} (RR: R1 -> R2 -> Prop): Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). -Admitted. +Proof. + repeat intro. + split; eapply eutt_eq_under_rr_impl; auto. + all: symmetry; auto. +Qed. (** Generalized heterogeneous version of [eutt_bind] *) Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: From a83a5e6512d9b105d606e643477b051031f6e727 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 10:34:28 -0500 Subject: [PATCH 080/142] Prove eutt_bind_gen --- theories/Eq/SimUpToTaus.v | 112 ++++++++++++++++++++++++++++++++------ theories/Eq/UpToTaus.v | 36 +++++------- theories/FixFacts.v | 13 +++-- 3 files changed, 115 insertions(+), 46 deletions(-) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index d6866610..bcb9cca7 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -154,9 +154,9 @@ Proof. intros; pclearbot; auto. Qed. -Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) : +Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) r : forall (t1 : itree E R1) (t2 : itree E R2), - eutt RR t1 t2 -> sutt RR t1 t2. + paco2 (eutt_ RR) r t1 t2 -> paco2 (sutt_ RR) r t1 t2. Proof. pcofix self; intros t1 t2 H1. punfold H1. @@ -165,12 +165,18 @@ Proof. - apply FIN1. - intros. eapply monotone_eq_notauF; eauto. - intros; pclearbot; auto. + intros ? ? []; auto. Qed. -Inductive suttF1 {E R} (sutt: itree' E R -> itree' E R -> Prop) : - itree' E R -> itree' E R -> Prop := -| suttF1_ret r : suttF1 sutt (RetF r) (RetF r) +Hint Resolve eutt_sutt. + +Section SUTT1. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Inductive suttF1 (sutt: itree' E R1 -> itree' E R2 -> Prop) : + itree' E R1 -> itree' E R2 -> Prop := +| suttF1_ret r1 r2 : RR r1 r2 -> suttF1 sutt (RetF r1) (RetF r2) | suttF1_vis u (e : E u) k1 k2 (SUTTK: forall x, sutt (observe (k1 x)) (observe (k2 x))): suttF1 sutt (VisF e k1) (VisF e k2) @@ -183,22 +189,39 @@ Inductive suttF1 {E R} (sutt: itree' E R -> itree' E R -> Prop) : . Hint Constructors suttF1. -Definition sutt1 {E R} (t1 t2 : itree E R) := - paco2 (@suttF1 E R) bot2 (observe t1) (observe t2). +Definition sutt1 (t1 : itree E R1) (t2 : itree E R2) := + paco2 suttF1 bot2 (observe t1) (observe t2). Hint Unfold sutt1. -Lemma reflexive_suttF1 {E R} sutt (r1:Reflexive sutt) : Reflexive (@suttF1 E R sutt). +End SUTT1. + +Hint Constructors suttF1. +Hint Unfold sutt1. + +Section SUTT1_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + +Lemma reflexive_suttF1 `{Reflexive _ RR} sutt (r1:Reflexive sutt) : Reflexive (@suttF1 E _ _ RR sutt). Proof. unfold Reflexive. intros x. destruct x; eauto. Qed. -Lemma monotone_suttF1 {E R} : monotone2 (@suttF1 E R). +End SUTT1_rel. + +Section SUTT1_facts. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Lemma monotone_suttF1 : monotone2 (@suttF1 E _ _ RR). Proof. repeat red; intros. induction IN; eauto. Qed. Hint Resolve monotone_suttF1 : paco. -Lemma sutt_to_sutt1 {E R} : - forall (t1 t2: itree E R), sutt eq t1 t2 -> sutt1 t1 t2. +Lemma sutt_to_sutt1 (r : _ -> _ -> Prop) (r' : _ -> _ -> Prop) + (IMPL_rr' : forall t1 t2, r t1 t2 -> observing r' t1 t2) : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (sutt_ RR) r t1 t2 -> paco2 (suttF1 RR) r' (observe t1) (observe t2). Proof. pcofix self; intros t1 t2 SUTT. punfold SUTT. pfold. @@ -207,13 +230,15 @@ Proof. - destruct H0 as [Huntaus Hnotau]. induction Huntaus. + destruct H1; subst; auto. - pclearbot; constructor; right; apply self; apply H0. + constructor. intros x; edestruct (H0 x). + * right; auto. + * right; auto. apply self0. apply IMPL_rr'; auto. + subst; auto. - rewrite H; constructor. right; apply self. pfold; auto. Qed. -Lemma sutt1_to_sutt {E R} : - forall (t1 t2: itree E R), sutt1 t1 t2 -> sutt eq t1 t2. +Lemma sutt1_to_sutt : forall (t1 : itree E R1) (t2 : itree E R2), + sutt1 RR t1 t2 -> sutt RR t1 t2. Proof. pcofix self; intros t1 t2 SUTT. punfold SUTT. pfold. red. @@ -242,8 +267,59 @@ Proof. * pclearbot; inv OBS. eauto. Qed. -Lemma sutt_is_sutt1 {E R} (t1 t2 : itree E R) : - sutt eq t1 t2 <-> sutt1 t1 t2. +Lemma sutt_is_sutt1 (t1 : itree E R1) (t2 : itree E R2) : + sutt RR t1 t2 <-> sutt1 RR t1 t2. +Proof. + split. + - intros; eapply sutt_to_sutt1; try eassumption; auto. + - apply sutt1_to_sutt. +Qed. + +End SUTT1_facts. + +Hint Resolve @monotone_suttF1 : paco. + +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma sutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + sutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> sutt SS (s1 r1) (s2 r2)) -> + @sutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). +Proof. + intros; apply sutt_is_sutt1. + apply sutt_is_sutt1 in H. + revert t1 t2 H; pcofix self; intros. + punfold H1. + genobs t1 ot1. genobs t2 ot2. + revert t1 t2 Heqot1 Heqot2. + induction H1; intros. + - rewrite 2 unfold_bind, <- Heqot1, <- Heqot2; simpl. + eapply sutt_to_sutt1; [ | eapply H0; eauto]. intros ? ? []. + - rewrite 2 unfold_bind, <- Heqot1, <- Heqot2; simpl. + pclearbot. pfold; constructor. auto. + - rewrite (unfold_bind t0), <- Heqot2; simpl. + pfold; constructor. + apply paco2_unfold; [auto with paco |]. + eapply IHsuttF1; auto. + - rewrite (unfold_bind t0), <- Heqot1; simpl. + pfold; constructor. + pclearbot; subst; auto. +Qed. + +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). Proof. - split. apply sutt_to_sutt1. apply sutt1_to_sutt. + intros. apply sutt_eutt; eapply sutt_bind_gen. + - apply eutt_sutt; eassumption. + - intros. apply eutt_sutt. apply H0; auto. + - apply eutt_sutt. + eapply Symmetric_eutt_; try eassumption; auto. + intros ? ? HH; apply HH. + - simpl. intros. apply eutt_sutt. eapply Symmetric_eutt_; try eassumption; eauto. + 2: eapply H0; auto. + auto. Qed. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 2a0db390..ddc4bfd0 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -730,14 +730,13 @@ Proof. intros TRANS x y z. apply Transitive_euttF_; auto. Qed. -End EUTT_rel. - -Section EUTT_eq. - -Context {E : Type -> Type} {R : Type}. +Global Instance Symmetric_eutt `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) + (Sr : Symmetric r) : + Symmetric (paco2 (eutt_ RR) r). +Proof. red; eapply Symmetric_eutt_; eauto. Qed. -Global Instance Reflexive_eutt - {RR : R -> R -> Prop} `{Reflexive _ RR} +Global Instance Reflexive_eutt `{Reflexive _ RR} (r : itree E R -> itree E R -> Prop) : Reflexive (paco2 (eutt_ RR) r). Proof. @@ -745,15 +744,16 @@ Proof. intros. pfold. red. apply Reflexive_euttF; eauto. Qed. +End EUTT_rel. + +Section EUTT_eq. + +Context {E : Type -> Type} {R : Type}. + Let eutt : itree E R -> itree E R -> Prop := eutt eq. Infix "≈" := eutt (at level 70) : itree_scope. -Global Instance Symmetric_eutt (r : itree E R -> itree E R -> Prop) - (Sr : Symmetric r) : - Symmetric (paco2 (eutt_ eq) r). -Proof. red; eapply Symmetric_eutt_; eauto. Qed. - Global Instance Transitive_eutt : Transitive eutt. Proof. red; eapply Transitive_eutt_; eauto. @@ -771,7 +771,7 @@ Proof. eapply unalltaus_tau in H1; eauto. assert (X := unalltaus_injective _ _ _ H1 H2). subst; apply Reflexive_eq_notauF; eauto. - left. apply Reflexive_eutt. + left. apply reflexivity. Qed. Lemma tau_eutt (t: itree E R) : Tau t ≈ t. @@ -788,7 +788,7 @@ Proof. - induction H; intros. + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). apply Reflexive_eq_notauF; eauto. - left; apply Reflexive_eutt. + left; apply reflexivity. + eapply unalltaus_tau in UNTAUS1; eauto. Qed. @@ -1085,14 +1085,6 @@ Proof. all: symmetry; auto. Qed. -(** Generalized heterogeneous version of [eutt_bind] *) -Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: - forall t1 t2, - eutt RR t1 t2 -> - forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> - @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). -Admitted. - Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : itree' E R -> itree' E R -> Prop := | euttF1_Tau_L : forall t1 t2, diff --git a/theories/FixFacts.v b/theories/FixFacts.v index a2f03173..db67cd5f 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -501,7 +501,7 @@ Hint Constructors loop_preinv. Lemma eutt_loop_inv_main_step (ca : C + A) t1 t2 : t1 ≅ loop_ f1 ca -> t2 ≅ loop_ f2 ca -> - suttF1 (going loop_preinv) (observe t1) (observe t2). + suttF1 eq (going loop_preinv) (observe t1) (observe t2). Proof. intros H1 H2. rewrite unfold_loop' in H1. @@ -518,7 +518,7 @@ Proof. revert t1 t2 H1 H2. induction eutt_f; intros z1 z2 H1 H2. - - destruct r. + - subst; destruct r2. + apply eq_itree_tau_inv1 in H1. destruct H1 as [t1' [Ht1 Ht1']]. apply eq_itree_tau_inv1 in H2. @@ -564,7 +564,7 @@ Proof. Qed. Lemma eutt_loop_inv ot1 ot2 : - loop_preinv (go ot1) (go ot2) -> paco2 suttF1 bot2 ot1 ot2. + loop_preinv (go ot1) (go ot2) -> paco2 (suttF1 eq) bot2 ot1 ot2. Proof. intros HH. revert ot1 ot2 HH; pcofix self; intros. pfold. @@ -578,7 +578,7 @@ Proof. rewrite unfold_bind in H2. revert ot1 ot2 H1 H2; induction Hu; intros. - + destruct r0. + + subst; destruct r2. * apply eq_itree_tau_inv1 in H1. apply eq_itree_tau_inv1 in H2. simpl in H1, H2. @@ -589,7 +589,7 @@ Proof. eapply loop_inv_main; rewrite <- itree_eta; eauto. * apply eq_itree_ret_inv1 in H1. apply eq_itree_ret_inv1 in H2. - simpl in H1, H2. subst; constructor. + simpl in H1, H2. subst; auto. + pclearbot. apply eq_itree_vis_inv1 in H1. @@ -644,6 +644,7 @@ Instance eutt_loop {E A B C} : Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B C). Proof. repeat intro; subst. + repeat red in H. eapply sutt_eutt. - eapply sutt_loop; auto. repeat intro; subst. @@ -651,7 +652,7 @@ Proof. - eapply paco2_mon_gen. + eapply sutt_loop; auto. repeat intro. - apply eutt_sutt; symmetry; auto. + apply eutt_sutt. apply symmetry; auto. + intros. eapply monotone_sutt_RR; try eassumption. red; auto. + auto. From 99312b2a825e23d55bb553611bc0449d4cf1a669 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 11:30:50 -0500 Subject: [PATCH 081/142] Words about sutt --- theories/Eq/SimUpToTaus.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index bcb9cca7..c3338086 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -1,5 +1,18 @@ (** * Simulation Up To Tau *) +(** A preorder [sutt t1 t2], where every visible step + ([RetF] or [VisF]) on the left must be matched with a corresponding + step on the right, ignoring [TauF]. + + In particular, [spin := Tau spin] is less than everything. + + The induced equivalence relation is [eutt]. + + Various [Proper] lemmas about [eutt] are more easily proved as + [Proper] lemmas about [sutt] first, and then symmetrizing using + [eutt_sutt] and [sutt_eutt]. + *) + Require Import Paco.paco. From Coq Require Import From 1c623f0cdaaf4d2ba2105d1d75f949f4abaec132 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 11:52:02 -0500 Subject: [PATCH 082/142] Export SimUpToTaus by default --- theories/ITree.v | 1 + 1 file changed, 1 insertion(+) diff --git a/theories/ITree.v b/theories/ITree.v index 733a7f35..2aeddc44 100644 --- a/theories/ITree.v +++ b/theories/ITree.v @@ -3,6 +3,7 @@ From ITree Require Export Core Eq.Eq Eq.UpToTaus + Eq.SimUpToTaus Effect.Sum OpenSum Translate From 2c25877d3ba7bafc69f59fcf09ba155d01adaa77 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 11:53:06 -0500 Subject: [PATCH 083/142] Makefile: refactor build system for examples --- .gitignore | 1 + Makefile | 45 +++++--------------------------- examples/ExtractThreadsExample.v | 4 +-- examples/Imp2Asm.v | 5 ++-- examples/Makefile | 35 +++++++++++++++++++++++++ examples/_CoqProject | 15 +++++++++++ 6 files changed, 62 insertions(+), 43 deletions(-) create mode 100644 examples/Makefile create mode 100644 examples/_CoqProject diff --git a/.gitignore b/.gitignore index d6f3606a..9f1b379c 100644 --- a/.gitignore +++ b/.gitignore @@ -34,5 +34,6 @@ tests/extraction/*.ml tests/extraction/*.mli examples/io.ml examples/io.mli +examples/extracted/ *.native diff --git a/Makefile b/Makefile index e1bf7810..dc98653f 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,4 @@ -.PHONY: clean all coq test tests examples install uninstall depgraph \ - example-imp example-lc example-io example-nimp example-asm +.PHONY: clean all coq test tests examples install uninstall depgraph COQPATHFILE=$(wildcard _CoqPath) @@ -17,41 +16,10 @@ uninstall: Makefile.coq test: examples tests tests: - make -C tests + $(MAKE) -C tests -examples: example-imp example-lc example-io example-nimp example-threads - -examples/%.vo: examples/%.v - cd examples && \ - coqc -Q ../theories/ ITree $*.v - -example-imp: examples/Imp.vo - -example-lc: examples/stlc.vo - -example-lc: examples/stlc.vo - -example-io: examples/IO.vo - cd examples && \ - ocamlbuild io.native && ./io.native - -examples/Asm.vo: examples/sum.vo examples/Imp.vo -examples/Imp2Asm.vo: examples/Asm.vo -examples/Imp2AsmBis.vo: examples/sum.vo examples/Asm.vo - -example-asm: examples/Asm.vo - -example-imp2asm: examples/Imp2Asm.vo - -example-imp2asm2: examples/Imp2AsmBis.vo - -THREADSV=examples/MultiThreadedPrinting.v examples/ExtractThreadsExample.v -THREADSML=examples/runthread.ml -example-threads: $(THREADSV) $(THREADSML) - coqc -Q theories/ ITree -Q examples/ Examples $(THREADSV) && \ - cd examples && \ - ocamlbuild -I extracted runthread.native && \ - ./runthread.native +examples: + $(MAKE) -C examples Makefile.coq: _CoqProject coq_makefile -f $< -o $@ @@ -59,10 +27,9 @@ Makefile.coq: _CoqProject clean: Makefile.coq $(MAKE) -f Makefile.coq clean $(MAKE) -C tests clean - $(RM) {*,*/*}/*.{vo,glob} {*,*/*}/.*.aux + $(MAKE) -C examples clean + $(RM) theories/{*,*/*}/*.{vo,glob} theories/{*,*/*}/.*.aux $(RM) _CoqProject Makefile.coq* - $(RM) examples/extracted/*.* - cd examples && ocamlbuild -clean _CoqProject: $(COQPATHFILE) _CoqConfig Makefile @ echo "# Generating _CoqProject" diff --git a/examples/ExtractThreadsExample.v b/examples/ExtractThreadsExample.v index e414f129..cfc9427f 100644 --- a/examples/ExtractThreadsExample.v +++ b/examples/ExtractThreadsExample.v @@ -7,9 +7,9 @@ Extraction Blacklist String List Char Core Z. Set Extraction AccessOpaque. (* NOTE: assumes that this file is compiled from / *) -Cd "examples/extracted". +Cd "extracted". Recursive Extraction Library MultiThreadedPrinting. (* This is needed for the makefile to succeed for some reason. *) -Cd "../..". +Cd "..". diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index ee7c45ce..af655b48 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -9,6 +9,7 @@ From Coq Require Import RelationClasses. From ITree Require Import + Basics_Functions Effect.Env ITree. @@ -237,7 +238,7 @@ Section Correctness. Lemma fmap_block_map: forall {L L'} b (f: L -> L'), - denote_block E (fmap_block f b) ≅ ITree.map (option_map f) (denote_block E b). + denote_block E (fmap_block f b) ≅ ITree.map (sum_bimap f id) (denote_block E b). Proof. induction b as [i b | br]; intros f. - simpl. @@ -1293,4 +1294,4 @@ Section tests. End tests. -*) \ No newline at end of file +*) diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 index 00000000..66db55fe --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,35 @@ +.PHONY: example-imp example-lc example-io example-nimp example-asm example-threads + +examples: Makefile.coq + $(MAKE) -f Makefile.coq + +Makefile.coq: _CoqProject + coq_makefile -f $< -o $@ + +example-imp: + $(MAKE) -f Makefile.coq Imp.vo + +example-asm: + $(MAKE) -f Makefile.coq Asm.vo + +example-lc: + $(MAKE) -f Makefile.coq stlc.vo + +example-io: + $(MAKE) -f Makefile.coq IO.vo + +example-nimp: + $(MAKE) -f Makefile.coq Nimp.vo + +THREADSV=MultiThreadedPrinting.vo ExtractThreadsExample.vo +THREADSML=runthread.ml + +example-threads: Makefile.coq $(THREADSML) + $(MAKE) -f Makefile.coq $(THREADSV) + coqc -Q theories/ ITree -Q examples/ Examples $(THREADSV) + ocamlbuild -I extracted runthread.native + ./runthread.native + +clean: + ocamlbuild -clean + $(RM) extracted/*.* diff --git a/examples/_CoqProject b/examples/_CoqProject new file mode 100644 index 00000000..768db7c6 --- /dev/null +++ b/examples/_CoqProject @@ -0,0 +1,15 @@ +-Q ../theories ITree +-R . Examples + +IO.v +MultiThreadedPrinting.v +ExtractThreadsExample.v + +Asm.v +Den.v +Imp.v +Linking.v +Imp2Asm.v + +Nimp.v +stlc.v From b07ccc94faf8bb512fb1de50a089b0acb3eab425 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Sun, 24 Feb 2019 21:26:23 -0500 Subject: [PATCH 084/142] added eh_swap --- theories/Morphisms.v | 3 +++ theories/MorphismsFacts.v | 34 ++++++++++++++++++++++++++++++++-- 2 files changed, 35 insertions(+), 2 deletions(-) diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 9f7ab215..5264ae83 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -210,6 +210,9 @@ Definition eh_left {A B} : A ~> itree (A +' B) := Definition eh_right {A B} : B ~> itree (A +' B) := fun _ e => Vis (inr1 e) (fun x => Ret x). +Definition eh_swap {A B} : A +' B ~> itree (B +' A) := + eh_both eh_right eh_left. + (** Standard interpreters *) Import ITree.Basics.Monads. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 3f1bc748..80bc3a7d 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -666,5 +666,35 @@ Proof. rewrite H. reflexivity. Qed. - - +Lemma bind_vis : forall {E R S T} e (k1 : R -> itree E S) (k2 : S -> itree E T), + (x <- (Vis e k1) ;; k2 x) ≅ Vis e (fun y => x <- (k1 y) ;; k2 x). +Proof. + intros E R S T e k1 k2. + rewrite itree_eta. + unfold_bind. cbn. reflexivity. +Qed. + +Lemma eh_swap_swap_id : forall A B, eh_compose eh_swap eh_swap ≡ (eh_id : (A +' B) ~> itree (A +' B)). +Proof. + intros A B X e. + unfold eh_compose. unfold eh_swap. + rewrite unfold_interp. unfold interp_u. + unfold handleF. + unfold eh_both. destruct e; cbn. + - eapply transitivity. apply tau_eutt. + unfold eh_left. + rewrite bind_vis. + unfold eh_id. unfold ITree.liftE. + apply eutt_Vis. + intros x. + rewrite itree_eta. cbn. + reflexivity. + - eapply transitivity. apply tau_eutt. + unfold eh_right. + rewrite bind_vis. + unfold eh_id. unfold ITree.liftE. + apply eutt_Vis. + intros x. + rewrite itree_eta. cbn. + reflexivity. +Qed. \ No newline at end of file From aa19ea32259ead71aba6259b5830886d0644069e Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sun, 24 Feb 2019 21:44:05 -0500 Subject: [PATCH 085/142] Fix imp2asm compiler --- examples/Asm.v | 67 ++++++++++++++++ examples/Imp2Asm.v | 189 ++++++++++++++++----------------------------- 2 files changed, 133 insertions(+), 123 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index 84141372..abfb161b 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -1,6 +1,7 @@ From Coq Require Import Strings.String Program.Basics. +From ITree Require Import Basics_Functions. Require Import ZArith. Typeclasses eauto := 5. @@ -58,6 +59,72 @@ Section Syntax. code : bks (internal + A) (internal + B) }. + Arguments internal {A B}. + Arguments code {A B}. + + Definition raw_asm {A B} (b : A -> block B) : asm A B := + {| internal := Empty_set; + code := fun a' => + match a' with + | inl v => match v : Empty_set with end + | inr a => fmap_block inr (b a) + end; + |}. + + Definition raw_asm' {A} (b : block A) : asm unit A := + raw_asm (fun _ => b). + + Definition pure_asm {A B} (f : A -> B) : asm A B := + raw_asm (fun a => bbb (Bjmp (f a))). + + Definition id_asm {A} : asm A A := pure_asm id. + + (* Relabeling functions for [app_asm] *) + Definition relabelAB {I J B D} : + block (I + B) -> block ((I + J) + (B + D)) := + fmap_block (fun l => + match l with + | inl i => inl (inl i) + | inr b => inr (inl b) + end). + + Definition relabelCD {I J B D} : + block (J + D) -> block ((I + J) + (B + D)) := + fmap_block (fun l => + match l with + | inl j => inl (inr j) + | inr d => inr (inr d) + end). + + (* Append two asm programs, preserving their internal links. *) + Definition app_asm {A B C D} (ab : asm A B) (cd : asm C D) : + asm (A + C) (B + D) := + {| internal := ab.(internal) + cd.(internal); + code := fun l => + match l with + | inl (inl ia) => relabelAB (ab.(code) (inl ia)) + | inl (inr ic) => relabelCD (cd.(code) (inl ic)) + | inr (inl a) => relabelAB (ab.(code) (inr a)) + | inr (inr c) => relabelCD (cd.(code) (inr c)) + end; + |}. + + (* Rename visible program labels. *) + Definition relabel_asm {A B C D} (f : A -> B) (g : C -> D) + (bc : asm B C) : asm A D := + {| code := fun l => + fmap_block (sum_bimap id g) + (bc.(code) + (sum_bimap id f l)); + |}. + + (* Link labels from two programs together. *) + Definition link_asm {I A B} (ab : asm (I + A) (I + B)) : asm A B := + {| internal := ab.(internal) + I; + code := fun l => + fmap_block sum_assoc_l (ab.(code) (sum_assoc_r l)); + |}. + End Syntax. Arguments internal {A B}. diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index af655b48..e55bfad6 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -55,130 +55,73 @@ Section after. end. End after. -Section fmap_block. - Context {a b : Type} (f : a -> b). - - Definition fmap_branch (blk : branch a) : branch b := - match blk with - | Bjmp x => Bjmp (f x) - | Bbrz v a b => Bbrz v (f a) (f b) - | Bhalt => Bhalt - end. - - Fixpoint fmap_block (blk : block a) : block b := - match blk with - | bbb x => bbb (fmap_branch x) - | bbi i blk => bbi i (fmap_block blk) - end. -End fmap_block. - -Definition link_seq (p1: asm unit Empty_set) (p2: asm unit Empty_set): asm unit Empty_set := - let transL l := - match l with - | inl l => inl (inl l) - | inr _ => inl (inr None) - end - in - let transR l := - match l with - | inl l => inl (inr (Some l)) - | inr l => inr l - end - in - {| internal := p1.(internal) + option p2.(internal) - ; code l := - match l with - | inl (inl l) => (* p1's internal *) - fmap_block transL (p1.(code) (inl l)) - | inl (inr None) => (* p2's entry point *) - fmap_block transR (p2.(code) (inr tt)) - | inl (inr (Some l)) => (* p2's internal *) - fmap_block transR (p2.(code) (inl l)) - | inr tt => (* p1's entry point *) - fmap_block transL (p1.(code) (inr tt)) - end - |}. - -Definition link_if (e : list instr) (lp : asm unit Empty_set) (rp : asm unit Empty_set) : asm unit Empty_set := - let to_left l := - match l with - | inl l => inl (inl (Some l)) - | inr l => inr l - end - in - let to_right l := - match l with - | inl l => inl (inr (Some l)) - | inr l => inr l - end - in - - {| internal := option lp.(internal) + option rp.(internal) - ; code l := - match l with - | inr tt => (* Entry point to the conditional *) - after e (bbb (Bbrz (gen_tmp 0) (inl (inl None)) (inl (inr None)))) - | inl (inl None) => (* Entry point to the left branch *) - fmap_block to_left (lp.(code) (inr tt)) - | inl (inl (Some l)) => (* Inside the left branch *) - fmap_block to_left (lp.(code) (inl l)) - | inl (inr None) => (* Entry point to the right branch *) - fmap_block to_right (rp.(code) (inr tt)) - | inl (inr (Some l)) => (* Inside the right branch *) - fmap_block to_right (rp.(code) (inl l)) - end - |}. - - -Variant WhileBlocks : Set := -| WhileTop -| WhileBottom. - -Definition link_loop (e : list instr) (bp : asm unit Empty_set): asm unit Empty_set := - let to_body l := - match l with - | inl l => inl (inr l) - | inr l => inr l - end - in - - {| internal := WhileBlocks + bp.(internal) - ; code l := - match l with - | inr tt => (* Entry point to the loop *) - after e (bbb (Bbrz (gen_tmp 0) (inl (inl WhileTop)) (inl (inl WhileBottom)))) - | inl (inl WhileTop) => (* Entry point to the body *) - fmap_block to_body (bp.(code) (inr tt)) - | inl (inl WhileBottom) => (* Exit point *) - bbb Bhalt - | inl (inr l) => (* Inside the body *) - fmap_block to_body (bp.(code) (inl l)) - end - |}. - -Set Nested Proofs Allowed. - -Fixpoint compile (s : stmt) {struct s} : asm unit Empty_set := +(** Sequencing of blocks: the program [seq_asm ab bc] links the + exit points of [ab] with the entry points of [bc]. + +[[ + B + A---ab-----bc---C +]] + + ... can be implemented using just [app_asm] and [link_asm]. + +[[ + +------+ + | | + A------ab--+B + | + B+--bc------C +]] +*) +Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C): asm A C := + link_asm (relabel_asm sum_comm id (app_asm ab bc)). + +(* Location of temporary for [if]. *) +Definition tmp_if := gen_tmp 0. + +(* Conditional *) +Definition cond_asm (e : list instr) : asm unit (unit + unit) := + raw_asm' (after e (bbb (Bbrz tmp_if (inl tt) (inr tt)))). + +(** [if_asm e tp fp] +[[ + true + ee-------tp---C + 1---ee-------fp---C + false +]] + *) +Definition if_asm {A} + (e : list instr) (tp : asm unit A) (fp : asm unit A) : + asm unit A := + seq_asm (cond_asm e) + (relabel_asm id sum_merge (app_asm tp fp)). + +(* [while_asm e p] +[[ + +-------------+ + | | + | true | + | e-------p--+ + 1---+--e--------------1 + false +]] +*) +Definition while_asm (e : list instr) (p : asm unit unit) : + asm unit unit := + link_asm (relabel_asm id sum_merge + (app_asm (if_asm e + (relabel_asm id inl p) + (pure_asm inr)) + (pure_asm inl))). + +Fixpoint compile (s : stmt) {struct s} : asm unit unit := match s with - - | Skip => - - {| internal := Empty_set - ; code := fun _ => bbb Bhalt |} - - | Assign x e => - - {| internal := Empty_set - ; code := fun _ => after (compile_assign x e) - (bbb Bhalt) |} - - | Seq l r => link_seq (compile l) (compile r) - - - | If e l r => link_if (compile_expr 0 e) (compile l) (compile r) - - | While e b => link_loop (compile_expr 0 e) (compile b) - + | Skip => id_asm + | Assign x e => raw_asm' (after (compile_assign x e) (bbb (Bjmp tt))) + | Seq l r => seq_asm (compile l) (compile r) + | If e l r => if_asm (compile_expr 0 e) (compile l) (compile r) + | While e b => while_asm (compile_expr 0 e) (compile b) end. Section denote_list. From 25216fb623ab0416579b0e39a2c04516ce8fe992 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 24 Feb 2019 22:19:56 -0500 Subject: [PATCH 086/142] quick fix to the makefile (closes #67) --- examples/Makefile | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/examples/Makefile b/examples/Makefile index 66db55fe..90493969 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -1,6 +1,7 @@ .PHONY: example-imp example-lc example-io example-nimp example-asm example-threads examples: Makefile.coq + mkdir -p extracted $(MAKE) -f Makefile.coq Makefile.coq: _CoqProject @@ -30,6 +31,7 @@ example-threads: Makefile.coq $(THREADSML) ocamlbuild -I extracted runthread.native ./runthread.native -clean: +clean: _CoqProject + $(MAKE) -f Makefile.coq clean ocamlbuild -clean - $(RM) extracted/*.* + $(RM) -rf extracted From dd5226ff1b45fcca297018d8907804ad33818356 Mon Sep 17 00:00:00 2001 From: Yannick Date: Sun, 24 Feb 2019 23:01:00 -0500 Subject: [PATCH 087/142] Typechecking correctness theorem. --- examples/Imp2Asm.v | 598 +++++---------------------------------------- 1 file changed, 62 insertions(+), 536 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index e55bfad6..343efe25 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -595,6 +595,63 @@ Qed. eapply Renv_write_local; eauto. Qed. + Require Import Den. + + Lemma compile_correct: + forall s (g_imp g_asm : alist var value), + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) + (interp_locals (denote_asm (compile s) tt) g_asm) + (interp_locals (denoteStmt s;; Ret (inr Done)) g_imp). + Proof. + + (* Proof sketched on the old version of the theorem, mostly obsolete + induction s; intros. + { (* assign *) + simpl. + unfold denote_main. simpl. unfold denote_program. + simpl. + rewrite denote_after_denote_list. + rewrite bind_bind. + rewrite interp_locals_bind. + rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply compile_assign_correct; eauto. + simpl; intros. + clear - H0. + rewrite fmap_block_map. + unfold ITree.map. + rewrite bind_bind. + setoid_rewrite ret_bind. + rewrite <- (bind_ret (interp_locals _ (fst r2))). + rewrite interp_locals_bind. + eapply eutt_bind_gen. + { SearchAbout denote_block. + instantiate (1 := fun a b => Renv (fst a) (fst b) /\ snd a = snd b). + admit. } + { simpl. + intros. + destruct r0, r3; simpl in *. + destruct H; subst. + destruct o0; simpl. + { force_left. + eapply Ret_eutt. + simpl. tauto. } + { force_left. eapply Ret_eutt; simpl. tauto. } } } + { (* seq *) + simpl. + specialize (IHs1 _ (main (compile s2 b)) _ _ H). + rewrite bind_bind. + unfold denote_main; simpl. + unfold denote_main in IHs1. + rewrite fmap_block_map. + unfold ITree.map. rewrite bind_bind. + setoid_rewrite ret_bind. +*) + + Admitted. + + (* Seq a b a :: itree _ Empty_set @@ -607,31 +664,10 @@ a :: itree _ Empty_set *) -Definition denote_program {e} `{Locals -< e} `{Memory -< e} {L} - (p : program L) : p.(label) -> itree e (option L) := - rec (fun lbl : p.(label) => - next <- denote_block (_ +' e) (p.(blocks) lbl) ;; - match next with - | None => ret None - | Some (inl next) => lift (Call next) - | Some (inr next) => ret (Some next) - end). - Arguments denote_program {_ _ _}. - - Require Import ITree.MorphismsFacts. - Require Import ITree.FixFacts. - -Definition denote_main {e} `{Locals -< e} `{Memory -< e} {L} - (p : program L) : itree e (option L) := - next <- denote_block e p.(main) ;; - match next with - | None => ret None - | Some (inl next) => denote_program p next - | Some (inr next) => ret (Some next) - end. - -Arguments denote_block {_ _ _ _} _. -Arguments interp {_ _} _ {_} _. + (* + +OBSOLETE? + Lemma interp_match_option : forall {T U} (x : option T) {E F} (h : E ~> itree F) (Z : itree _ U) Y, interp h match x with | None => Z @@ -673,31 +709,9 @@ match x with | Some x => translate h (Y x) end. Proof. destruct x; reflexivity. Qed. - -(* -Proper (.. ==> eutt _) (rec _) - -let rec F := ... in -let rec G := ... in - -let rec F := let G := ... in ... in *) -(* -Lemma link_ok : forall p1 p2 l, - denote_program (link_seq p1 p2) l ≈ - rec (fun l => - match l with - | inl l => - l' <- denote_program p1 l ;; - match l' with - | None => Ret None - | Some _ => denote_main p2 - end - | inr None => denote_main p2 - | inr (Some l) => denote_program p2 l - end) l. -*) + (* things to do? * 1. change the compiler to not compress basic blocks. @@ -710,204 +724,6 @@ Lemma link_ok : forall p1 p2 l, * bonus: break & continue *) -About rec. - -Variant Fused {d1 d2 c1 c2 : Type} : Type -> Type := -| Entry : Fused c2 -| EnterL (_ : d1) : Fused c1 -| EnterR (_ : d2) : Fused c2. -Arguments Fused : clear implicits. - -Lemma rec_fuse : forall {E : Type -> Type} {dom1 codom1 dom2 codom2 : Type} - (f : dom1 -> itree (callE dom1 codom1 +' E) codom1) - (g : dom2 -> itree (callE dom2 codom2 +' E) codom2) - (x : dom1) (y : codom1 -> dom2), - (l <- rec f x ;; - rec g (y l)) - ≈ - @mrec (Fused dom1 dom2 codom1 codom2) E - (fun _ elr => - match elr with - | Entry => l <- lift (EnterL x) ;; lift (EnterR (y l)) - | EnterL x => - translate (fun Z x => - match x with - | inl1 x => - match x in callE _ _ z return (Fused _ _ _ _ +' _) z with - | Call x => inl1 (EnterL x) - end - | inr1 x => inr1 x - end) (f x) - | EnterR x => - translate (fun Z x => - match x with - | inl1 x => - match x in callE _ _ z return (Fused _ _ _ _ +' _) z with - | Call x => inl1 (EnterR x) - end - | inr1 x => inr1 x - end) (g x) - end) _ Entry. -Proof. -Admitted. - -Variant Incl {d1 c1 T : Type} : Type -> Type := -| EnterI : Incl T -| EnterF (_ : d1) : Incl c1. -Arguments Incl : clear implicits. - - -Lemma rec_fuse' : forall {E : Type -> Type} {dom1 codom1 T : Type} - (f : dom1 -> itree (callE dom1 codom1 +' E) codom1) - (k : codom1 -> itree E T) - (x : dom1), - (l <- rec f x ;; k l) - ≈ - @mrec (Incl dom1 codom1 T) E - (fun _ elr => - match elr with - | EnterI => l <- ITree.liftE (inl1 (EnterF x)) ;; - translate (fun _ x => inr1 x) (k l) - | EnterF x => - translate (fun Z x => - match x with - | inl1 x => - match x in callE _ _ z return (Incl _ _ _ +' _) z with - | Call x => inl1 (EnterF x) - end - | inr1 x => inr1 x - end) (f x) - end) _ EnterI. -Proof. -Admitted. - - (* 1. push translate over a match-option - * 2. pull a rec from a continuation above the bind - * 3. pull translate over a match-Incl - * 4. fuse two adjacent mrec - *) - -(* -Lemma rec_k : forall {E : Type -> Type} {dom1 codom1 T : Type} - (f : dom1 -> itree (callE dom1 codom1 +' E) codom1) - (c : itree E T) - (k : T -> dom1), - (l <- c ;; rec f (k l)) - ≈ - @mrec (Incl dom1 codom1 T) E - (fun _ elr => - match elr with - | EnterI => l <- translate (fun _ x => inr1 x) _ c ;; - ITree.liftE (inl1 (EnterF (k l))) - | EnterF x => - translate (fun Z x => - match x with - | inl1 x => - match x in callE _ _ z return (Incl _ _ _ +' _) z with - | Call x => inl1 (EnterF x) - end - | inr1 x => inr1 x - end) _ (f x) - end) _ EnterI. -Proof. -Admitted. -*) -About translate. -About mrec. - - -Lemma lem : forall {E : Type -> Type} {dom1 codom1 U : Type} - (f : dom1 -> itree (Incl dom1 codom1 U +' E) codom1) - (Z : itree (callE dom1 codom1 +' E) U) - (l : dom1) - , - @mrec (callE dom1 codom1) _ - (fun _ x => - match x with - | Call x => - interp (E:=Incl dom1 codom1 U +' E) (F:=callE dom1 codom1 +' E) - (fun _ z => - match z with - | inl1 x => - match x with - | EnterI => Z - | EnterF x => ITree.liftE (inl1 (Call x)) - end - | inr1 x => ITree.liftE (inr1 x) - end) (f x) - end) _ (Call l) - ≈ - @mrec (Incl dom1 codom1 U) _ - (fun _ x => - match x with - | EnterI => translate (fun _ x => - match x with - | inl1 x => - match x in callE _ _ X return (Incl dom1 codom1 U +' E) X with - | Call x => inl1 (EnterF x) - end - | inr1 x => inr1 x - end) Z - | EnterF x => f x - end) _ (EnterF l). -Abort. - -(* rec_fuse' : `l <- rec ... ;; k` = rec ... *) -(* rec_k : `l <- c ;; rec ...` = rec ... *) - -(* -rec_rec : @rec T (fun x => @rec U ...) = @rec (T + U) (fun ...) -*) - -Lemma lift_sum_rec : forall {A B C : Type} {E} - (L : A -> itree E C) - (R : B -> itree E C) - (l : A + B), - match l with - | inl x => L x - | inr x => R x - end = - rec (A:=A + B)%type - (fun x => - match x with - | inl x => translate (fun _ x => inr1 x) (L x) - | inr x => translate (fun _ x => inr1 x) (R x) - end) l. -Proof. Admitted. - -Variant With (T : Type) (E : Type -> Type) (t : Type) : Type := -| WithIt (_ : T) (_ : E t) : With T E t. -Arguments WithIt {_ _ _} _ _. - -Lemma lift_sum_rec_left - : forall {B T u : Type} {D : Type -> Type} {E} - (L : T -> D ~> itree (D +' E)) - (R : B -> itree E u) - (f : T -> D u) - (l : T + B), - match l with - | inl x => mrec (L x) _ (f x) - | inr x => R x - end = - mrec (D:=(With T D +' callE B u))%type - (fun _ x => - match x with - | inl1 (WithIt t y) => - translate (fun _ x => - match x with - | inl1 x => inl1 (inl1 (WithIt t x)) - | inr1 x => inr1 x - end) (L t _ y) - | inr1 x => - match x with - | Call x => translate (fun _ x => inr1 x) (R x) - end - end) _ match l with - | inl x => inl1 (WithIt x (f x)) - | inr x => inr1 (Call x) - end. -Proof. Admitted. - Lemma Proper_match : forall {T U V : Type} R (f f' : T -> V) (g g' : U -> V) x, ((pointwise_relation _ R) f f') -> ((pointwise_relation _ R) g g') -> @@ -922,300 +738,10 @@ Lemma Proper_match : forall {T U V : Type} R (f f' : T -> V) (g g' : U -> V) x, end. Proof. destruct x; compute; eauto. Qed. -Lemma link_seq_ok : forall p1 p2 l, - denote_program (link_seq p1 p2) l ≈ - match l with - | inl l => - l' <- denote_program p1 l ;; - match l' with - | None => Ret None - | Some _ => denote_main p2 - end - | inr None => denote_main p2 - | inr (Some l) => denote_program p2 l - end. -Proof. - intros. - unfold denote_program. - rewrite Proper_match. - 2:{ red; intros. - eapply rec_fuse'. } - 2:{ red. intros. - instantiate (1:=fun a => match a with - | Some l0 => - rec - (fun lbl : label p2 => - next <- denote_block (blocks p2 lbl);; - match next with - | Some (inl next0) => lift (Call next0) - | Some (inr next0) => ret (Some next0) - | None => ret None - end) l0 - | None => denote_main p2 - end). - reflexivity. } - simpl. - rewrite lift_sum_rec_left with (f:=fun _ => EnterI). - SearchAbout rec. - rewrite lift_sum_rec. - - - destruct l. - { setoid_rewrite rec_fuse'. - simpl. - setoid_rewrite translate_match_option. - - destruct l. - { (* in the left *) - unfold denote_program. - rewrite rec_unfold at 1. - repeat rewrite interp_bind. - match goal with - | |- ITree.bind ?X _ ≈ _ => - assert (X = (denote_block (blocks (link_seq p1 p2) (inl l)))) - end. - admit. - rewrite H. - rewrite rec_unfold. - repeat rewrite interp_bind. - repeat rewrite bind_bind. - match goal with - | |- _ ≈ ITree.bind ?X _ => - assert (X = (denote_block (blocks p1 l))) - end. - admit. - rewrite H0. - simpl. - rewrite fmap_block_map. - unfold ITree.map. - rewrite bind_bind. - setoid_rewrite ret_bind. - eapply eutt_bind_gen. - { instantiate (1:=eq). reflexivity. } - intros; subst. - repeat rewrite interp_match_option. - unfold option_map. - destruct r2. - { destruct s. - - admit. - - destruct u. admit. } - { admit. } } - { unfold denote_program. - simpl. - -} - - - - Lemma denote_block_no_calls : - interp (hBoth L id) (liftR id) = interp id e. - - Print denote_program. - Print denote_block. - simpl denote_block. - Eval simpl in (denote_block (blocks (link_seq p1 p2) (inl l))). - simpl. - - simpl. - unfold denote_block at 2. - simpl. -About denote_block. -setoid_rewrite interp_match_option. - - eapply eutt_bind_gen. - Show Existentials. - eapply eq_itree_interp. - - - - - - - - do 2 rewrite rec_unfold. - -Admitted. - - Lemma true_compile_correct_program: - forall s (g_imp g_asm : alist var value), - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) - (interp_locals (denote_main (compile s)) g_asm) - (interp_locals (denoteStmt s;; Ret (Some tt)) g_imp). - - - - - - - - - Lemma true_compile_correct_program: - forall s L (b: block L) (g_imp g_asm : alist var value), - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) - (interp_locals (denote_main (compile s b)) g_asm) - (interp_locals (denoteStmt s;; denote_block _ b) g_imp). - Proof. - induction s; intros. - { (* assign *) - simpl. - unfold denote_main. simpl. unfold denote_program. - simpl. - rewrite denote_after_denote_list. - rewrite bind_bind. - rewrite interp_locals_bind. - rewrite interp_locals_bind. - eapply eutt_bind_gen. - eapply compile_assign_correct; eauto. - simpl; intros. - clear - H0. - rewrite fmap_block_map. - unfold ITree.map. - rewrite bind_bind. - setoid_rewrite ret_bind. - rewrite <- (bind_ret (interp_locals _ (fst r2))). - rewrite interp_locals_bind. - eapply eutt_bind_gen. - { SearchAbout denote_block. - instantiate (1 := fun a b => Renv (fst a) (fst b) /\ snd a = snd b). - admit. } - { simpl. - intros. - destruct r0, r3; simpl in *. - destruct H; subst. - destruct o0; simpl. - { force_left. - eapply Ret_eutt. - simpl. tauto. } - { force_left. eapply Ret_eutt; simpl. tauto. } } } - { (* seq *) - simpl. - specialize (IHs1 _ (main (compile s2 b)) _ _ H). - rewrite bind_bind. - unfold denote_main; simpl. - unfold denote_main in IHs1. - rewrite fmap_block_map. - unfold ITree.map. rewrite bind_bind. - setoid_rewrite ret_bind. - - - - - - Arguments denote_program {_ _ _ _} _ _. - Arguments denote_block {_ _ _ _} _. - - - (* - This statement does not hold. We need to handle the environment. - We want something closer to this kind: - *) - - (* TODO: parameterize by REnv *) - Lemma compile_correct_program: - forall s L (b: block L) imports g_asm g_imp, - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b)) - (interp_locals (denote_main (compile s b) imports) g_asm) - (interp_locals (denoteStmt s;; - ml <- denote_block b;; - match ml with - | None => Ret tt - | Some l => imports l - end) g_imp). - Proof. -(* simpl. - induction s; intros L b imports. - - - unfold denote_main; simpl. - rewrite denote_after_denote_list; simpl. - rewrite bind_bind. - eapply eutt_bind. - + apply denote_compile_assign. - + intros ?; simpl. - rewrite fmap_block_map, map_bind; simpl. - eapply eutt_bind; [reflexivity|]. - intros [?|]; simpl; reflexivity. - - - simpl denoteStmt. - specialize (IHs2 L b imports). - unfold denote_main; simpl denote_block; rewrite fmap_block_map. - unfold bind at 1, Monad_itree; rewrite map_bind. - rewrite bind_bind. - etransitivity. - 2:{ - eapply eutt_bind; [reflexivity |]. - intros ?; apply IHs2. - } - clear IHs2. - unfold denote_main. - set (imports' := (fun l => match l with - | inr l => imports l - | inl l => denote_program (compile s2 b) imports l - end)). - specialize (IHs1 _ (main (compile s2 b)) imports'). - rewrite <- IHs1. - unfold denote_main. - apply eutt_bind; [reflexivity | ]. - intros [?|]; [| reflexivity]. - simpl option_map. - destruct s as [s | [s | s]]; [| | reflexivity]. - + clear. subst imports'. - simpl. - unfold denote_program. simpl. - + admit. - - - specialize (IHs1 L b imports). - specialize (IHs2 L b imports). - simpl denoteStmt. - rewrite bind_bind. - unfold denote_main. - simpl. - admit. - - - admit. - - - unfold denote_main; simpl. - rewrite ret_bind, fmap_block_map, map_bind. - eapply eutt_bind; [reflexivity |]. - intros [? |]; simpl; reflexivity. -*) -Admitted. - - (* note: because local temporaries also modify the environment, they have to be - * interpreted here. - *) - Theorem compile_correct: - forall s, @denote_main _ _ _ Empty_set (compile s (bbb Bhalt)) - (fun x => match x with end) ≈ denoteStmt s. - Proof. -(* intros stmt. - unfold denote_main. - transitivity (@denoteStmt (Locals +' Memory) _ stmt;; Ret tt). - { - eapply eutt_bind; [reflexivity | intros []]. - simpl. -*) - - Admitted. End Real_correctness. - (* -l: x = phi(l1: a, l2: b) ; ... -l1: ... ; jmp l -l2: ... ; jmp l - -l: [x] - .... -l1: ...; jmp[a] -l2: ...; jmp[b] -*) - -(* - Section tests. Import ImpNotations. From 483c5da3ea4c459ec10c8b9ce9e6946ca69e5e56 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 06:11:11 -0500 Subject: [PATCH 088/142] Split compiler and compiler correctness --- examples/Imp2Asm.v | 651 +-------------------------------- examples/Imp2AsmCorrectness.v | 667 ++++++++++++++++++++++++++++++++++ examples/_CoqProject | 1 + 3 files changed, 673 insertions(+), 646 deletions(-) create mode 100644 examples/Imp2AsmCorrectness.v diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 343efe25..3621aa81 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -48,10 +48,10 @@ End compile_assign. Section after. Context {a : Type}. - Fixpoint after (is : list instr) (blk : block a) : block a := + Fixpoint after (is : list instr) (bch : branch a) : block a := match is with - | nil => blk - | i :: is => bbi i (after is blk) + | nil => bbb bch + | i :: is => bbi i (after is bch) end. End after. @@ -81,7 +81,7 @@ Definition tmp_if := gen_tmp 0. (* Conditional *) Definition cond_asm (e : list instr) : asm unit (unit + unit) := - raw_asm' (after e (bbb (Bbrz tmp_if (inl tt) (inr tt)))). + raw_asm' (after e (Bbrz tmp_if (inl tt) (inr tt))). (** [if_asm e tp fp] [[ @@ -118,649 +118,8 @@ Definition while_asm (e : list instr) (p : asm unit unit) : Fixpoint compile (s : stmt) {struct s} : asm unit unit := match s with | Skip => id_asm - | Assign x e => raw_asm' (after (compile_assign x e) (bbb (Bjmp tt))) + | Assign x e => raw_asm' (after (compile_assign x e) (Bjmp tt)) | Seq l r => seq_asm (compile l) (compile r) | If e l r => if_asm (compile_expr 0 e) (compile l) (compile r) | While e b => while_asm (compile_expr 0 e) (compile b) end. - -Section denote_list. - - Import MonadNotation. - - Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := - fix traverse__ l: M unit := - match l with - | [] => ret tt - | a::l => (f a;; traverse__ l)%monad - end. - - Context {E} {EL : Locals -< E} {EM : Memory -< E}. - - Definition denote_list: list instr -> itree E unit := - traverse_ (denote_instr E). - - Lemma denote_after_denote_list: - forall {label: Type} instrs (b: block label), - denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_block E b). - Proof. - induction instrs as [| i instrs IH]; intros b. - - simpl; rewrite ret_bind; reflexivity. - - simpl; rewrite bind_bind. - eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. - Qed. - - Lemma denote_list_app: - forall is1 is2, - @denote_list (is1 ++ is2) ≅ - (@denote_list is1;; denote_list is2). - Proof. - intros is1 is2; induction is1 as [| i is1 IH]; simpl; intros; [rewrite ret_bind; reflexivity |]. - rewrite bind_bind; setoid_rewrite IH; reflexivity. - Qed. - -End denote_list. - -Section Correctness. - - (* - Potential extensions for later: - - Add some non-determinism at the source level, for instance order of evaluation in add, and have the compiler an order. - The correctness would then be a refinement. - How to define it? Likely with respect to an oracle. - - Add a print effect? - - Change languages to map two notions of state at the source down to a single one at the target? - Make the keys of the second env monad as the sum of the two initial ones. - *) - - - Import ITree.Core. - - Variable E: Type -> Type. - Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. - - Lemma fmap_block_map: - forall {L L'} b (f: L -> L'), - denote_block E (fmap_block f b) ≅ ITree.map (sum_bimap f id) (denote_block E b). - Proof. - induction b as [i b | br]; intros f. - - simpl. - unfold ITree.map; rewrite bind_bind. - eapply eq_itree_eq_bind; [reflexivity | intros []; apply IHb]. - - simpl. - destruct br; simpl. - + unfold ITree.map; rewrite ret_bind; reflexivity. - + unfold ITree.map; rewrite bind_bind. - eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. - + unfold ITree.map; rewrite ret_bind; reflexivity. - Qed. - - Variant Rvar : var -> var -> Prop := - | Rvar_var v : Rvar (varOf v) v. - - Arguments alist_find {_ _ _ _}. - - Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. - - Definition Renv (g_asm g_imp : alist var value) : Prop := - forall k_asm k_imp, Rvar k_asm k_imp -> - forall v, alist_In k_imp g_imp v <-> alist_In k_asm g_asm v. - - (* Let's not unfold this inside of the main proof *) - Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := - fun '(g_asm', _) '(g_imp',v) => - Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) - alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) - (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) - alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). - -End Correctness. - -Section EUTT. - - Require Import Paco.paco. - - Context {E: Type -> Type}. - - Instance eq_itree_run_env {E R} {K V map} {Mmap: Maps.Map K V map}: - Proper (@eutt (envE K V +' E) R R eq ==> eq ==> @eutt E (prod map R) (prod map R) eq) - (run_env R). - Proof. - Admitted. - -End EUTT. - -Section GEN_TMP. - - Lemma to_string_inj: forall (n m: nat), n <> m -> to_string n <> to_string m. - Admitted. - - Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. - Proof. - intros n m ineq; intros abs; apply ineq. - apply to_string_inj in ineq; inversion abs; easy. - Qed. - - Lemma varOf_inj: forall n m, m <> n -> varOf m <> varOf n. - Proof. - intros n m ineq abs; inv abs; easy. - Qed. - -End GEN_TMP. - -Opaque gen_tmp. -Opaque varOf. - -Section Real_correctness. - - Context {E': Type -> Type}. - Context {HasMemory: Memory -< E'}. - Definition E := Locals +' E'. - - Definition interp_locals {R: Type} (t: itree E R) (s: alist var value): itree E' (alist var value * R) := - run_env _ (interp1 evalLocals _ t) s. - - Instance eq_itree_interp_locals {R}: - Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) - interp_locals. - Proof. - Admitted. - - Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), - @eutt E' _ _ eq - (interp_locals (ITree.bind t k) s) - (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). - Admitted. - - Set Nested Proofs Allowed. - - Ltac force_left := - match goal with - | |- eutt _ ?x _ => rewrite (itree_eta x); cbn - end. - - Ltac force_right := - match goal with - | |- eutt _ _ ?x => rewrite (itree_eta x); cbn - end. - - Ltac untau_left := force_left; rewrite tau_eutt. - Ltac untau_right := force_right; rewrite tau_eutt. - - Arguments alist_add {_ _ _ _}. - Arguments alist_find {_ _ _ _}. - - Ltac flatten_goal := - match goal with - | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq - end. - - Ltac flatten_hyp h := - match type of h with - | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq - end. - - Ltac flatten_all := - match goal with - | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq - | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq - end. - - Ltac inv h := inversion h; subst; clear h. - Arguments alist_remove {_ _ _ _}. - - Lemma In_add_eq {K V: Type} {RR:RelDec eq} {RRC:@RelDec_Correct _ _ RR}: - forall k v (m: alist K V), - alist_In k (alist_add k v m) v. - Proof. - intros; unfold alist_add, alist_In; simpl; flatten_goal; [reflexivity | rewrite <- neg_rel_dec_correct in Heq; tauto]. - Qed. - - (* A removed key is not contained in the resulting map *) - Lemma not_In_remove: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v: V), - ~ alist_In k (alist_remove k m) v. - Proof. - induction m as [| [k1 v1] m IH]; intros. - - simpl; intros abs; inv abs. - - simpl; flatten_goal. - + unfold alist_In; simpl. - rewrite Bool.negb_true_iff in Heq; rewrite Heq. - intros abs; eapply IH; eassumption. - + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. - intros abs; eapply IH; eauto. - Qed. - - (* Removing a key does not alter other keys *) - Lemma In_In_remove_ineq: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v : V) (k' : K), - k <> k' -> - alist_In k m v -> - alist_In k (alist_remove k' m) v. - Proof. - induction m as [| [? ?] m IH]; intros ?k ?v ?k' ineq IN; [inversion IN |]. - simpl. - flatten_goal. - - unfold alist_In in *; simpl in *. - rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. - flatten_goal; auto. - - unfold alist_In in *; simpl in *. - rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. - flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto | eapply IH; eauto]. - Qed. - - Lemma In_remove_In_ineq: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v : V) (k' : K), - alist_In k (alist_remove k' m) v -> - alist_In k m v. - Proof. - induction m as [| [? ?] m IH]; intros ?k ?v ?k' IN; [inversion IN |]. - simpl in IN; flatten_hyp IN. - - unfold alist_In in *; simpl in *. - flatten_all; auto. - eapply IH; eauto. - -rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. - unfold alist_In; simpl. - flatten_goal; [rewrite rel_dec_correct in Heq; subst |]. - exfalso; eapply not_In_remove; eauto. - eapply IH; eauto. - Qed. - - Lemma In_remove_In_ineq_iff: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v : V) (k' : K), - k <> k' -> - alist_In k (alist_remove k' m) v <-> - alist_In k m v. - Proof. - intros; split; eauto using In_In_remove_ineq, In_remove_In_ineq. - Qed. - - (* Adding a value to a key does not alter other keys *) - Lemma In_In_add_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: - forall k v k' v' (m: alist K V), - k <> k' -> - alist_In k m v -> - alist_In k (alist_add k' v' m) v. - Proof. - intros. - unfold alist_In; simpl; flatten_goal; [rewrite rel_dec_correct in Heq; subst; tauto |]. - apply In_In_remove_ineq; auto. - Qed. - - Lemma In_add_In_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: - forall k v k' v' (m: alist K V), - k <> k' -> - alist_In k (alist_add k' v' m) v -> - alist_In k m v. - Proof. - intros k v k' v' m ineq IN. - unfold alist_In in IN; simpl in IN; flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto |]. - eapply In_remove_In_ineq; eauto. - Qed. - - Lemma In_add_ineq_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: - forall m (v v' : V) (k k' : K), - k <> k' -> - alist_In k m v <-> alist_In k (alist_add k' v' m) v. - Proof. - intros; split; eauto using In_In_add_ineq, In_add_In_ineq. - Qed. - - (* alist_find fails iff no value is associated to the key in the map *) - Lemma alist_find_None {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: - forall k (m: alist K V), - (forall v, ~ In (k,v) m) <-> alist_find k m = None. - Proof. - induction m as [| [k1 v1] m IH]; [simpl; easy |]. - simpl; split; intros H. - - flatten_goal; [rewrite rel_dec_correct in Heq; subst; exfalso | rewrite <- neg_rel_dec_correct in Heq]. - apply (H v1); left; reflexivity. - apply IH; intros v abs; apply (H v); right; assumption. - - intros v; flatten_hyp H; [inv H | rewrite <- IH in H]. - intros [EQ | abs]; [inv EQ; rewrite <- neg_rel_dec_correct in Heq; tauto | apply (H v); assumption]. - Qed. - - Lemma Renv_add: forall g_asm g_imp n v, - Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. - Proof. - repeat intro. - destruct (k_asm ?[ eq ] (gen_tmp n)) eqn:EQ. - rewrite rel_dec_correct in EQ; subst; inv H0. - rewrite <- neg_rel_dec_correct in EQ. - rewrite (H _ _ H0). - apply In_add_ineq_iff; auto. - Qed. - - Lemma Renv_find: - forall g_asm g_imp x, - Renv g_asm g_imp -> - alist_find x g_imp = alist_find (varOf x) g_asm. - Proof. - intros. - destruct (alist_find x g_imp) eqn:LUL, (alist_find (varOf x) g_asm) eqn:LUR; auto. - - eapply H in LUL; [| constructor]. - rewrite LUL in LUR; auto. - - eapply H in LUL; [| constructor]. - rewrite LUL in LUR; auto. - - erewrite <- (H (varOf x) x (Rvar_var x) v) in LUR. - rewrite LUR in LUL; inv LUL. - Qed. - - Lemma sim_rel_add: forall g_asm g_imp n v, - Renv g_asm g_imp -> - sim_rel g_asm n (alist_add (gen_tmp n) v g_asm, tt) (g_imp, v). - Proof. - intros. - split; [| split]. - - apply Renv_add; assumption. - - apply In_add_eq. - - intros m LT v'. - apply In_add_ineq_iff, gen_tmp_inj; lia. - Qed. - - Lemma sim_rel_Renv: forall g_asm n s1 v1 s2 v2, - sim_rel g_asm n (s1,v1) (s2,v2) -> Renv s1 s2. - Proof. - intros ? ? ? ? ? ? H; apply H. - Qed. - - Lemma sim_rel_find_tmp_n: - forall g_asm n g_asm' g_imp' v, - sim_rel g_asm n (g_asm', tt) (g_imp',v) -> - alist_In (gen_tmp n) g_asm' v. - Proof. - intros ? ? ? ? ? [_ [H _]]; exact H. - Qed. - - Lemma sim_rel_find_tmp_lt_n: - forall g_asm n m g_asm' g_imp' v, - m < n -> - sim_rel g_asm n (g_asm', tt) (g_imp',v) -> - alist_find (gen_tmp m) g_asm = alist_find (gen_tmp m) g_asm'. - Proof. - intros ? ? ? ? ? ? ineq [_ [_ H]]. - match goal with - | |- _ = ?x => destruct x eqn:EQ - end. - setoid_rewrite (H _ ineq); auto. - match goal with - | |- ?x = _ => destruct x eqn:EQ' - end; [| reflexivity]. - setoid_rewrite (H _ ineq) in EQ'. - rewrite EQ' in EQ; easy. - Qed. - - Notation "(% x )" := (gen_tmp x) (at level 1). - - Lemma compile_expr_correct : forall e g_imp g_asm n, - Renv g_asm g_imp -> - eutt (sim_rel g_asm n) - (interp_locals (denote_list (compile_expr n e)) g_asm) - (interp_locals (denoteExpr e) g_imp). - Proof. - induction e; simpl; intros. - - repeat untau_left. - repeat untau_right. - force_left; force_right. - apply eutt_Ret. - erewrite <- Renv_find; [| eassumption]. - apply sim_rel_add; assumption. - - repeat untau_left. - force_left. - force_right. - apply eutt_Ret. - apply sim_rel_add; assumption. - - do 2 setoid_rewrite denote_list_app. - do 2 setoid_rewrite interp_locals_bind. - eapply eutt_bind_gen. - + eapply IHe1; assumption. - + intros [g_asm' []] [g_imp' v] HSIM. - eapply eutt_bind_gen. - eapply IHe2. - eapply sim_rel_Renv; eassumption. - intros [g_asm'' []] [g_imp'' v'] HSIM'. - repeat untau_left. - force_left; force_right. - simpl fst in *. - apply eutt_Ret. - { - generalize HSIM; intros LU; apply sim_rel_find_tmp_n in LU. - unfold alist_In in LU; erewrite sim_rel_find_tmp_lt_n in LU; eauto; fold (alist_In (%n) g_asm'' v) in LU. - generalize HSIM'; intros LU'; apply sim_rel_find_tmp_n in LU'. - rewrite LU,LU'. - split; [| split]. - { - eapply Renv_add, sim_rel_Renv; eassumption. - } - { - apply In_add_eq. - } - { - intros m LT v''. - rewrite <- In_add_ineq_iff; [| apply gen_tmp_inj; lia]. - destruct HSIM as [_ [_ HSIM]]. - destruct HSIM' as [_ [_ HSIM']]. - rewrite HSIM; [| auto with arith]. - rewrite HSIM'; [| auto with arith]. - reflexivity. - } - } - Qed. - - Lemma Renv_write_local: - forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), - Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). - Proof. - intros k m m' v. - repeat intro. - red in H. - specialize (H k_asm k_imp H0 v0). - inv H0. - unfold alist_add, alist_In; simpl. - do 2 flatten_goal; - repeat match goal with - | h: _ = true |- _ => rewrite rel_dec_correct in h - | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h - end; try subst. - - tauto. - - tauto. - - apply varOf_inj in Heq; easy. - - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_string_Correct. -Qed. - - Lemma compile_assign_correct : forall e g_imp g_asm x, - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b)) - (interp_locals (denote_list (compile_assign x e)) g_asm) - (interp_locals (v <- denoteExpr e ;; lift (SetVar x v)) g_imp). - Proof. - simpl; intros. - unfold compile_assign. - rewrite denote_list_app. - do 2 rewrite interp_locals_bind. - eapply eutt_bind_gen. - eapply compile_expr_correct; eauto. - intros. - repeat untau_left. - force_left. - repeat untau_right; force_right. - eapply eutt_Ret; simpl. - destruct r1, r2. - erewrite sim_rel_find_tmp_n; eauto; simpl. - destruct H0. - eapply Renv_write_local; eauto. - Qed. - - Require Import Den. - - Lemma compile_correct: - forall s (g_imp g_asm : alist var value), - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) - (interp_locals (denote_asm (compile s) tt) g_asm) - (interp_locals (denoteStmt s;; Ret (inr Done)) g_imp). - Proof. - - (* Proof sketched on the old version of the theorem, mostly obsolete - induction s; intros. - { (* assign *) - simpl. - unfold denote_main. simpl. unfold denote_program. - simpl. - rewrite denote_after_denote_list. - rewrite bind_bind. - rewrite interp_locals_bind. - rewrite interp_locals_bind. - eapply eutt_bind_gen. - eapply compile_assign_correct; eauto. - simpl; intros. - clear - H0. - rewrite fmap_block_map. - unfold ITree.map. - rewrite bind_bind. - setoid_rewrite ret_bind. - rewrite <- (bind_ret (interp_locals _ (fst r2))). - rewrite interp_locals_bind. - eapply eutt_bind_gen. - { SearchAbout denote_block. - instantiate (1 := fun a b => Renv (fst a) (fst b) /\ snd a = snd b). - admit. } - { simpl. - intros. - destruct r0, r3; simpl in *. - destruct H; subst. - destruct o0; simpl. - { force_left. - eapply Ret_eutt. - simpl. tauto. } - { force_left. eapply Ret_eutt; simpl. tauto. } } } - { (* seq *) - simpl. - specialize (IHs1 _ (main (compile s2 b)) _ _ H). - rewrite bind_bind. - unfold denote_main; simpl. - unfold denote_main in IHs1. - rewrite fmap_block_map. - unfold ITree.map. rewrite bind_bind. - setoid_rewrite ret_bind. -*) - - Admitted. - - -(* -Seq a b -a :: itree _ Empty_set -[[Skip]] = Vis Halt ... -[[Seq Skip b]] = Vis Halt ... - - -[[s]] :: itree _ unit -[[a]] :: itree _ L (* if closed *) -*) - - - (* - -OBSOLETE? - -Lemma interp_match_option : forall {T U} (x : option T) {E F} (h : E ~> itree F) (Z : itree _ U) Y, - interp h match x with - | None => Z - | Some y => Y y - end = -match x with -| None => interp h Z -| Some y => interp h (Y y) -end. -Proof. destruct x; reflexivity. Qed. -Lemma interp_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> itree F) (Z : _ -> itree _ U) Y, - interp h match x with - | inl x => Z x - | inr x => Y x - end = -match x with -| inl x => interp h (Z x) -| inr x => interp h (Y x) -end. -Proof. destruct x; reflexivity. Qed. - -Lemma translate_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> F) (Z : _ -> itree _ U) Y, - translate h match x with - | inl x => Z x - | inr x => Y x - end = -match x with -| inl x => translate h (Z x) -| inr x => translate h (Y x) -end. -Proof. destruct x; reflexivity. Qed. -Lemma translate_match_option : forall {B U} (x : option B) {E F} (h : E ~> F) (Z : itree _ U) Y, - translate h _ match x with - | None => Z - | Some x => Y x - end = -match x with -| None => translate h Z -| Some x => translate h (Y x) -end. -Proof. destruct x; reflexivity. Qed. -*) - - - -(* things to do? - * 1. change the compiler to not compress basic blocks. - * - ideally we would write a separate pass that does that - * - split out each of the structures as separate definitions and lemmas - * 2. need to prove `interp F (denote_block ...) = denote_block ...` - * 3. link_seq_ok should be a proof by co-induction. - * 4. clean up this file *a lot* - * bonus: block fusion - * bonus: break & continue - *) - -Lemma Proper_match : forall {T U V : Type} R (f f' : T -> V) (g g' : U -> V) x, - ((pointwise_relation _ R) f f') -> - ((pointwise_relation _ R) g g') -> - R - match x with - | inl x => f x - | inr x => g x - end - match x with - | inl x => f' x - | inr x => g' x - end. -Proof. destruct x; compute; eauto. Qed. - - -End Real_correctness. - -(* -Section tests. - - Import ImpNotations. - - Definition ex1: stmt := - "x" ← 1. - - (* The result is a bit annoying to read in that it keeps around absurd branches *) - Compute (compile ex1). - - Definition ex_cond: stmt := - "x" ← 1;;; - IF "x" - THEN "res" ← 2 - ELSE "res" ← 3. - - Compute (compile ex_cond). - -End tests. - - -*) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v new file mode 100644 index 00000000..8984da3f --- /dev/null +++ b/examples/Imp2AsmCorrectness.v @@ -0,0 +1,667 @@ +Require Import Imp Asm Imp2Asm. + +Require Import Psatz. + +From Coq Require Import + Strings.String + Morphisms + Setoid + RelationClasses. + +From ITree Require Import + Basics_Functions + Effect.Env + ITree. + +From ExtLib Require Import + Core.RelDec + Structures.Monad + Structures.Maps + Programming.Show + Data.Map.FMapAList. + +Import ListNotations. +Open Scope string_scope. + +Section denote_list. + + Import MonadNotation. + + Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := + fix traverse__ l: M unit := + match l with + | [] => ret tt + | a::l => (f a;; traverse__ l)%monad + end. + + Context {E} {EL : Locals -< E} {EM : Memory -< E}. + + Definition denote_list: list instr -> itree E unit := + traverse_ (denote_instr E). + + Lemma denote_after_denote_list: + forall {label: Type} instrs (b: branch label), + denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_branch E b). + Proof. + induction instrs as [| i instrs IH]; intros b. + - simpl; rewrite ret_bind; reflexivity. + - simpl; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. + Qed. + + Lemma denote_list_app: + forall is1 is2, + @denote_list (is1 ++ is2) ≅ + (@denote_list is1;; denote_list is2). + Proof. + intros is1 is2; induction is1 as [| i is1 IH]; simpl; intros; [rewrite ret_bind; reflexivity |]. + rewrite bind_bind; setoid_rewrite IH; reflexivity. + Qed. + +End denote_list. + +Section Correctness. + + (* + Potential extensions for later: + - Add some non-determinism at the source level, for instance order of evaluation in add, and have the compiler an order. + The correctness would then be a refinement. + How to define it? Likely with respect to an oracle. + - Add a print effect? + - Change languages to map two notions of state at the source down to a single one at the target? + Make the keys of the second env monad as the sum of the two initial ones. + *) + + + Import ITree.Core. + + Variable E: Type -> Type. + Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. + + Lemma fmap_block_map: + forall {L L'} b (f: L -> L'), + denote_block E (fmap_block f b) ≅ ITree.map (sum_bimap f id) (denote_block E b). + Proof. + induction b as [i b | br]; intros f. + - simpl. + unfold ITree.map; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IHb]. + - simpl. + destruct br; simpl. + + unfold ITree.map; rewrite ret_bind; reflexivity. + + unfold ITree.map; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + + unfold ITree.map; rewrite ret_bind; reflexivity. + Qed. + + Variant Rvar : var -> var -> Prop := + | Rvar_var v : Rvar (varOf v) v. + + Arguments alist_find {_ _ _ _}. + + Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. + + Definition Renv (g_asm g_imp : alist var value) : Prop := + forall k_asm k_imp, Rvar k_asm k_imp -> + forall v, alist_In k_imp g_imp v <-> alist_In k_asm g_asm v. + + (* Let's not unfold this inside of the main proof *) + Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := + fun '(g_asm', _) '(g_imp',v) => + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). + +End Correctness. + +Section EUTT. + + Require Import Paco.paco. + + Context {E: Type -> Type}. + + Instance eq_itree_run_env {E R} {K V map} {Mmap: Maps.Map K V map}: + Proper (@eutt (envE K V +' E) R R eq ==> eq ==> @eutt E (prod map R) (prod map R) eq) + (run_env R). + Proof. + Admitted. + +End EUTT. + +Section GEN_TMP. + + Lemma to_string_inj: forall (n m: nat), n <> m -> to_string n <> to_string m. + Admitted. + + Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. + Proof. + intros n m ineq; intros abs; apply ineq. + apply to_string_inj in ineq; inversion abs; easy. + Qed. + + Lemma varOf_inj: forall n m, m <> n -> varOf m <> varOf n. + Proof. + intros n m ineq abs; inv abs; easy. + Qed. + +End GEN_TMP. + +Opaque gen_tmp. +Opaque varOf. + +Section Real_correctness. + + Context {E': Type -> Type}. + Context {HasMemory: Memory -< E'}. + Definition E := Locals +' E'. + + Definition interp_locals {R: Type} (t: itree E R) (s: alist var value): itree E' (alist var value * R) := + run_env _ (interp1 evalLocals _ t) s. + + Instance eq_itree_interp_locals {R}: + Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) + interp_locals. + Proof. + Admitted. + + Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), + @eutt E' _ _ eq + (interp_locals (ITree.bind t k) s) + (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). + Admitted. + + Set Nested Proofs Allowed. + + Ltac force_left := + match goal with + | |- eutt _ ?x _ => rewrite (itree_eta x); cbn + end. + + Ltac force_right := + match goal with + | |- eutt _ _ ?x => rewrite (itree_eta x); cbn + end. + + Ltac untau_left := force_left; rewrite tau_eutt. + Ltac untau_right := force_right; rewrite tau_eutt. + + Arguments alist_add {_ _ _ _}. + Arguments alist_find {_ _ _ _}. + + Ltac flatten_goal := + match goal with + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + + Ltac flatten_hyp h := + match type of h with + | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + + Ltac flatten_all := + match goal with + | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. + + Ltac inv h := inversion h; subst; clear h. + Arguments alist_remove {_ _ _ _}. + + Lemma In_add_eq {K V: Type} {RR:RelDec eq} {RRC:@RelDec_Correct _ _ RR}: + forall k v (m: alist K V), + alist_In k (alist_add k v m) v. + Proof. + intros; unfold alist_add, alist_In; simpl; flatten_goal; [reflexivity | rewrite <- neg_rel_dec_correct in Heq; tauto]. + Qed. + + (* A removed key is not contained in the resulting map *) + Lemma not_In_remove: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v: V), + ~ alist_In k (alist_remove k m) v. + Proof. + induction m as [| [k1 v1] m IH]; intros. + - simpl; intros abs; inv abs. + - simpl; flatten_goal. + + unfold alist_In; simpl. + rewrite Bool.negb_true_iff in Heq; rewrite Heq. + intros abs; eapply IH; eassumption. + + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + intros abs; eapply IH; eauto. + Qed. + + (* Removing a key does not alter other keys *) + Lemma In_In_remove_ineq: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v : V) (k' : K), + k <> k' -> + alist_In k m v -> + alist_In k (alist_remove k' m) v. + Proof. + induction m as [| [? ?] m IH]; intros ?k ?v ?k' ineq IN; [inversion IN |]. + simpl. + flatten_goal. + - unfold alist_In in *; simpl in *. + rewrite Bool.negb_true_iff, <- neg_rel_dec_correct in Heq. + flatten_goal; auto. + - unfold alist_In in *; simpl in *. + rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto | eapply IH; eauto]. + Qed. + + Lemma In_remove_In_ineq: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v : V) (k' : K), + alist_In k (alist_remove k' m) v -> + alist_In k m v. + Proof. + induction m as [| [? ?] m IH]; intros ?k ?v ?k' IN; [inversion IN |]. + simpl in IN; flatten_hyp IN. + - unfold alist_In in *; simpl in *. + flatten_all; auto. + eapply IH; eauto. + -rewrite Bool.negb_false_iff, rel_dec_correct in Heq; subst. + unfold alist_In; simpl. + flatten_goal; [rewrite rel_dec_correct in Heq; subst |]. + exfalso; eapply not_In_remove; eauto. + eapply IH; eauto. + Qed. + + Lemma In_remove_In_ineq_iff: + forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} + (m : alist K V) (k : K) (v : V) (k' : K), + k <> k' -> + alist_In k (alist_remove k' m) v <-> + alist_In k m v. + Proof. + intros; split; eauto using In_In_remove_ineq, In_remove_In_ineq. + Qed. + + (* Adding a value to a key does not alter other keys *) + Lemma In_In_add_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: + forall k v k' v' (m: alist K V), + k <> k' -> + alist_In k m v -> + alist_In k (alist_add k' v' m) v. + Proof. + intros. + unfold alist_In; simpl; flatten_goal; [rewrite rel_dec_correct in Heq; subst; tauto |]. + apply In_In_remove_ineq; auto. + Qed. + + Lemma In_add_In_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: + forall k v k' v' (m: alist K V), + k <> k' -> + alist_In k (alist_add k' v' m) v -> + alist_In k m v. + Proof. + intros k v k' v' m ineq IN. + unfold alist_In in IN; simpl in IN; flatten_hyp IN; [rewrite rel_dec_correct in Heq; subst; tauto |]. + eapply In_remove_In_ineq; eauto. + Qed. + + Lemma In_add_ineq_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + forall m (v v' : V) (k k' : K), + k <> k' -> + alist_In k m v <-> alist_In k (alist_add k' v' m) v. + Proof. + intros; split; eauto using In_In_add_ineq, In_add_In_ineq. + Qed. + + (* alist_find fails iff no value is associated to the key in the map *) + Lemma alist_find_None {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + forall k (m: alist K V), + (forall v, ~ In (k,v) m) <-> alist_find k m = None. + Proof. + induction m as [| [k1 v1] m IH]; [simpl; easy |]. + simpl; split; intros H. + - flatten_goal; [rewrite rel_dec_correct in Heq; subst; exfalso | rewrite <- neg_rel_dec_correct in Heq]. + apply (H v1); left; reflexivity. + apply IH; intros v abs; apply (H v); right; assumption. + - intros v; flatten_hyp H; [inv H | rewrite <- IH in H]. + intros [EQ | abs]; [inv EQ; rewrite <- neg_rel_dec_correct in Heq; tauto | apply (H v); assumption]. + Qed. + + Lemma Renv_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. + Proof. + repeat intro. + destruct (k_asm ?[ eq ] (gen_tmp n)) eqn:EQ. + rewrite rel_dec_correct in EQ; subst; inv H0. + rewrite <- neg_rel_dec_correct in EQ. + rewrite (H _ _ H0). + apply In_add_ineq_iff; auto. + Qed. + + Lemma Renv_find: + forall g_asm g_imp x, + Renv g_asm g_imp -> + alist_find x g_imp = alist_find (varOf x) g_asm. + Proof. + intros. + destruct (alist_find x g_imp) eqn:LUL, (alist_find (varOf x) g_asm) eqn:LUR; auto. + - eapply H in LUL; [| constructor]. + rewrite LUL in LUR; auto. + - eapply H in LUL; [| constructor]. + rewrite LUL in LUR; auto. + - erewrite <- (H (varOf x) x (Rvar_var x) v) in LUR. + rewrite LUR in LUL; inv LUL. + Qed. + + Lemma sim_rel_add: forall g_asm g_imp n v, + Renv g_asm g_imp -> + sim_rel g_asm n (alist_add (gen_tmp n) v g_asm, tt) (g_imp, v). + Proof. + intros. + split; [| split]. + - apply Renv_add; assumption. + - apply In_add_eq. + - intros m LT v'. + apply In_add_ineq_iff, gen_tmp_inj; lia. + Qed. + + Lemma sim_rel_Renv: forall g_asm n s1 v1 s2 v2, + sim_rel g_asm n (s1,v1) (s2,v2) -> Renv s1 s2. + Proof. + intros ? ? ? ? ? ? H; apply H. + Qed. + + Lemma sim_rel_find_tmp_n: + forall g_asm n g_asm' g_imp' v, + sim_rel g_asm n (g_asm', tt) (g_imp',v) -> + alist_In (gen_tmp n) g_asm' v. + Proof. + intros ? ? ? ? ? [_ [H _]]; exact H. + Qed. + + Lemma sim_rel_find_tmp_lt_n: + forall g_asm n m g_asm' g_imp' v, + m < n -> + sim_rel g_asm n (g_asm', tt) (g_imp',v) -> + alist_find (gen_tmp m) g_asm = alist_find (gen_tmp m) g_asm'. + Proof. + intros ? ? ? ? ? ? ineq [_ [_ H]]. + match goal with + | |- _ = ?x => destruct x eqn:EQ + end. + setoid_rewrite (H _ ineq); auto. + match goal with + | |- ?x = _ => destruct x eqn:EQ' + end; [| reflexivity]. + setoid_rewrite (H _ ineq) in EQ'. + rewrite EQ' in EQ; easy. + Qed. + + Notation "(% x )" := (gen_tmp x) (at level 1). + + Lemma compile_expr_correct : forall e g_imp g_asm n, + Renv g_asm g_imp -> + eutt (sim_rel g_asm n) + (interp_locals (denote_list (compile_expr n e)) g_asm) + (interp_locals (denoteExpr e) g_imp). + Proof. + induction e; simpl; intros. + - repeat untau_left. + repeat untau_right. + force_left; force_right. + apply eutt_Ret. + erewrite <- Renv_find; [| eassumption]. + apply sim_rel_add; assumption. + - repeat untau_left. + force_left. + force_right. + apply eutt_Ret. + apply sim_rel_add; assumption. + - do 2 setoid_rewrite denote_list_app. + do 2 setoid_rewrite interp_locals_bind. + eapply eutt_bind_gen. + + eapply IHe1; assumption. + + intros [g_asm' []] [g_imp' v] HSIM. + eapply eutt_bind_gen. + eapply IHe2. + eapply sim_rel_Renv; eassumption. + intros [g_asm'' []] [g_imp'' v'] HSIM'. + repeat untau_left. + force_left; force_right. + simpl fst in *. + apply eutt_Ret. + { + generalize HSIM; intros LU; apply sim_rel_find_tmp_n in LU. + unfold alist_In in LU; erewrite sim_rel_find_tmp_lt_n in LU; eauto; fold (alist_In (%n) g_asm'' v) in LU. + generalize HSIM'; intros LU'; apply sim_rel_find_tmp_n in LU'. + rewrite LU,LU'. + split; [| split]. + { + eapply Renv_add, sim_rel_Renv; eassumption. + } + { + apply In_add_eq. + } + { + intros m LT v''. + rewrite <- In_add_ineq_iff; [| apply gen_tmp_inj; lia]. + destruct HSIM as [_ [_ HSIM]]. + destruct HSIM' as [_ [_ HSIM']]. + rewrite HSIM; [| auto with arith]. + rewrite HSIM'; [| auto with arith]. + reflexivity. + } + } + Qed. + + Lemma Renv_write_local: + forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), + Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). + Proof. + intros k m m' v. + repeat intro. + red in H. + specialize (H k_asm k_imp H0 v0). + inv H0. + unfold alist_add, alist_In; simpl. + do 2 flatten_goal; + repeat match goal with + | h: _ = true |- _ => rewrite rel_dec_correct in h + | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h + end; try subst. + - tauto. + - tauto. + - apply varOf_inj in Heq; easy. + - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_string_Correct. +Qed. + +(** Correctness of compilation *) + + Lemma compile_assign_correct : forall e g_imp g_asm x, + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b)) + (interp_locals (denote_list (compile_assign x e)) g_asm) + (interp_locals (v <- denoteExpr e ;; lift (SetVar x v)) g_imp). + Proof. + simpl; intros. + unfold compile_assign. + rewrite denote_list_app. + do 2 rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply compile_expr_correct; eauto. + intros. + repeat untau_left. + force_left. + repeat untau_right; force_right. + eapply eutt_Ret; simpl. + destruct r1, r2. + erewrite sim_rel_find_tmp_n; eauto; simpl. + destruct H0. + eapply Renv_write_local; eauto. + Qed. + + Require Import Den. + + Lemma compile_correct: + forall s (g_imp g_asm : alist var value), + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) + (interp_locals (denote_asm (compile s) tt) g_asm) + (interp_locals (denoteStmt s ;; Ret (inl tt)) g_imp). + Proof. + + (* Proof sketched on the old version of the theorem, mostly obsolete + induction s; intros. + { (* assign *) + simpl. + unfold denote_main. simpl. unfold denote_program. + simpl. + rewrite denote_after_denote_list. + rewrite bind_bind. + rewrite interp_locals_bind. + rewrite interp_locals_bind. + eapply eutt_bind_gen. + eapply compile_assign_correct; eauto. + simpl; intros. + clear - H0. + rewrite fmap_block_map. + unfold ITree.map. + rewrite bind_bind. + setoid_rewrite ret_bind. + rewrite <- (bind_ret (interp_locals _ (fst r2))). + rewrite interp_locals_bind. + eapply eutt_bind_gen. + { SearchAbout denote_block. + instantiate (1 := fun a b => Renv (fst a) (fst b) /\ snd a = snd b). + admit. } + { simpl. + intros. + destruct r0, r3; simpl in *. + destruct H; subst. + destruct o0; simpl. + { force_left. + eapply Ret_eutt. + simpl. tauto. } + { force_left. eapply Ret_eutt; simpl. tauto. } } } + { (* seq *) + simpl. + specialize (IHs1 _ (main (compile s2 b)) _ _ H). + rewrite bind_bind. + unfold denote_main; simpl. + unfold denote_main in IHs1. + rewrite fmap_block_map. + unfold ITree.map. rewrite bind_bind. + setoid_rewrite ret_bind. +*) + + Admitted. + + +(* +Seq a b +a :: itree _ Empty_set +[[Skip]] = Vis Halt ... +[[Seq Skip b]] = Vis Halt ... + + +[[s]] :: itree _ unit +[[a]] :: itree _ L (* if closed *) +*) + + + (* + +OBSOLETE? + +Lemma interp_match_option : forall {T U} (x : option T) {E F} (h : E ~> itree F) (Z : itree _ U) Y, + interp h match x with + | None => Z + | Some y => Y y + end = +match x with +| None => interp h Z +| Some y => interp h (Y y) +end. +Proof. destruct x; reflexivity. Qed. +Lemma interp_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> itree F) (Z : _ -> itree _ U) Y, + interp h match x with + | inl x => Z x + | inr x => Y x + end = +match x with +| inl x => interp h (Z x) +| inr x => interp h (Y x) +end. +Proof. destruct x; reflexivity. Qed. + +Lemma translate_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> F) (Z : _ -> itree _ U) Y, + translate h match x with + | inl x => Z x + | inr x => Y x + end = +match x with +| inl x => translate h (Z x) +| inr x => translate h (Y x) +end. +Proof. destruct x; reflexivity. Qed. +Lemma translate_match_option : forall {B U} (x : option B) {E F} (h : E ~> F) (Z : itree _ U) Y, + translate h _ match x with + | None => Z + | Some x => Y x + end = +match x with +| None => translate h Z +| Some x => translate h (Y x) +end. +Proof. destruct x; reflexivity. Qed. +*) + + + +(* things to do? + * 1. change the compiler to not compress basic blocks. + * - ideally we would write a separate pass that does that + * - split out each of the structures as separate definitions and lemmas + * 2. need to prove `interp F (denote_block ...) = denote_block ...` + * 3. link_seq_ok should be a proof by co-induction. + * 4. clean up this file *a lot* + * bonus: block fusion + * bonus: break & continue + *) + +Lemma Proper_match : forall {T U V : Type} R (f f' : T -> V) (g g' : U -> V) x, + ((pointwise_relation _ R) f f') -> + ((pointwise_relation _ R) g g') -> + R + match x with + | inl x => f x + | inr x => g x + end + match x with + | inl x => f' x + | inr x => g' x + end. +Proof. destruct x; compute; eauto. Qed. + + +End Real_correctness. + +(* +Section tests. + + Import ImpNotations. + + Definition ex1: stmt := + "x" ← 1. + + (* The result is a bit annoying to read in that it keeps around absurd branches *) + Compute (compile ex1). + + Definition ex_cond: stmt := + "x" ← 1;;; + IF "x" + THEN "res" ← 2 + ELSE "res" ← 3. + + Compute (compile ex_cond). + +End tests. + + +*) diff --git a/examples/_CoqProject b/examples/_CoqProject index 768db7c6..d47670fb 100644 --- a/examples/_CoqProject +++ b/examples/_CoqProject @@ -10,6 +10,7 @@ Den.v Imp.v Linking.v Imp2Asm.v +Imp2AsmCorrectness.v Nimp.v stlc.v From a54c6edbf3f2e311257e14cca0d762f79440141f Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 06:34:55 -0500 Subject: [PATCH 089/142] Sketch correctness proof for individual Imp constructs --- examples/Imp2AsmCorrectness.v | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 8984da3f..676ab44f 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -497,7 +497,40 @@ Qed. Qed. Require Import Den. - + + Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) : + eq_den (denote_asm (seq_asm ab bc)) + (denote_asm ab >=> denote_asm bc). + Proof. + Admitted. + +(* (incomplete) eutt modulo interp_locals and Renv on states *) +Axiom eq_den' : forall {A}, itree E A -> itree E A -> Prop. + + Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : + eq_den' (denote_asm (if_asm e tp fp) tt) + (denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then denote_asm tp tt else denote_asm fp tt). + Proof. + Admitted. + + Lemma while_asm_correct (e : list instr) (p : asm unit unit) : + eq_den' (denote_asm (while_asm e p) tt) + (loop_den (fun l => + match l with + | inl tt => + denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then + denote_asm p tt;; Ret (inl (inl tt)) + else + Ret (inl (inr tt)) + | inr tt => Ret (inl (inl tt)) + end) tt). + Proof. + Admitted. + Lemma compile_correct: forall s (g_imp g_asm : alist var value), Renv g_asm g_imp -> From bb9b940fb60db33b08b588d2ef48f8db23faa699 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 07:15:28 -0500 Subject: [PATCH 090/142] Add doc on asm syntax --- examples/Asm.v | 74 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 44 insertions(+), 30 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index abfb161b..b52089c7 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -10,7 +10,7 @@ Section Syntax. Definition var : Set := string. Definition value : Set := nat. (* this should change *) - (* start with the syntax *) + (** ** Syntax *) Variant operand : Set := | Oimm (_ : value) @@ -29,11 +29,30 @@ Section Syntax. . Global Arguments branch _ : clear implicits. + (** A block is a sequence of straightline instructions followed + by a branch. *) Inductive block {label : Type} : Type := | bbi (_ : instr) (_ : block) | bbb (_ : branch label). Global Arguments block _ : clear implicits. + (** Collection of blocks labeled by [A], with branches in [B]. *) + Definition bks A B := A -> block B. + + (** Blocks with visible unlinked labels [A] and [B] and internal + linked labels, allowing blocks to explicitly jump to each other. + - [A]: entry points + - [B]: exit points + - [internal]: linked and hidden labels + *) + Record asm A B : Type := + { + internal : Type; + code : bks (internal + A) (internal + B) + }. + + (** ** Combinators *) + Definition fmap_branch {A B : Type} (f: A -> B): branch A -> branch B := fun b => match b with @@ -49,20 +68,16 @@ Section Syntax. | bbi i b => bbi i (fmap b) end. - (* Collection of blocks labeled by [A], with jumps in [B]. *) - Definition bks A B := A -> block B. - - (* ASM: linked blocks, can jump to themselves *) - Record asm A B : Type := - { - internal : Type; - code : bks (internal + A) (internal + B) - }. + Definition relabel_bks {A B C D : Type} (f : A -> B) (g : C -> D) + (b : bks B C) : bks A D := + fun a => fmap_block g (b (f a)). - Arguments internal {A B}. - Arguments code {A B}. + Global Arguments internal {A B}. + Global Arguments code {A B}. - Definition raw_asm {A B} (b : A -> block B) : asm A B := + (** Any collection of blocks forms an [asm] program with + no hidden blocks. *) + Definition raw_asm {A B} (b : bks A B) : asm A B := {| internal := Empty_set; code := fun a' => match a' with @@ -71,16 +86,19 @@ Section Syntax. end; |}. - Definition raw_asm' {A} (b : block A) : asm unit A := + (** Wrap a single block as [asm]. *) + Definition raw_asm_block {A} (b : block A) : asm unit A := raw_asm (fun _ => b). + (** An [asm] program made only of external jumps. This is + useful to connect programs with [app_asm]. *) Definition pure_asm {A B} (f : A -> B) : asm A B := raw_asm (fun a => bbb (Bjmp (f a))). Definition id_asm {A} : asm A A := pure_asm id. - (* Relabeling functions for [app_asm] *) - Definition relabelAB {I J B D} : + (* Internal relabeling functions for [app_asm] *) + Definition _app_B {I J B D} : block (I + B) -> block ((I + J) + (B + D)) := fmap_block (fun l => match l with @@ -88,7 +106,7 @@ Section Syntax. | inr b => inr (inl b) end). - Definition relabelCD {I J B D} : + Definition _app_D {I J B D} : block (J + D) -> block ((I + J) + (B + D)) := fmap_block (fun l => match l with @@ -96,33 +114,29 @@ Section Syntax. | inr d => inr (inr d) end). - (* Append two asm programs, preserving their internal links. *) + (** Append two asm programs, preserving their internal links. *) Definition app_asm {A B C D} (ab : asm A B) (cd : asm C D) : asm (A + C) (B + D) := {| internal := ab.(internal) + cd.(internal); code := fun l => match l with - | inl (inl ia) => relabelAB (ab.(code) (inl ia)) - | inl (inr ic) => relabelCD (cd.(code) (inl ic)) - | inr (inl a) => relabelAB (ab.(code) (inr a)) - | inr (inr c) => relabelCD (cd.(code) (inr c)) + | inl (inl ia) => _app_B (ab.(code) (inl ia)) + | inl (inr ic) => _app_D (cd.(code) (inl ic)) + | inr (inl a) => _app_B (ab.(code) (inr a)) + | inr (inr c) => _app_D (cd.(code) (inr c)) end; |}. - (* Rename visible program labels. *) + (** Rename visible program labels. *) Definition relabel_asm {A B C D} (f : A -> B) (g : C -> D) (bc : asm B C) : asm A D := - {| code := fun l => - fmap_block (sum_bimap id g) - (bc.(code) - (sum_bimap id f l)); + {| code := relabel_bks (sum_bimap id f) (sum_bimap id g) bc.(code); |}. - (* Link labels from two programs together. *) + (** Link labels from two programs together. *) Definition link_asm {I A B} (ab : asm (I + A) (I + B)) : asm A B := {| internal := ab.(internal) + I; - code := fun l => - fmap_block sum_assoc_l (ab.(code) (sum_assoc_r l)); + code := relabel_bks sum_assoc_r sum_assoc_l ab.(code); |}. End Syntax. From 4af2ff334193679a65462290b8b4a72a9902a44f Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 09:37:56 -0500 Subject: [PATCH 091/142] Factor out AsmCombinators --- examples/Asm.v | 85 -------------- examples/AsmCombinators.v | 211 ++++++++++++++++++++++++++++++++++ examples/Imp2Asm.v | 15 +-- examples/Imp2AsmCorrectness.v | 79 +++---------- examples/_CoqProject | 3 +- 5 files changed, 233 insertions(+), 160 deletions(-) create mode 100644 examples/AsmCombinators.v diff --git a/examples/Asm.v b/examples/Asm.v index b52089c7..a21bf1f4 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -51,94 +51,9 @@ Section Syntax. code : bks (internal + A) (internal + B) }. - (** ** Combinators *) - - Definition fmap_branch {A B : Type} (f: A -> B): branch A -> branch B := - fun b => - match b with - | Bjmp a => Bjmp (f a) - | Bbrz c a a' => Bbrz c (f a) (f a') - | Bhalt => Bhalt - end. - - Definition fmap_block {A B: Type} (f: A -> B): block A -> block B := - fix fmap b := - match b with - | bbb a => bbb (fmap_branch f a) - | bbi i b => bbi i (fmap b) - end. - - Definition relabel_bks {A B C D : Type} (f : A -> B) (g : C -> D) - (b : bks B C) : bks A D := - fun a => fmap_block g (b (f a)). - Global Arguments internal {A B}. Global Arguments code {A B}. - (** Any collection of blocks forms an [asm] program with - no hidden blocks. *) - Definition raw_asm {A B} (b : bks A B) : asm A B := - {| internal := Empty_set; - code := fun a' => - match a' with - | inl v => match v : Empty_set with end - | inr a => fmap_block inr (b a) - end; - |}. - - (** Wrap a single block as [asm]. *) - Definition raw_asm_block {A} (b : block A) : asm unit A := - raw_asm (fun _ => b). - - (** An [asm] program made only of external jumps. This is - useful to connect programs with [app_asm]. *) - Definition pure_asm {A B} (f : A -> B) : asm A B := - raw_asm (fun a => bbb (Bjmp (f a))). - - Definition id_asm {A} : asm A A := pure_asm id. - - (* Internal relabeling functions for [app_asm] *) - Definition _app_B {I J B D} : - block (I + B) -> block ((I + J) + (B + D)) := - fmap_block (fun l => - match l with - | inl i => inl (inl i) - | inr b => inr (inl b) - end). - - Definition _app_D {I J B D} : - block (J + D) -> block ((I + J) + (B + D)) := - fmap_block (fun l => - match l with - | inl j => inl (inr j) - | inr d => inr (inr d) - end). - - (** Append two asm programs, preserving their internal links. *) - Definition app_asm {A B C D} (ab : asm A B) (cd : asm C D) : - asm (A + C) (B + D) := - {| internal := ab.(internal) + cd.(internal); - code := fun l => - match l with - | inl (inl ia) => _app_B (ab.(code) (inl ia)) - | inl (inr ic) => _app_D (cd.(code) (inl ic)) - | inr (inl a) => _app_B (ab.(code) (inr a)) - | inr (inr c) => _app_D (cd.(code) (inr c)) - end; - |}. - - (** Rename visible program labels. *) - Definition relabel_asm {A B C D} (f : A -> B) (g : C -> D) - (bc : asm B C) : asm A D := - {| code := relabel_bks (sum_bimap id f) (sum_bimap id g) bc.(code); - |}. - - (** Link labels from two programs together. *) - Definition link_asm {I A B} (ab : asm (I + A) (I + B)) : asm A B := - {| internal := ab.(internal) + I; - code := relabel_bks sum_assoc_r sum_assoc_l ab.(code); - |}. - End Syntax. Arguments internal {A B}. diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v new file mode 100644 index 00000000..f0a090f4 --- /dev/null +++ b/examples/AsmCombinators.v @@ -0,0 +1,211 @@ +(** * Composition of [asm] programs *) + +Require Import Asm. + +From Coq Require Import + List + Strings.String + Program.Basics. +Import ListNotations. +From ITree Require Import Basics_Functions. +Require Import ZArith. + +Typeclasses eauto := 5. + +(** ** Internal structures *) + +Definition fmap_branch {A B : Type} (f: A -> B): branch A -> branch B := + fun b => + match b with + | Bjmp a => Bjmp (f a) + | Bbrz c a a' => Bbrz c (f a) (f a') + | Bhalt => Bhalt + end. + +Definition fmap_block {A B: Type} (f: A -> B): block A -> block B := + fix fmap b := + match b with + | bbb a => bbb (fmap_branch f a) + | bbi i b => bbi i (fmap b) + end. + +Definition relabel_bks {A B C D : Type} (f : A -> B) (g : C -> D) + (b : bks B C) : bks A D := + fun a => fmap_block g (b (f a)). + +Section after. +Context {A : Type}. +Fixpoint after (is : list instr) (bch : branch A) : block A := + match is with + | nil => bbb bch + | i :: is => bbi i (after is bch) + end. +End after. + +(** ** Low-level interface with [asm] *) + +(** Any collection of blocks forms an [asm] program with + no hidden blocks. *) +Definition raw_asm {A B} (b : bks A B) : asm A B := + {| internal := Empty_set; + code := fun a' => + match a' with + | inl v => match v : Empty_set with end + | inr a => fmap_block inr (b a) + end; + |}. + +(** Wrap a single block as [asm]. *) +Definition raw_asm_block {A} (b : block A) : asm unit A := + raw_asm (fun _ => b). + +(** ** [asm] combinators *) + +(** An [asm] program made only of external jumps. This is + useful to connect programs with [app_asm]. *) +Definition pure_asm {A B} (f : A -> B) : asm A B := + raw_asm (fun a => bbb (Bjmp (f a))). + +Definition id_asm {A} : asm A A := pure_asm id. + +(* Internal relabeling functions for [app_asm] *) +Definition _app_B {I J B D} : + block (I + B) -> block ((I + J) + (B + D)) := + fmap_block (fun l => + match l with + | inl i => inl (inl i) + | inr b => inr (inl b) + end). + +Definition _app_D {I J B D} : + block (J + D) -> block ((I + J) + (B + D)) := + fmap_block (fun l => + match l with + | inl j => inl (inr j) + | inr d => inr (inr d) + end). + +(** Append two asm programs, preserving their internal links. *) +Definition app_asm {A B C D} (ab : asm A B) (cd : asm C D) : + asm (A + C) (B + D) := + {| internal := ab.(internal) + cd.(internal); + code := fun l => + match l with + | inl (inl ia) => _app_B (ab.(code) (inl ia)) + | inl (inr ic) => _app_D (cd.(code) (inl ic)) + | inr (inl a) => _app_B (ab.(code) (inr a)) + | inr (inr c) => _app_D (cd.(code) (inr c)) + end; + |}. + +(** Rename visible program labels. *) +Definition relabel_asm {A B C D} (f : A -> B) (g : C -> D) + (bc : asm B C) : asm A D := + {| code := relabel_bks (sum_bimap id f) (sum_bimap id g) bc.(code); + |}. + +(** Link labels from two programs together. *) +Definition link_asm {I A B} (ab : asm (I + A) (I + B)) : asm A B := + {| internal := ab.(internal) + I; + code := relabel_bks sum_assoc_r sum_assoc_l ab.(code); + |}. + +(** ** Correctness *) +(** The combinators above map to their denotational counterparts. *) + +From ExtLib Require Import + Structures.Monad. +Import MonadNotation. +From ITree Require Import + ITree OpenSum Fix. +Require Import Imp Den. + +Section Correctness. + +Context {E : Type -> Type}. +Context {HasLocals : Locals -< E}. +Context {HasMemory : Memory -< E}. + +(** *** Internal structures *) + +Lemma fmap_block_map: + forall {L L'} b (f: L -> L'), + denote_block E (fmap_block f b) ≅ ITree.map (sum_bimap f id) (denote_block E b). +Proof. + induction b as [i b | br]; intros f. + - simpl. + unfold ITree.map; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IHb]. + - simpl. + destruct br; simpl. + + unfold ITree.map; rewrite ret_bind; reflexivity. + + unfold ITree.map; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. + + unfold ITree.map; rewrite ret_bind; reflexivity. +Qed. + +Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := + fix traverse__ l: M unit := + match l with + | [] => ret tt + | a::l => (f a;; traverse__ l)%monad + end. + +Definition denote_list: list instr -> itree E unit := + traverse_ (denote_instr E). + +Lemma denote_after_denote_list: + forall {label: Type} instrs (b: branch label), + denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_branch E b). +Proof. + induction instrs as [| i instrs IH]; intros b. + - simpl; rewrite ret_bind; reflexivity. + - simpl; rewrite bind_bind. + eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. +Qed. + +Lemma denote_list_app: + forall is1 is2, + @denote_list (is1 ++ is2) ≅ + (@denote_list is1;; denote_list is2). +Proof. + intros is1 is2; induction is1 as [| i is1 IH]; simpl; intros; [rewrite ret_bind; reflexivity |]. + rewrite bind_bind; setoid_rewrite IH; reflexivity. +Qed. + +(** *** [asm] combinators *) + +Theorem pure_asm_correct {A B} (f : A -> B) : + eq_den (denote_asm (pure_asm f)) + (@lift_den E _ _ f). +Proof. +Admitted. + +Definition id_asm_correct {A} : + eq_den (denote_asm (pure_asm id)) (@id_den E A). +Proof. +Admitted. + +Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : + @eq_den E _ _ + (denote_asm (app_asm ab cd)) + (tensor_den (denote_asm ab) (denote_asm cd)). +Proof. +Admitted. + +Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) + (bc : asm B C) : + @eq_den E _ _ + (denote_asm (relabel_asm f g bc)) + (lift_den f >=> denote_asm bc >=> lift_den g). +Proof. +Admitted. + +Definition link_asm_correct {I A B} (ab : asm (I + A) (I + B)) : + @eq_den E _ _ + (denote_asm (link_asm ab)) + (loop_den (denote_asm ab)). +Proof. +Admitted. + +End Correctness. diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 3621aa81..fc42b9e3 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -1,4 +1,4 @@ -Require Import Imp Asm. +Require Import Imp Asm AsmCombinators. Require Import Psatz. @@ -46,15 +46,6 @@ Section compile_assign. End compile_assign. -Section after. - Context {a : Type}. - Fixpoint after (is : list instr) (bch : branch a) : block a := - match is with - | nil => bbb bch - | i :: is => bbi i (after is bch) - end. -End after. - (** Sequencing of blocks: the program [seq_asm ab bc] links the exit points of [ab] with the entry points of [bc]. @@ -81,7 +72,7 @@ Definition tmp_if := gen_tmp 0. (* Conditional *) Definition cond_asm (e : list instr) : asm unit (unit + unit) := - raw_asm' (after e (Bbrz tmp_if (inl tt) (inr tt))). + raw_asm_block (after e (Bbrz tmp_if (inl tt) (inr tt))). (** [if_asm e tp fp] [[ @@ -118,7 +109,7 @@ Definition while_asm (e : list instr) (p : asm unit unit) : Fixpoint compile (s : stmt) {struct s} : asm unit unit := match s with | Skip => id_asm - | Assign x e => raw_asm' (after (compile_assign x e) (Bjmp tt)) + | Assign x e => raw_asm_block (after (compile_assign x e) (Bjmp tt)) | Seq l r => seq_asm (compile l) (compile r) | If e l r => if_asm (compile_expr 0 e) (compile l) (compile r) | While e b => while_asm (compile_expr 0 e) (compile b) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 676ab44f..1cd8022d 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -1,4 +1,4 @@ -Require Import Imp Asm Imp2Asm. +Require Import Imp Asm AsmCombinators Imp2Asm. Require Import Psatz. @@ -23,43 +23,6 @@ From ExtLib Require Import Import ListNotations. Open Scope string_scope. -Section denote_list. - - Import MonadNotation. - - Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := - fix traverse__ l: M unit := - match l with - | [] => ret tt - | a::l => (f a;; traverse__ l)%monad - end. - - Context {E} {EL : Locals -< E} {EM : Memory -< E}. - - Definition denote_list: list instr -> itree E unit := - traverse_ (denote_instr E). - - Lemma denote_after_denote_list: - forall {label: Type} instrs (b: branch label), - denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_branch E b). - Proof. - induction instrs as [| i instrs IH]; intros b. - - simpl; rewrite ret_bind; reflexivity. - - simpl; rewrite bind_bind. - eapply eq_itree_eq_bind; [reflexivity | intros []; apply IH]. - Qed. - - Lemma denote_list_app: - forall is1 is2, - @denote_list (is1 ++ is2) ≅ - (@denote_list is1;; denote_list is2). - Proof. - intros is1 is2; induction is1 as [| i is1 IH]; simpl; intros; [rewrite ret_bind; reflexivity |]. - rewrite bind_bind; setoid_rewrite IH; reflexivity. - Qed. - -End denote_list. - Section Correctness. (* @@ -78,22 +41,6 @@ Section Correctness. Variable E: Type -> Type. Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. - Lemma fmap_block_map: - forall {L L'} b (f: L -> L'), - denote_block E (fmap_block f b) ≅ ITree.map (sum_bimap f id) (denote_block E b). - Proof. - induction b as [i b | br]; intros f. - - simpl. - unfold ITree.map; rewrite bind_bind. - eapply eq_itree_eq_bind; [reflexivity | intros []; apply IHb]. - - simpl. - destruct br; simpl. - + unfold ITree.map; rewrite ret_bind; reflexivity. - + unfold ITree.map; rewrite bind_bind. - eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. - + unfold ITree.map; rewrite ret_bind; reflexivity. - Qed. - Variant Rvar : var -> var -> Prop := | Rvar_var v : Rvar (varOf v) v. @@ -171,6 +118,16 @@ Section Real_correctness. (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). Admitted. +(* TODO: maybe some of the correctness lemmas/theorems could + be refactored with this relation on denotations (which needs + fixing). + + Definition eq_locals {R} (t1 t2 : itree E R) : Prop := + forall g1 g2, + Renv g1 g2 -> + eutt (sim_rel _ _) (interp_locals t1 g1) (interp_locals t2 g2). +*) + Set Nested Proofs Allowed. Ltac force_left := @@ -504,19 +461,17 @@ Qed. Proof. Admitted. -(* (incomplete) eutt modulo interp_locals and Renv on states *) -Axiom eq_den' : forall {A}, itree E A -> itree E A -> Prop. - Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : - eq_den' (denote_asm (if_asm e tp fp) tt) - (denote_list e ;; - v <- lift (GetVar tmp_if) ;; - if v : value then denote_asm tp tt else denote_asm fp tt). + eutt eq + (denote_asm (if_asm e tp fp) tt) + (denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then denote_asm tp tt else denote_asm fp tt). Proof. Admitted. Lemma while_asm_correct (e : list instr) (p : asm unit unit) : - eq_den' (denote_asm (while_asm e p) tt) + eutt eq (denote_asm (while_asm e p) tt) (loop_den (fun l => match l with | inl tt => diff --git a/examples/_CoqProject b/examples/_CoqProject index d47670fb..dd9e7cf0 100644 --- a/examples/_CoqProject +++ b/examples/_CoqProject @@ -5,9 +5,10 @@ IO.v MultiThreadedPrinting.v ExtractThreadsExample.v -Asm.v Den.v Imp.v +Asm.v +AsmCombinators.v Linking.v Imp2Asm.v Imp2AsmCorrectness.v From d3952998f70a722a207d2b4805e2e69ad3d337dd Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 09:51:19 -0500 Subject: [PATCH 092/142] Correctness proof sketc --- examples/AsmCombinators.v | 8 +++- examples/Imp2AsmCorrectness.v | 69 ++++++++++++----------------------- 2 files changed, 30 insertions(+), 47 deletions(-) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index f0a090f4..43d14257 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -154,7 +154,7 @@ Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): li Definition denote_list: list instr -> itree E unit := traverse_ (denote_instr E). -Lemma denote_after_denote_list: +Lemma after_correct : forall {label: Type} instrs (b: branch label), denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_branch E b). Proof. @@ -173,6 +173,12 @@ Proof. rewrite bind_bind; setoid_rewrite IH; reflexivity. Qed. +Lemma raw_asm_block_correct {A} (b : block A) : + eutt eq (denote_asm (raw_asm_block b) tt) + (denote_block _ b). +Proof. +Admitted. + (** *** [asm] combinators *) Theorem pure_asm_correct {A B} (f : A -> B) : diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 1cd8022d..5979b50d 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -493,52 +493,29 @@ Qed. (interp_locals (denote_asm (compile s) tt) g_asm) (interp_locals (denoteStmt s ;; Ret (inl tt)) g_imp). Proof. - - (* Proof sketched on the old version of the theorem, mostly obsolete - induction s; intros. - { (* assign *) - simpl. - unfold denote_main. simpl. unfold denote_program. - simpl. - rewrite denote_after_denote_list. - rewrite bind_bind. - rewrite interp_locals_bind. - rewrite interp_locals_bind. - eapply eutt_bind_gen. - eapply compile_assign_correct; eauto. - simpl; intros. - clear - H0. - rewrite fmap_block_map. - unfold ITree.map. - rewrite bind_bind. - setoid_rewrite ret_bind. - rewrite <- (bind_ret (interp_locals _ (fst r2))). - rewrite interp_locals_bind. - eapply eutt_bind_gen. - { SearchAbout denote_block. - instantiate (1 := fun a b => Renv (fst a) (fst b) /\ snd a = snd b). - admit. } - { simpl. - intros. - destruct r0, r3; simpl in *. - destruct H; subst. - destruct o0; simpl. - { force_left. - eapply Ret_eutt. - simpl. tauto. } - { force_left. eapply Ret_eutt; simpl. tauto. } } } - { (* seq *) - simpl. - specialize (IHs1 _ (main (compile s2 b)) _ _ H). - rewrite bind_bind. - unfold denote_main; simpl. - unfold denote_main in IHs1. - rewrite fmap_block_map. - unfold ITree.map. rewrite bind_bind. - setoid_rewrite ret_bind. -*) - - Admitted. + induction s; intros. + - (* Assign *) + simpl. + rewrite raw_asm_block_correct. + rewrite after_correct. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { eapply compile_assign_correct; auto. } + intros. simpl. + rewrite (itree_eta (_ (fst r1))), (itree_eta (_ (fst r2))). + cbn. + apply eutt_Ret; auto. + - (* Seq *) + admit. + - (* If *) + admit. + - (* While *) + admit. + - (* Skip *) + rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). + cbn. + apply eutt_Ret; auto. + Admitted. (* From 581bc10d8063490e789e136a6eb7de69dabb952f Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 10:15:10 -0500 Subject: [PATCH 093/142] Fill in some more in toplevel theorem --- examples/Imp2AsmCorrectness.v | 38 +++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 5979b50d..89cebcf0 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -486,30 +486,60 @@ Qed. Proof. Admitted. + Global Instance subrelation_eq_den {E A B} : + subrelation (@eq_den E A B) (pointwise_relation _ (eutt eq))%signature. + Proof. + Admitted. + +(* a trick to allow rewriting with eq_den *) +Definition ff (f : @den E unit unit) : itree E (unit + done) := f tt. + +Global Instance Proper_ff : Proper (eq_den ==> eutt eq) ff. +Admitted. + +Lemma fold_ff f : f tt = ff f. +Proof. reflexivity. Qed. + Lemma compile_correct: forall s (g_imp g_asm : alist var value), Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = inl (snd b)) (interp_locals (denote_asm (compile s) tt) g_asm) - (interp_locals (denoteStmt s ;; Ret (inl tt)) g_imp). + (interp_locals (denoteStmt s) g_imp). Proof. induction s; intros. - (* Assign *) simpl. rewrite raw_asm_block_correct. rewrite after_correct. + rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). rewrite 2 interp_locals_bind. eapply eutt_bind_gen. { eapply compile_assign_correct; auto. } intros. simpl. rewrite (itree_eta (_ (fst r1))), (itree_eta (_ (fst r2))). cbn. - apply eutt_Ret; auto. + apply eutt_Ret. destruct (snd r2). auto. - (* Seq *) - admit. + rewrite fold_ff; simpl. + rewrite seq_asm_correct. unfold ff. + unfold compose_den. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { auto. } + intros. destruct H0. destruct (snd r2). rewrite H1. + auto. - (* If *) + simpl; rewrite if_asm_correct. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { apply compile_expr_correct. auto. } + intros. admit. - (* While *) + simpl; rewrite while_asm_correct. rewrite fold_ff. + (* TODO: Should use some loop_den lemmas to make the two loops + line up. *) admit. - (* Skip *) rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). From 0602206636079e0154faa44f0a818aeb597eff5f Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 25 Feb 2019 11:56:39 -0500 Subject: [PATCH 094/142] Couple of proofs in AsmCombinators --- examples/AsmCombinators.v | 40 +++++++++++++++++++++++-- examples/Den.v | 63 +++++++++++++++++++++++++++++++-------- 2 files changed, 87 insertions(+), 16 deletions(-) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index 43d14257..543434c1 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -173,11 +173,37 @@ Proof. rewrite bind_bind; setoid_rewrite IH; reflexivity. Qed. +(* TO MOVE *) +Lemma map_ret {X Y: Type}: + forall (f: X -> Y) x, + @ITree.map E _ _ f (Ret x) ≅ Ret (f x). +Proof. + intros. + unfold ITree.map. + rewrite ret_bind; reflexivity. +Qed. + +Lemma raw_asm_block_correct_lifted {A} (b : block A) : + denote_asm (raw_asm_block b) ⩰ + (fun _ => (denote_block _ b)). +Proof. + unfold denote_asm. + rewrite vanishing_den. + rewrite elim_λ_den', elim_λ_den. + unfold denote_b; simpl. + intros []. + rewrite fmap_block_map, map_map. + unfold ITree.map. + rewrite <- (bind_ret (denote_block E b)) at 2. + apply eutt_bind; [reflexivity | intros []; reflexivity]. +Qed. + Lemma raw_asm_block_correct {A} (b : block A) : eutt eq (denote_asm (raw_asm_block b) tt) (denote_block _ b). Proof. -Admitted. + apply raw_asm_block_correct_lifted. +Qed. (** *** [asm] combinators *) @@ -185,12 +211,20 @@ Theorem pure_asm_correct {A B} (f : A -> B) : eq_den (denote_asm (pure_asm f)) (@lift_den E _ _ f). Proof. -Admitted. + unfold denote_asm . + rewrite vanishing_den. + rewrite elim_λ_den', elim_λ_den. + unfold denote_b; simpl. + intros ?. + rewrite map_ret. + reflexivity. +Qed. Definition id_asm_correct {A} : eq_den (denote_asm (pure_asm id)) (@id_den E A). Proof. -Admitted. + rewrite pure_asm_correct; reflexivity. +Defined. Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : @eq_den E _ _ diff --git a/examples/Den.v b/examples/Den.v index 975e7670..7dc43854 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -72,8 +72,10 @@ Section Den. sum_elim (compose_den ab (lift_den inl)) (compose_den cd (lift_den inr)). (* Left and right unitors *) - Definition λ_den {A: Type}: denE (I + A) A := lift_den sum_empty_l. - Definition ρ_den {A: Type}: denE (A + I) A := lift_den sum_empty_r. + Definition λ_den {A: Type}: denE (I + A) A := lift_den sum_empty_l. + Definition λ_den' {A: Type}: denE A (I + A) := lift_den inr. + Definition ρ_den {A: Type}: denE (A + I) A := lift_den sum_empty_r. + Definition ρ_den' {A: Type}: denE A (A + I) := lift_den inl. (* Associator *) Definition assoc_den_l {A B C: Type}: denE (A + (B + C)) ((A + B) + C) := lift_den sum_assoc_l. @@ -224,6 +226,38 @@ Section Den. intros []; reflexivity. Qed. + (** *** [Unitors] lemmas *) + + Lemma elim_λ_den {A B: Type}: + forall (ab: @den E A (I + B)), ab >=> λ_den ⩰ (fun a: A => ITree.map (sum_bimap sum_empty_l id) (ab a)). + Proof. + intros; apply compose_den_lift. + Qed. + + Lemma elim_λ_den' {A B: Type}: + forall (f: @den E (I + A) (I + B)), + λ_den' >=> f ⩰ fun a => f (inr a). + Proof. + repeat intro. + unfold λ_den', compose_den, lift_den. + rewrite ret_bind_; reflexivity. + Qed. + + Lemma elim_ρ_den' {A B: Type}: + forall (f: @den E (A + I) (B + I)), + ρ_den' >=> f ⩰ fun a => f (inl a). + Proof. + repeat intro. + unfold ρ_den', compose_den, lift_den. + rewrite ret_bind_; reflexivity. + Qed. + + Lemma elim_ρ_den {A B: Type}: + forall (ab: @den E A (B + I)), ab >=> ρ_den ⩰ (fun a: A => ITree.map (sum_bimap sum_empty_r id) (ab a)). + Proof. + intros; apply compose_den_lift. + Qed. + (** *** [tensor] lemmas *) Instance eq_den_tensor {A B C D}: @@ -387,6 +421,15 @@ Section Den. rewrite (H z); reflexivity. Qed. + Lemma bind_map: forall {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z), + eq_itree eq (ITree.map f (x <- t;; k x)) (x <- t;; ITree.map f (k x)). + Proof. + intros. + unfold ITree.map. + rewrite bind_bind. + reflexivity. + Qed. + (* Naturality of (loop_den I A B) in A *) (* Or more diagrammatically: [[ @@ -407,16 +450,6 @@ A----B----###----C ]] *) - Lemma bind_map: forall {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z), - eq_itree eq (ITree.map f (x <- t;; k x)) (x <- t;; ITree.map f (k x)). - Proof. - intros. - unfold ITree.map. - rewrite bind_bind. - reflexivity. - Qed. - - Lemma compose_loop {I A B C}: forall (bc_: denE (I + B) (I + C)) (ab: denE A B), loop_den ((id_den ⊗ ab) >=> bc_) ⩰ @@ -459,6 +492,11 @@ A----###----B----C loop_den ((ji ⊗ id_den) >=> ab_). Admitted. + (* Loop over the empty set can be erased *) + Lemma vanishing_den {A B: Type}: + forall (f: denE (I + A) (I + B)), + loop_den f ⩰ λ_den' >=> f >=> λ_den. + Admitted. (* [loop_loop]: @@ -504,7 +542,6 @@ These two loops: Lemma yanking_den {A: Type}: loop_den sym_den ⩰ @id_den A. Admitted. - (* Lemma loop_relabel {I J A B} *) (* (f : I -> J) {f' : J -> I} *) (* {ISO_f : Iso f f'} *) From 741a45cd8c9b122b331f897fa0edfc128571799c Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 25 Feb 2019 17:07:26 -0500 Subject: [PATCH 095/142] Work in progress to prove app_asm_correct --- examples/AsmCombinators.v | 65 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 63 insertions(+), 2 deletions(-) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index 543434c1..7bd1fb08 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -226,11 +226,72 @@ Proof. rewrite pure_asm_correct; reflexivity. Defined. +Lemma tensor_den_slide_right {A B C D}: + forall (ac: @den E A C) (bd: den B D), + ac ⊗ bd ⩰ id_den ⊗ bd >=> ac ⊗ id_den. +Proof. + intros. + unfold tensor_den. + repeat rewrite id_den_left. + rewrite sum_elim_compose. + rewrite compose_den_assoc. + rewrite inl_sum_elim, inr_sum_elim. + reflexivity. +Qed. + +Lemma local_rewrite1 {A B C: Type}: + id_den ⊗ sym_den >=> assoc_den_l >=> sym_den ⩰ + @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. +Proof. + unfold id_den, tensor_den,sym_den, assoc_den_l, compose_den, assoc_den_r, lift_den. + intros [| []]; simpl; + repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. +Qed. + +Lemma local_rewrite2 {A B C: Type}: + sym_den >=> assoc_den_r >=> id_den ⊗ sym_den ⩰ + @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. +Proof. + unfold id_den, tensor_den,sym_den, assoc_den_l, compose_den, assoc_den_r, lift_den. + intros [| []]; simpl; + repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. +Qed. + +Lemma loop_tensor_den {I A B C D} + (ab : @den E A B) (cd : @den E (I + C) (I + D)) : + ab ⊗ loop_den cd ⩰ + loop_den (assoc_den_l >=> sym_den ⊗ id_den >=> assoc_den_r + >=> ab ⊗ cd + >=> assoc_den_l >=> sym_den ⊗ id_den >=> assoc_den_r). +Proof. + rewrite tensor_swap, tensor_den_loop. + rewrite <- compose_loop. + rewrite <- loop_compose. + rewrite (tensor_swap cd ab). + repeat rewrite <- compose_den_assoc. + rewrite local_rewrite1. + do 2 rewrite compose_den_assoc. + rewrite <- (compose_den_assoc sym_den assoc_den_r _). + rewrite local_rewrite2. + repeat rewrite <- compose_den_assoc. + reflexivity. +Qed. + Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : @eq_den E _ _ - (denote_asm (app_asm ab cd)) - (tensor_den (denote_asm ab) (denote_asm cd)). + (denote_asm (app_asm ab cd)) + (tensor_den (denote_asm ab) (denote_asm cd)). Proof. + unfold denote_asm. + match goal with | |- ?x ⩰ _ => set (lhs := x) end. + rewrite tensor_den_loop. + rewrite loop_tensor_den. + rewrite <- compose_loop. + rewrite <- loop_compose. + rewrite loop_loop. + subst lhs. + unfold app_asm. + simpl. Admitted. Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) From e14223dca0e4229f0cdd12a0a48e16263a79a9cd Mon Sep 17 00:00:00 2001 From: Lysxia Date: Mon, 25 Feb 2019 19:46:51 -0500 Subject: [PATCH 096/142] Add unfold_mrec --- theories/FixFacts.v | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/theories/FixFacts.v b/theories/FixFacts.v index db67cd5f..f8566a06 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -29,36 +29,36 @@ Definition interp_mrecF R : handleF1 (interp_mrec ctx R) (fun _ d k => Tau (interp_mrec ctx _ (ctx _ d >>= k))). -Lemma unfold_interp_mrecF R (t : itree (D +' E) R) : +Lemma observe_interp_mrecF R (t : itree (D +' E) R) : observe (interp_mrec ctx _ t) = observe (interp_mrecF _ (observe t)). Proof. reflexivity. Qed. -Lemma unfold_interp_mrec R (t : itree (D +' E) R) : +Lemma observe_interp_mrec R (t : itree (D +' E) R) : eq_itree eq (interp_mrec ctx _ t) (interp_mrecF _ (observe t)). Proof. - rewrite itree_eta, unfold_interp_mrecF, <-itree_eta. + rewrite itree_eta, observe_interp_mrecF, <-itree_eta. reflexivity. Qed. Lemma ret_mrec {T} (x: T) : interp_mrec ctx _ (Ret x) ≅ Ret x. -Proof. rewrite unfold_interp_mrec; reflexivity. Qed. +Proof. rewrite observe_interp_mrec; reflexivity. Qed. Lemma tau_mrec {T} (t: itree _ T) : interp_mrec ctx _ (Tau t) ≅ Tau (interp_mrec ctx _ t). -Proof. rewrite unfold_interp_mrec. reflexivity. Qed. +Proof. rewrite observe_interp_mrec. reflexivity. Qed. Lemma vis_mrec_right {T U} (e : E U) (k : U -> itree (D +' E) T) : interp_mrec ctx _ (Vis (inr1 e) k) ≅ Vis e (fun x => interp_mrec ctx _ (k x)). -Proof. rewrite unfold_interp_mrec. reflexivity. Qed. +Proof. rewrite observe_interp_mrec. reflexivity. Qed. Lemma vis_mrec_left {T U} (d : D U) (k : U -> itree (D +' E) T) : interp_mrec ctx _ (Vis (inl1 d) k) ≅ Tau (interp_mrec ctx _ (ITree.bind (ctx _ d) k)). -Proof. rewrite unfold_interp_mrec. reflexivity. Qed. +Proof. rewrite observe_interp_mrec. reflexivity. Qed. Hint Rewrite @ret_mrec : itree. Hint Rewrite @vis_mrec_left : itree. @@ -70,7 +70,7 @@ Instance eq_itree_mrec {R} : Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. - rewrite !unfold_interp_mrec. + rewrite !observe_interp_mrec. pupto2_final. punfold H0. inv H0; pclearbot; [| |destruct e]. - apply reflexivity. @@ -122,7 +122,7 @@ Lemma mrec_invariant_init {U} (r : relation (itree _ U)) (interp_mrec ctx _ c1) (interp1 h_mrec _ c2). Proof. - rewrite unfold_interp_mrec, unfold_interp1. + rewrite observe_interp_mrec, unfold_interp1. punfold Ec. inversion Ec; cbn; pclearbot; pupto2_final. + subst; apply reflexivity. @@ -149,11 +149,11 @@ Proof. - rewrite Ec1, Ec2. apply mrec_invariant_init; auto 10. - rewrite Ec1, Ec2. cbn. - rewrite unfold_interp_mrec. + rewrite observe_interp_mrec. rewrite (unfold_bind (interp_mrec _ _ d)). unfold observe, _observe; cbn. destruct (observe d); fold_observe; cbn. - + rewrite <- unfold_interp_mrec. + + rewrite <- observe_interp_mrec. apply mrec_invariant_init; auto. + pupto2_final; pfold; constructor; right. eapply self. @@ -171,13 +171,19 @@ Proof. all: cbn; fold_bind; reflexivity. Qed. -Theorem interp_mrec_is_interp : forall {T} (c : itree _ T), - eq_itree eq (interp_mrec ctx _ c) (interp1 h_mrec _ c). +Theorem unfold_interp_mrec {T} (c : itree _ T) : + interp_mrec ctx _ c ≅ interp1 h_mrec _ c. Proof. - intros; eapply mrec_invariant_eq; + eapply mrec_invariant_eq; try eapply mrec_main; reflexivity. Qed. +Theorem unfold_mrec {T} (d : D T) : + mrec ctx _ d ≅ interp1 (mrec ctx) _ (ctx _ d). +Proof. + apply unfold_interp_mrec. +Qed. + End Facts. Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : @@ -187,7 +193,7 @@ Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : end) _ (f x). Proof. unfold rec. unfold mrec. - rewrite interp_mrec_is_interp. + rewrite unfold_interp_mrec. repeat rewrite <- interp_is_interp1. unfold interp_match. unfold mrec. From 4a18824992e9f9eb1b715d3baf0dedce6c06e335 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Mon, 25 Feb 2019 20:25:57 -0500 Subject: [PATCH 097/142] an example of proving factorial correct --- examples/Factorial.v | 67 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100644 examples/Factorial.v diff --git a/examples/Factorial.v b/examples/Factorial.v new file mode 100644 index 00000000..11a8d4ce --- /dev/null +++ b/examples/Factorial.v @@ -0,0 +1,67 @@ +Set Implicit Arguments. +Set Contextual Implicit. + +From Coq Require Import + Nat + Setoid + RelationClasses + Program + Morphisms. + +From ITree Require Import + ITree + Fix + FixFacts + Eq.Eq + Eq.UpToTaus + MorphismsFacts. + +(* Define the recursive factorial function via events. + Here we use the generic "rec" interface of the library, instantiating callE + with the type of factorial : nat -> nat. +*) +Definition factC {E} n : itree (callE nat nat +' E) nat := ITree.liftE (inl1 (Call n)). + +(* We write the body of the function monadically, using events rather than recursive calls. *) +Definition fact_body {E} (rec : nat -> itree (callE nat nat +' E) nat) : nat -> itree (callE nat nat +' E) nat := + (fun x => match x with + | 0 => Ret 1 + | S m => y <- rec m ;; Ret (x * y) + end). + +Definition factorial {E} (n:nat) : itree E nat := + rec (fact_body factC) n. + + +(* This is the Coq specification -- the usual mathematical definition. *) +Fixpoint factspec (n:nat) : nat := + match n with + | 0 => 1 + | S m => n * factspec m + end. + +(* The proof is by induction on n and uses only rewriting, no coinduction. *) +(* SAZ: The rewriting in this proof is a bit annoying. + - We have to use itree_eta in order to rewrite with ret_bind. + - the use of cbn to drive the interp forward also unfolds the fact_body too + much, which means we have to use fold_bind so that interp_bind can see + the bind. +*) +Lemma factorial_correct : forall {E} n, (factorial n : itree E nat) ≈ Ret (factspec n). +Proof. + intros E. + intros n. + induction n; intros; subst. + - rewrite itree_eta. cbn. reflexivity. + - unfold factorial. + rewrite rec_unfold. + rewrite itree_eta. + cbn. + rewrite tau_eutt. + rewrite IHn. + rewrite itree_eta. + rewrite ret_bind. + fold_bind. rewrite interp_bind. + rewrite interp_ret. rewrite ret_bind. + rewrite interp_ret. reflexivity. +Qed. \ No newline at end of file From b9e780c512230827e30f302ae435db12da143426 Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 26 Feb 2019 00:19:41 -0500 Subject: [PATCH 098/142] Proving a few lemmas. while_asm_correct seems to be slightly buggy, to double check tomorrow. Rewriting eq_den equations in eutt goals is problematic. --- examples/AsmCombinators.v | 59 ++++++++++- examples/Imp2AsmCorrectness.v | 180 +++++++++++++++++++++++++--------- 2 files changed, 189 insertions(+), 50 deletions(-) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index 7bd1fb08..d23f5f82 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -277,12 +277,45 @@ Proof. reflexivity. Qed. +Lemma foo {A B C: Type}: + forall (f: bks A C) (g: bks B C), + denote_b E (fun a => match a with + | inl x => f x + | inr x => g x + end) ⩰ + fun a => match a with + | inl x => denote_block E (f x) + | inr x => denote_block E (g x) + end. +Proof. + intros. + unfold denote_b; intros []; reflexivity. +Qed. + +Lemma bar {A B C: Type}: + forall (f: bks A C) (g: bks B C) a, + denote_block E match a with + | inl x => f x + | inr x => g x + end ≈ + match a with + | inl x => denote_block E (f x) + | inr x => denote_block E (g x) + end. +Proof. + intros. + destruct a; reflexivity. +Qed. + +Set Nested Proofs Allowed. + Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : @eq_den E _ _ (denote_asm (app_asm ab cd)) (tensor_den (denote_asm ab) (denote_asm cd)). Proof. unfold denote_asm. + match goal with | |- ?x ⩰ _ => set (lhs := x) end. rewrite tensor_den_loop. rewrite loop_tensor_den. @@ -290,10 +323,32 @@ Proof. rewrite <- loop_compose. rewrite loop_loop. subst lhs. - unfold app_asm. - simpl. + (* match goal with *) + (* | |- loop_den ?x ⩰ loop_den ?y => set (a := x) ; set (b := y) end. *) + + match goal with | |- _ ⩰ ?x => set (lhs := x) end. + simpl code. + cut ( + (denote_b E + (fun l : internal ab + internal cd + (A + C) => + match l with + | inl (inl ia) => _app_B (code ab (inl ia)) + | inl (inr ic) => _app_D (code cd (inl ic)) + | inr (inl a) => _app_B (code ab (inr a)) + | inr (inr c) => _app_D (code cd (inr c)) + end)) ⩰ + (fun l : internal ab + internal cd + (A + C) => + match l with + | inl (inl ia) => denote_block E (_app_B (code ab (inl ia))) + | inl (inr ic) => denote_block E (_app_D (code cd (inl ic))) + | inr (inl a) => denote_block E (_app_B (code ab (inr a))) + | inr (inr c) => denote_block E (_app_D (code cd (inr c))) + end)); [intros EQ; rewrite EQ; clear EQ | intros [[]|[]]; reflexivity]. + Admitted. + + Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) (bc : asm B C) : @eq_den E _ _ diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 89cebcf0..7c5ba575 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -455,12 +455,39 @@ Qed. Require Import Den. + Lemma sym_den_unfold {E} {A B}: + lift_den sum_comm ⩰ @sym_den E A B. + Proof. + reflexivity. + Qed. + + Lemma seq_linking_den {E} {A B C} (ab : @den E A B) (bc : den B C) : + loop_den (sym_den >=> ab ⊗ bc) ⩰ ab >=> bc. + Proof. + rewrite tensor_den_slide. + rewrite <- compose_den_assoc. + rewrite loop_compose. + rewrite tensor_swap. + repeat rewrite <- compose_den_assoc. + rewrite sym_nilpotent, id_den_left. + rewrite compose_loop. + erewrite yanking_den. + rewrite id_den_right. + reflexivity. + Qed. + Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_den (denote_asm (seq_asm ab bc)) (denote_asm ab >=> denote_asm bc). Proof. - Admitted. + unfold seq_asm. + rewrite link_asm_correct, relabel_asm_correct, app_asm_correct. + rewrite id_den_right. + rewrite sym_den_unfold. + apply seq_linking_den. + Qed. + (* YZ: Things get wonky once in the two subgoals. eq_den lemmas cannot be rewritten inside of terms anymore since it's specialized to a specific eutt *) Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : eutt eq (denote_asm (if_asm e tp fp) tt) @@ -468,7 +495,38 @@ Qed. v <- lift (GetVar tmp_if) ;; if v : value then denote_asm tp tt else denote_asm fp tt). Proof. - Admitted. + unfold if_asm. + rewrite (seq_asm_correct _ _ tt). + unfold cond_asm. + unfold compose_den; rewrite raw_asm_block_correct. + rewrite after_correct. + simpl. + repeat setoid_rewrite bind_bind. + apply eutt_bind; [reflexivity | intros ?]. + apply eutt_bind; [reflexivity | intros []]. + - rewrite ret_bind_. + rewrite (relabel_asm_correct _ _ _ (inl tt)). + unfold compose_den; simpl. + rewrite bind_bind. + unfold lift_den; rewrite ret_bind_. + setoid_rewrite (app_asm_correct tp fp (inl tt)). + setoid_rewrite bind_bind. + rewrite <- (bind_ret (denote_asm tp tt)) at 2. + eapply eutt_bind; [reflexivity | intros []]. + unfold lift_den; rewrite ret_bind_; reflexivity. + rewrite ret_bind_; reflexivity. + - rewrite ret_bind_. + rewrite (relabel_asm_correct _ _ _ (inr tt)). + unfold compose_den; simpl. + rewrite bind_bind. + unfold lift_den; rewrite ret_bind_. + setoid_rewrite (app_asm_correct tp fp (inr tt)). + setoid_rewrite bind_bind. + rewrite <- (bind_ret (denote_asm fp tt)) at 2. + eapply eutt_bind; [reflexivity | intros []]. + unfold lift_den; rewrite ret_bind_; reflexivity. + rewrite ret_bind_; reflexivity. + Qed. Lemma while_asm_correct (e : list instr) (p : asm unit unit) : eutt eq (denote_asm (while_asm e p) tt) @@ -484,6 +542,32 @@ Qed. | inr tt => Ret (inl (inl tt)) end) tt). Proof. + unfold while_asm. + rewrite (link_asm_correct _ tt). + apply eq_den_loop. + rewrite relabel_asm_correct, id_den_left. + rewrite app_asm_correct. + intros [[] |[]]. + - unfold compose_den. + simpl; setoid_rewrite bind_bind. + rewrite if_asm_correct. + rewrite bind_bind. + apply eutt_bind; [reflexivity | intros []]. + rewrite bind_bind. + apply eutt_bind; [reflexivity | intros []]. + + rewrite (relabel_asm_correct _ _ _ tt). + unfold compose_den. + simpl; repeat setoid_rewrite bind_bind. + unfold lift_den; rewrite ret_bind_. + apply eutt_bind; [reflexivity | intros [[]|]]. + * repeat rewrite ret_bind_; reflexivity. + * repeat rewrite ret_bind_. + (* Buggy, to fix *) + admit. + + rewrite (pure_asm_correct _ tt). + unfold lift_den. + repeat rewrite ret_bind_. + reflexivity. Admitted. Global Instance subrelation_eq_den {E A B} : @@ -500,53 +584,53 @@ Admitted. Lemma fold_ff f : f tt = ff f. Proof. reflexivity. Qed. - Lemma compile_correct: - forall s (g_imp g_asm : alist var value), - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = inl (snd b)) - (interp_locals (denote_asm (compile s) tt) g_asm) - (interp_locals (denoteStmt s) g_imp). - Proof. - induction s; intros. - - (* Assign *) - simpl. - rewrite raw_asm_block_correct. - rewrite after_correct. - rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { eapply compile_assign_correct; auto. } - intros. simpl. - rewrite (itree_eta (_ (fst r1))), (itree_eta (_ (fst r2))). - cbn. - apply eutt_Ret. destruct (snd r2). auto. - - (* Seq *) - rewrite fold_ff; simpl. - rewrite seq_asm_correct. unfold ff. - unfold compose_den. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { auto. } - intros. destruct H0. destruct (snd r2). rewrite H1. - auto. - - (* If *) - simpl; rewrite if_asm_correct. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { apply compile_expr_correct. auto. } - intros. - admit. - - (* While *) - simpl; rewrite while_asm_correct. rewrite fold_ff. - (* TODO: Should use some loop_den lemmas to make the two loops +Lemma compile_correct: + forall s (g_imp g_asm : alist var value), + Renv g_asm g_imp -> + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = inl (snd b)) + (interp_locals (denote_asm (compile s) tt) g_asm) + (interp_locals (denoteStmt s) g_imp). +Proof. + induction s; intros. + - (* Assign *) + simpl. + rewrite raw_asm_block_correct. + rewrite after_correct. + rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { eapply compile_assign_correct; auto. } + intros. simpl. + rewrite (itree_eta (_ (fst r1))), (itree_eta (_ (fst r2))). + cbn. + apply eutt_Ret. destruct (snd r2). auto. + - (* Seq *) + rewrite fold_ff; simpl. + rewrite seq_asm_correct. unfold ff. + unfold compose_den. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { auto. } + intros. destruct H0. destruct (snd r2). rewrite H1. + auto. + - (* If *) + simpl; rewrite if_asm_correct. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { apply compile_expr_correct. auto. } + intros. + admit. + - (* While *) + simpl; rewrite while_asm_correct. rewrite fold_ff. + (* TODO: Should use some loop_den lemmas to make the two loops line up. *) - admit. - - (* Skip *) - rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). - cbn. - apply eutt_Ret; auto. - Admitted. - + admit. + - (* Skip *) + rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). + cbn. + apply eutt_Ret; auto. +Admitted. + (* Seq a b From 7976b9658aa13c45f487e6b0902009652b23fd54 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 26 Feb 2019 06:38:36 -0500 Subject: [PATCH 099/142] Make done an effect --- examples/Asm.v | 42 +++++++++-------- examples/AsmCombinators.v | 44 +++++++++--------- examples/Den.v | 79 ++++++++++++-------------------- examples/Imp2AsmCorrectness.v | 86 ++++++++++++++++++----------------- 4 files changed, 121 insertions(+), 130 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index a21bf1f4..db96825e 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -77,19 +77,26 @@ Section Semantics. | Load (addr : value) : Memory value | Store (addr val : value) : Memory unit. + Inductive Exit : Type -> Type := + | Done : Exit Empty_set. + + Definition done {E A} `{Exit -< E} : itree E A := + Vis (subeffect _ Done) (fun v => match v : Empty_set with end). + (* Denotation of blocks *) Section with_effect. - Variable e : Type -> Type. - Context {HasLocals : Locals -< e}. - Context {HasMemory : Memory -< e}. + Context {E : Type -> Type}. + Context {HasLocals : Locals -< E}. + Context {HasMemory : Memory -< E}. + Context {HasExit : Exit -< E}. - Definition denote_operand (o : operand) : itree e value := + Definition denote_operand (o : operand) : itree E value := match o with | Oimm v => Ret v | Ovar v => lift (GetVar v) end. - Definition denote_instr (i : instr) : itree e unit := + Definition denote_instr (i : instr) : itree E unit := match i with | Imov d s => v <- denote_operand s ;; @@ -111,18 +118,16 @@ Section Semantics. Section with_labels. Context {A B : Type}. - Definition denote_branch (b : @branch B) - : itree e (B + done) := + Definition denote_branch (b : branch B) : itree E B := match b with - | Bjmp l => ret (inl l) + | Bjmp l => ret l | Bbrz v y n => val <- lift (GetVar v) ;; - if val : value then ret (inl y) else ret (inl n) - | Bhalt => ret (inr Done) + if val : value then ret y else ret n + | Bhalt => done end. - Fixpoint denote_block (b : @block B) - : itree e (B + done) := + Fixpoint denote_block (b : block B) : itree E B := match b with | bbi i b => denote_instr i ;; denote_block b @@ -130,22 +135,21 @@ Section Semantics. denote_branch b end. - Definition denote_b: bks A B -> @den e A B := + Definition denote_b : bks A B -> @den E A B := fun bs a => denote_block (bs a). End with_labels. - End with_effect. (* A denotation of an asm program can be viewed as a circuit/diagram where wires correspond to jumps/program links. - It is therefore denoted as a [dem] term *) + It is therefore denoted as a [den] term *) - (* Denotation of [asm] *) - Definition denote_asm {e} `{Locals -< e} `{Memory -< e} {A B} : - asm A B -> @den e A B := - fun s => loop_den (denote_b e (code s)). + (* Denotation of [asm] *) + Definition denote_asm {A B} : asm A B -> @den E A B := + fun s => loop_den (denote_b (code s)). + End with_effect. End Semantics. (* SAZ: Everything from here down can probably be polished. diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index d23f5f82..433dd606 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -125,12 +125,13 @@ Section Correctness. Context {E : Type -> Type}. Context {HasLocals : Locals -< E}. Context {HasMemory : Memory -< E}. +Context {HasExit : Exit -< E}. (** *** Internal structures *) Lemma fmap_block_map: forall {L L'} b (f: L -> L'), - denote_block E (fmap_block f b) ≅ ITree.map (sum_bimap f id) (denote_block E b). + denote_block (fmap_block f b) ≅ ITree.map f (denote_block b). Proof. induction b as [i b | br]; intros f. - simpl. @@ -141,7 +142,8 @@ Proof. + unfold ITree.map; rewrite ret_bind; reflexivity. + unfold ITree.map; rewrite bind_bind. eapply eq_itree_eq_bind; [reflexivity | intros []; rewrite ret_bind; reflexivity]. - + unfold ITree.map; rewrite ret_bind; reflexivity. + + rewrite (itree_eta (ITree.map _ _)). + cbn. apply eq_itree_vis. intros []. Qed. Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): list A -> M unit := @@ -152,11 +154,11 @@ Definition traverse_ {A: Type} {M: Type -> Type} `{Monad M} (f: A -> M unit): li end. Definition denote_list: list instr -> itree E unit := - traverse_ (denote_instr E). + traverse_ denote_instr. Lemma after_correct : forall {label: Type} instrs (b: branch label), - denote_block E (after instrs b) ≅ (denote_list instrs ;; denote_branch E b). + denote_block (after instrs b) ≅ (denote_list instrs ;; denote_branch b). Proof. induction instrs as [| i instrs IH]; intros b. - simpl; rewrite ret_bind; reflexivity. @@ -185,7 +187,7 @@ Qed. Lemma raw_asm_block_correct_lifted {A} (b : block A) : denote_asm (raw_asm_block b) ⩰ - (fun _ => (denote_block _ b)). + (fun _ => denote_block b). Proof. unfold denote_asm. rewrite vanishing_den. @@ -194,13 +196,13 @@ Proof. intros []. rewrite fmap_block_map, map_map. unfold ITree.map. - rewrite <- (bind_ret (denote_block E b)) at 2. - apply eutt_bind; [reflexivity | intros []; reflexivity]. + rewrite <- (bind_ret (denote_block b)) at 2. + reflexivity. Qed. Lemma raw_asm_block_correct {A} (b : block A) : eutt eq (denote_asm (raw_asm_block b) tt) - (denote_block _ b). + (denote_block b). Proof. apply raw_asm_block_correct_lifted. Qed. @@ -243,7 +245,7 @@ Lemma local_rewrite1 {A B C: Type}: id_den ⊗ sym_den >=> assoc_den_l >=> sym_den ⩰ @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. Proof. - unfold id_den, tensor_den,sym_den, assoc_den_l, compose_den, assoc_den_r, lift_den. + unfold id_den, tensor_den,sym_den, assoc_den_l, ITree.cat, assoc_den_r, lift_den. intros [| []]; simpl; repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. Qed. @@ -252,7 +254,7 @@ Lemma local_rewrite2 {A B C: Type}: sym_den >=> assoc_den_r >=> id_den ⊗ sym_den ⩰ @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. Proof. - unfold id_den, tensor_den,sym_den, assoc_den_l, compose_den, assoc_den_r, lift_den. + unfold id_den, tensor_den,sym_den, assoc_den_l, ITree.cat, assoc_den_r, lift_den. intros [| []]; simpl; repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. Qed. @@ -279,13 +281,13 @@ Qed. Lemma foo {A B C: Type}: forall (f: bks A C) (g: bks B C), - denote_b E (fun a => match a with + denote_b (fun a => match a with | inl x => f x | inr x => g x end) ⩰ fun a => match a with - | inl x => denote_block E (f x) - | inr x => denote_block E (g x) + | inl x => denote_block (f x) + | inr x => denote_block (g x) end. Proof. intros. @@ -294,13 +296,13 @@ Qed. Lemma bar {A B C: Type}: forall (f: bks A C) (g: bks B C) a, - denote_block E match a with + denote_block match a with | inl x => f x | inr x => g x end ≈ match a with - | inl x => denote_block E (f x) - | inr x => denote_block E (g x) + | inl x => denote_block (f x) + | inr x => denote_block (g x) end. Proof. intros. @@ -329,7 +331,7 @@ Proof. match goal with | |- _ ⩰ ?x => set (lhs := x) end. simpl code. cut ( - (denote_b E + (denote_b (fun l : internal ab + internal cd + (A + C) => match l with | inl (inl ia) => _app_B (code ab (inl ia)) @@ -339,10 +341,10 @@ Proof. end)) ⩰ (fun l : internal ab + internal cd + (A + C) => match l with - | inl (inl ia) => denote_block E (_app_B (code ab (inl ia))) - | inl (inr ic) => denote_block E (_app_D (code cd (inl ic))) - | inr (inl a) => denote_block E (_app_B (code ab (inr a))) - | inr (inr c) => denote_block E (_app_D (code cd (inr c))) + | inl (inl ia) => denote_block (_app_B (code ab (inl ia))) + | inl (inr ic) => denote_block (_app_D (code cd (inl ic))) + | inr (inl a) => denote_block (_app_B (code ab (inr a))) + | inr (inr c) => denote_block (_app_D (code cd (inr c))) end)); [intros EQ; rewrite EQ; clear EQ | intros [[]|[]]; reflexivity]. Admitted. diff --git a/examples/Den.v b/examples/Den.v index 7dc43854..139c6fcb 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -11,8 +11,8 @@ From Coq Require Import Set Nested Proofs Allowed. (** * Category of denotations *) -Inductive done : Set := Done : done. -Definition den {E: Type -> Type} A B : Type := A -> itree E (B + done). + +Definition den {E: Type -> Type} A B : Type := A -> itree E B. (* den can represent both blocks (A -> block B) and asm (asm A B). *) Section Den. @@ -51,19 +51,14 @@ Section Den. Section Structure. (* Composition *) - Definition compose_den {A B C} (ab : denE A B) (bc : denE B C) : @denE A C := - fun a => ob <- ab a ;; - match ob with - | inl b => bc b - | inr d => Ret (inr d) - end. + Notation compose_den := ITree.cat. (* Identities *) Definition I: Type := Empty_set. - Definition id_den {A} : denE A A := fun a => Ret (inl a). + Definition id_den {A} : denE A A := fun a => Ret a. (* Utility function to lift a pure computation into den *) - Definition lift_den {A B} (f : A -> B) : denE A B := fun a => Ret (inl (f a)). + Definition lift_den {A B} (f : A -> B) : denE A B := fun a => Ret (f a). (* Tensor product *) (* Tensoring on objects is simply the sum type constructor *) @@ -101,27 +96,24 @@ Section Den. *) Definition loop_den {I A B} : - (I + A -> itree E ((I + B) + done)) -> A -> itree E (B + done) := - fun body => loop (compose (ITree.map sum_assoc_r) body). + (I + A -> itree E (I + B)) -> A -> itree E B := loop. End Structure. - Infix ">=>" := compose_den (at level 50, left associativity). Infix "⊗" := (tensor_den) (at level 30). Section Laws. (** *** [compose_den] respect eq_den *) Global Instance eq_den_compose {A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@compose_den A B C). + Proper (eq_den ==> eq_den ==> eq_den) (@ITree.cat _ A B C). Proof. intros ab ab' eqAB bc bc' eqBC. intro a. - unfold compose_den. + unfold ITree.cat. rewrite (eqAB a). apply eutt_bind; try reflexivity. - intros []; try reflexivity. - rewrite (eqBC b); reflexivity. + intro b; rewrite (eqBC b); reflexivity. Qed. (** *** [compose_den] is associative *) @@ -130,28 +122,25 @@ Section Den. ((ab >=> bc) >=> cd) ⩰ (ab >=> (bc >=> cd)). Proof. intros a. - unfold compose_den. + unfold ITree.cat. rewrite bind_bind. apply eutt_bind; try reflexivity. - intros []; try reflexivity. - rewrite itree_eta. - rewrite ret_bind. reflexivity. Qed. (** *** [id_den] respect identity laws *) Lemma id_den_left {A B}: forall (f: denE A B), id_den >=> f ⩰ f. Proof. - intros f a; unfold compose_den, id_den. + intros f a; unfold ITree.cat, id_den. rewrite itree_eta; rewrite ret_bind. rewrite <- itree_eta; reflexivity. Qed. Lemma id_den_right {A B}: forall (f: denE A B), f >=> id_den ⩰ f. Proof. - intros f a; unfold compose_den, id_den. + intros f a; unfold ITree.cat, id_den. rewrite <- (bind_ret (f a)) at 2. - apply eutt_bind; [reflexivity | intros []; reflexivity]. + reflexivity. Qed. (** *** [lift_den] is well-behaved *) @@ -168,9 +157,8 @@ Section Den. (lift_den ab >=> lift_den bc) ⩰ (lift_den (bc ∘ ab)). Proof. intros a. - unfold lift_den, compose_den. - rewrite itree_eta. - rewrite ret_bind. + unfold lift_den, ITree.cat. + rewrite ret_bind_. reflexivity. Qed. @@ -194,21 +182,19 @@ Section Den. lift_den f >=> bc ⩰ fun a => bc (f a). Proof. intros; intro a. - unfold lift_den, compose_den. - rewrite itree_eta. - rewrite ret_bind. rewrite <- itree_eta; reflexivity. + unfold lift_den, ITree.cat. + rewrite ret_bind_. reflexivity. Qed. Fact compose_den_lift {A B C}: forall (ab: den A B) (g:B -> C), eq_den (ab >=> lift_den g) - (fun a => ITree.map (sum_bimap g id) (ab a)). + (fun a => ITree.map g (ab a)). Proof. intros; intro a. - unfold compose_den. unfold ITree.map. apply eutt_bind. reflexivity. - intros []; reflexivity. + intro; reflexivity. Qed. (** *** [sum_elim] lemmas *) @@ -217,7 +203,7 @@ Section Den. sum_elim ac bc >=> cd ⩰ sum_elim (ac >=> cd) (bc >=> cd). Proof. intros; intros []; - (unfold compose_den; simpl; apply eutt_bind; [reflexivity | intros []; reflexivity]). + (unfold ITree.map; simpl; apply eutt_bind; reflexivity). Qed. Fact lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : @@ -229,7 +215,7 @@ Section Den. (** *** [Unitors] lemmas *) Lemma elim_λ_den {A B: Type}: - forall (ab: @den E A (I + B)), ab >=> λ_den ⩰ (fun a: A => ITree.map (sum_bimap sum_empty_l id) (ab a)). + forall (ab: @den E A (I + B)), ab >=> λ_den ⩰ (fun a: A => ITree.map sum_empty_l (ab a)). Proof. intros; apply compose_den_lift. Qed. @@ -239,7 +225,7 @@ Section Den. λ_den' >=> f ⩰ fun a => f (inr a). Proof. repeat intro. - unfold λ_den', compose_den, lift_den. + unfold λ_den', ITree.cat, lift_den. rewrite ret_bind_; reflexivity. Qed. @@ -248,19 +234,19 @@ Section Den. ρ_den' >=> f ⩰ fun a => f (inl a). Proof. repeat intro. - unfold ρ_den', compose_den, lift_den. + unfold ρ_den', ITree.cat, lift_den. rewrite ret_bind_; reflexivity. Qed. Lemma elim_ρ_den {A B: Type}: - forall (ab: @den E A (B + I)), ab >=> ρ_den ⩰ (fun a: A => ITree.map (sum_bimap sum_empty_r id) (ab a)). + forall (ab: @den E A (B + I)), ab >=> ρ_den ⩰ (fun a: A => ITree.map sum_empty_r (ab a)). Proof. intros; apply compose_den_lift. Qed. (** *** [tensor] lemmas *) - Instance eq_den_tensor {A B C D}: + Global Instance eq_den_tensor {A B C D}: Proper (eq_den ==> eq_den ==> eq_den) (@tensor_den A B C D). Proof. intros ac ac' eqac bd bd' eqbd. @@ -309,7 +295,7 @@ Section Den. sum_elim (ac >=> (sum_elim cf df)) (bc >=> (sum_elim cf df)). Proof. intros. - unfold compose_den. + unfold ITree.map. intros []; reflexivity. Qed. @@ -318,11 +304,9 @@ Section Den. lift_den inl >=> sum_elim ac bc ⩰ ac. Proof. intros. - unfold compose_den, lift_den. + unfold ITree.cat, lift_den. intros ?. - rewrite itree_eta. - rewrite ret_bind. - rewrite <- itree_eta. + rewrite ret_bind_. reflexivity. Qed. @@ -331,11 +315,9 @@ Section Den. lift_den inr >=> sum_elim ac bc ⩰ bc. Proof. intros. - unfold compose_den, lift_den. + unfold ITree.cat, lift_den. intros ?. - rewrite itree_eta. - rewrite ret_bind. - rewrite <- itree_eta. + rewrite ret_bind_. reflexivity. Qed. @@ -556,7 +538,6 @@ End Den. Bind Scope den_scope with den. Infix "⩰" := eq_den (at level 70). -Infix ">=>" := compose_den (at level 50, left associativity). Infix "⊗" := (tensor_den) (at level 30). Hint Rewrite @compose_den_assoc : lift_den. diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 7c5ba575..6942d599 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -101,6 +101,7 @@ Section Real_correctness. Context {E': Type -> Type}. Context {HasMemory: Memory -< E'}. + Context {HasExit: Exit -< E'}. Definition E := Locals +' E'. Definition interp_locals {R: Type} (t: itree E R) (s: alist var value): itree E' (alist var value * R) := @@ -489,16 +490,18 @@ Qed. (* YZ: Things get wonky once in the two subgoals. eq_den lemmas cannot be rewritten inside of terms anymore since it's specialized to a specific eutt *) Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : - eutt eq - (denote_asm (if_asm e tp fp) tt) - (denote_list e ;; + eq_den + (denote_asm (if_asm e tp fp)) + (fun _ => + denote_list e ;; v <- lift (GetVar tmp_if) ;; if v : value then denote_asm tp tt else denote_asm fp tt). Proof. unfold if_asm. - rewrite (seq_asm_correct _ _ tt). + rewrite seq_asm_correct. unfold cond_asm. - unfold compose_den; rewrite raw_asm_block_correct. + rewrite raw_asm_block_correct_lifted. + intros []; unfold ITree.cat at 1; simpl. rewrite after_correct. simpl. repeat setoid_rewrite bind_bind. @@ -506,77 +509,75 @@ Qed. apply eutt_bind; [reflexivity | intros []]. - rewrite ret_bind_. rewrite (relabel_asm_correct _ _ _ (inl tt)). - unfold compose_den; simpl. + unfold ITree.cat; simpl. rewrite bind_bind. unfold lift_den; rewrite ret_bind_. setoid_rewrite (app_asm_correct tp fp (inl tt)). setoid_rewrite bind_bind. rewrite <- (bind_ret (denote_asm tp tt)) at 2. - eapply eutt_bind; [reflexivity | intros []]. + eapply eutt_bind; [ reflexivity | intros ? ]. unfold lift_den; rewrite ret_bind_; reflexivity. - rewrite ret_bind_; reflexivity. - rewrite ret_bind_. rewrite (relabel_asm_correct _ _ _ (inr tt)). - unfold compose_den; simpl. + unfold ITree.cat; simpl. rewrite bind_bind. unfold lift_den; rewrite ret_bind_. setoid_rewrite (app_asm_correct tp fp (inr tt)). setoid_rewrite bind_bind. rewrite <- (bind_ret (denote_asm fp tt)) at 2. - eapply eutt_bind; [reflexivity | intros []]. + eapply eutt_bind; [reflexivity | intros ?]. unfold lift_den; rewrite ret_bind_; reflexivity. - rewrite ret_bind_; reflexivity. Qed. Lemma while_asm_correct (e : list instr) (p : asm unit unit) : - eutt eq (denote_asm (while_asm e p) tt) - (loop_den (fun l => - match l with - | inl tt => - denote_list e ;; - v <- lift (GetVar tmp_if) ;; - if v : value then - denote_asm p tt;; Ret (inl (inl tt)) - else - Ret (inl (inr tt)) - | inr tt => Ret (inl (inl tt)) - end) tt). + eq_den + (denote_asm (while_asm e p)) + (loop_den (fun l => + match l with + | inl tt => + denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then + denote_asm p tt;; Ret (inl tt) + else + Ret (inr tt) + | inr tt => Ret (inl tt) + end)). Proof. unfold while_asm. - rewrite (link_asm_correct _ tt). + rewrite link_asm_correct. apply eq_den_loop. rewrite relabel_asm_correct, id_den_left. - rewrite app_asm_correct. + rewrite app_asm_correct. + rewrite if_asm_correct. intros [[] |[]]. - - unfold compose_den. + - unfold ITree.cat. simpl; setoid_rewrite bind_bind. - rewrite if_asm_correct. rewrite bind_bind. apply eutt_bind; [reflexivity | intros []]. rewrite bind_bind. apply eutt_bind; [reflexivity | intros []]. + rewrite (relabel_asm_correct _ _ _ tt). - unfold compose_den. + unfold ITree.cat. simpl; repeat setoid_rewrite bind_bind. unfold lift_den; rewrite ret_bind_. - apply eutt_bind; [reflexivity | intros [[]|]]. - * repeat rewrite ret_bind_; reflexivity. - * repeat rewrite ret_bind_. - (* Buggy, to fix *) - admit. + apply eutt_bind; [reflexivity | intros []]. + repeat rewrite ret_bind_; reflexivity. + rewrite (pure_asm_correct _ tt). unfold lift_den. repeat rewrite ret_bind_. reflexivity. - Admitted. + - rewrite itree_eta; cbn; reflexivity. + Qed. +(* Global Instance subrelation_eq_den {E A B} : subrelation (@eq_den E A B) (pointwise_relation _ (eutt eq))%signature. Proof. Admitted. - +*) (* a trick to allow rewriting with eq_den *) -Definition ff (f : @den E unit unit) : itree E (unit + done) := f tt. +Definition ff (f : @den E unit unit) : itree E unit := f tt. Global Instance Proper_ff : Proper (eq_den ==> eutt eq) ff. Admitted. @@ -587,7 +588,7 @@ Proof. reflexivity. Qed. Lemma compile_correct: forall s (g_imp g_asm : alist var value), Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = inl (snd b)) + eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) (interp_locals (denote_asm (compile s) tt) g_asm) (interp_locals (denoteStmt s) g_imp). Proof. @@ -607,23 +608,26 @@ Proof. - (* Seq *) rewrite fold_ff; simpl. rewrite seq_asm_correct. unfold ff. - unfold compose_den. + unfold ITree.cat. rewrite 2 interp_locals_bind. eapply eutt_bind_gen. { auto. } intros. destruct H0. destruct (snd r2). rewrite H1. auto. - (* If *) - simpl; rewrite if_asm_correct. + rewrite fold_ff; simpl. + rewrite if_asm_correct. + unfold ff. rewrite 2 interp_locals_bind. eapply eutt_bind_gen. { apply compile_expr_correct. auto. } intros. admit. - (* While *) - simpl; rewrite while_asm_correct. rewrite fold_ff. + simpl; rewrite fold_ff. + rewrite while_asm_correct. (* TODO: Should use some loop_den lemmas to make the two loops - line up. *) + line up. *) admit. - (* Skip *) rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). From 4782591534a2bb5ec59ac426effe79508fd2b9a7 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 26 Feb 2019 08:45:21 -0500 Subject: [PATCH 100/142] app_asm_correct --- examples/AsmCombinators.v | 97 ++++++++++++++++++++++++++++----------- examples/Den.v | 69 +++++++++++++++++++++++++++- 2 files changed, 139 insertions(+), 27 deletions(-) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index 433dd606..24b79df6 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -309,6 +309,33 @@ Proof. destruct a; reflexivity. Qed. +Lemma foo_assoc_l {A B C D D'} (f : den _ D') : + @id_den E A ⊗ @assoc_den_l E B C D >=> (assoc_den_l >=> f) + ⩰ assoc_den_l >=> (assoc_den_l >=> (assoc_den_r ⊗ id_den >=> f)). +Proof. + rewrite <- !compose_den_assoc. + rewrite <- assoc_coherent_l. + rewrite (compose_den_assoc _ _ (_ ⊗ id_den)). + rewrite cat_tensor, id_den_left, assoc_lr, tensor_id. + rewrite id_den_right. + reflexivity. +Qed. + +Lemma foo_assoc_r {A' A B C D} (f : den A' _) : + f >=> assoc_den_r >=> @id_den E A ⊗ @assoc_den_r E B C D + ⩰ f >=> assoc_den_l ⊗ id_den >=> assoc_den_r >=> assoc_den_r. +Proof. + rewrite (compose_den_assoc _ _ assoc_den_r). + rewrite <- assoc_coherent_r. + rewrite (compose_den_assoc (tensor_den _ _)). + rewrite (compose_den_assoc _ (tensor_den _ _)). + rewrite <- (compose_den_assoc (tensor_den _ _)). + rewrite cat_tensor, id_den_left, assoc_lr, tensor_id. + rewrite id_den_left. + rewrite compose_den_assoc. + reflexivity. +Qed. + Set Nested Proofs Allowed. Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : @@ -325,31 +352,35 @@ Proof. rewrite <- loop_compose. rewrite loop_loop. subst lhs. - (* match goal with *) - (* | |- loop_den ?x ⩰ loop_den ?y => set (a := x) ; set (b := y) end. *) - - match goal with | |- _ ⩰ ?x => set (lhs := x) end. - simpl code. - cut ( - (denote_b - (fun l : internal ab + internal cd + (A + C) => - match l with - | inl (inl ia) => _app_B (code ab (inl ia)) - | inl (inr ic) => _app_D (code cd (inl ic)) - | inr (inl a) => _app_B (code ab (inr a)) - | inr (inr c) => _app_D (code cd (inr c)) - end)) ⩰ - (fun l : internal ab + internal cd + (A + C) => - match l with - | inl (inl ia) => denote_block (_app_B (code ab (inl ia))) - | inl (inr ic) => denote_block (_app_D (code cd (inl ic))) - | inr (inl a) => denote_block (_app_B (code ab (inr a))) - | inr (inr c) => denote_block (_app_D (code cd (inr c))) - end)); [intros EQ; rewrite EQ; clear EQ | intros [[]|[]]; reflexivity]. - -Admitted. - + rewrite <- (loop_rename_internal' sym_den sym_den) + by apply sym_nilpotent. + apply eq_den_loop. + rewrite ! compose_den_assoc. + unfold tensor_den, sym_den, ITree.cat, assoc_den_l, assoc_den_r, id_den, lift_den. + intros [[|]|[|]]; cbn. + (* ... *) + all: repeat (rewrite ret_bind_; simpl). + all: rewrite bind_bind. + all: unfold _app_B, _app_D. + all: rewrite fmap_block_map. + all: unfold ITree.map. + all: apply eutt_bind; try reflexivity. + all: intros []; rewrite (itree_eta (ITree.bind _ _)); cbn; reflexivity. +Qed. +Definition relabel_bks_correct {A B C D} (f : A -> B) (g : C -> D) + (bc : bks B C) : + @eq_den E _ _ + (denote_b (relabel_bks f g bc)) + (lift_den f >=> denote_b bc >=> lift_den g). +Proof. + rewrite lift_compose_den. + rewrite compose_den_lift. + intro a. + unfold denote_b, relabel_bks. + rewrite fmap_block_map. + reflexivity. +Qed. Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) (bc : asm B C) : @@ -357,13 +388,27 @@ Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) (denote_asm (relabel_asm f g bc)) (lift_den f >=> denote_asm bc >=> lift_den g). Proof. -Admitted. + unfold denote_asm. + simpl. + rewrite relabel_bks_correct. + rewrite <- compose_loop. + rewrite <- loop_compose. + apply eq_den_loop. + rewrite !tensor_id_lift. + reflexivity. +Qed. Definition link_asm_correct {I A B} (ab : asm (I + A) (I + B)) : @eq_den E _ _ (denote_asm (link_asm ab)) (loop_den (denote_asm ab)). Proof. -Admitted. + unfold denote_asm. + rewrite loop_loop. + apply eq_den_loop. + simpl. + rewrite relabel_bks_correct. + reflexivity. +Qed. End Correctness. diff --git a/examples/Den.v b/examples/Den.v index 139c6fcb..da9ecc0a 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -334,7 +334,7 @@ Section Den. reflexivity. Qed. - Lemma assoc_coherent {A B C D}: + Lemma assoc_coherent_r {A B C D}: @assoc_den_r A B C ⊗ @id_den D >=> assoc_den_r >=> id_den ⊗ assoc_den_r ⩰ assoc_den_r >=> assoc_den_r. Proof. @@ -349,6 +349,21 @@ Section Den. intros [[[|]|]|]; reflexivity. Qed. + Lemma assoc_coherent_l {A B C D}: + @id_den A ⊗ @assoc_den_l B C D >=> assoc_den_l >=> assoc_den_l ⊗ id_den ⩰ + assoc_den_l >=> assoc_den_l. + Proof. + unfold tensor_den, assoc_den_l. + repeat rewrite id_den_left. + repeat rewrite compose_sum_elim. + repeat rewrite compose_lift_den. + rewrite lift_sum_elim. + repeat rewrite compose_lift_den. + rewrite lift_sum_elim. + apply eq_lift_den. + intros [|[|[|]]]; reflexivity. + Qed. + (** *** [sym] lemmas *) Lemma sym_unit_den {A} : @@ -533,6 +548,58 @@ These two loops: (* Proof. *) (* Admitted. *) + (* TODO: Find the right place for these *) + + Lemma cat_tensor {A1 A2 A3 B1 B2 B3} + (f1 : @den E A1 A2) (f2 : den A2 A3) + (g1 : den B1 B2) (g2 : den B2 B3) : + (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩰ (f1 >=> f2) ⊗ (g1 >=> g2). + Proof. + unfold tensor_den, ITree.cat, lift_den; simpl. + intros []; simpl; + rewrite !bind_bind; setoid_rewrite ret_bind_; reflexivity. + Qed. + + Lemma assoc_lr {A B C} : + @assoc_den_l A B C >=> assoc_den_r ⩰ id_den. + Proof. + unfold assoc_den_l, assoc_den_r. + rewrite compose_lift_den. + intros [| []]; reflexivity. + Qed. + + Lemma assoc_rl {A B C} : + @assoc_den_r A B C >=> assoc_den_l ⩰ id_den. + Proof. + unfold assoc_den_l, assoc_den_r. + rewrite compose_lift_den. + intros [[]|]; reflexivity. + Qed. + + Lemma tensor_id {A B} : + id_den ⊗ id_den ⩰ @id_den (A + B). + Proof. + unfold tensor_den, ITree.cat, id_den. + intros []; cbn; rewrite ret_bind_; reflexivity. + Qed. + + Lemma loop_rename_internal' {I J A B} (ij : den I J) (ji: den J I) + (ab_: @den E (I + A) (I + B)) : + (ij >=> ji) ⩰ id_den -> + loop_den ((ji ⊗ id_den) >=> ab_ >=> (ij ⊗ id_den)) ⩰ + loop_den ab_. + Proof. + intros Hij. + rewrite loop_rename_internal. + rewrite <- compose_den_assoc. + rewrite cat_tensor. + rewrite Hij. + rewrite id_den_left. + rewrite tensor_id. + rewrite id_den_left. + reflexivity. + Qed. + End Laws. End Den. From 2ffb17fc81de700824f22af0ba8d519012805e05 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 26 Feb 2019 09:49:46 -0500 Subject: [PATCH 101/142] move Require out of sections. --- examples/Asm.v | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index db96825e..4a8e1932 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -1,11 +1,14 @@ From Coq Require Import Strings.String - Program.Basics. + Program.Basics + ZArith.ZArith. From ITree Require Import Basics_Functions. -Require Import ZArith. +From ExtLib Require Structures.Monad. +Require Import Imp. + Typeclasses eauto := 5. -Section Syntax. +Section Syntax. Definition var : Set := string. Definition value : Set := nat. (* this should change *) @@ -67,11 +70,11 @@ Section Semantics. (* Denotation in terms of itrees *) - Require Import ExtLib.Structures.Monad. + Import ExtLib.Structures.Monad. Import MonadNotation. Local Open Scope monad_scope. - Require Import Imp. + Import Imp. Inductive Memory : Type -> Type := | Load (addr : value) : Memory value @@ -154,7 +157,7 @@ End Semantics. (* SAZ: Everything from here down can probably be polished. In particular, I'm still not completely happy with how all the different parts - fit together in run. + fit together in run. *) From b99739be02cde5bf4dbfa9a5957cbae5a4fcbab3 Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Tue, 26 Feb 2019 10:10:35 -0500 Subject: [PATCH 102/142] cleanup ret_bind by using ret_bind_ --- examples/Factorial.v | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/examples/Factorial.v b/examples/Factorial.v index 11a8d4ce..26b21c43 100644 --- a/examples/Factorial.v +++ b/examples/Factorial.v @@ -59,9 +59,8 @@ Proof. cbn. rewrite tau_eutt. rewrite IHn. - rewrite itree_eta. - rewrite ret_bind. + rewrite ret_bind_. fold_bind. rewrite interp_bind. - rewrite interp_ret. rewrite ret_bind. + rewrite interp_ret. rewrite ret_bind_. rewrite interp_ret. reflexivity. Qed. \ No newline at end of file From 9f8acbd5c185a7522848fde1b087b701520ffb51 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 26 Feb 2019 10:34:17 -0500 Subject: [PATCH 103/142] generalizing Rhom. --- theories/MorphismsFacts.v | 108 ++++++++++++++++++++++---------------- 1 file changed, 62 insertions(+), 46 deletions(-) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 80bc3a7d..f5f6d75c 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -69,32 +69,48 @@ Proof. rewrite unfold_interp. reflexivity. Qed. (** ** [interp] properness *) -Instance eq_itree_interp {E F R} (f : E ~> itree F) : - Proper (eq_itree eq ==> eq_itree eq) (interp f R). -Proof. - repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros. - rewrite itree_eta, (itree_eta (interp f _ y)), !interp_unfold. - punfold H0; red in H0. - destruct H0; pclearbot. +(* todo(gmm): unify with eh_eq *) +Definition Rhom {E F : Type -> Type} (R : forall t, F t -> F t -> Prop) +: relation (E ~> F) := + fun f g => + forall X, pointwise_relation (E X) (R X) (f X) (g X). + +Instance eq_itree_interp {E F R}: + Proper (@Rhom E (itree F) (fun _ => eq_itree eq) ==> eq_itree eq ==> eq_itree eq) + (fun f => interp f R). +Proof. + intros f g Hfg. + intros l r Hlr. + pupto2_init. + revert l r Hlr. + pcofix CIH. + rename r into rr. + intros l r Hlr. + rewrite itree_eta, (itree_eta (interp g _ r)), !interp_unfold. + punfold Hlr; red in Hlr. + destruct Hlr; pclearbot. - pupto2_final. pfold. red. cbn. eauto. - pupto2_final. pfold. red. cbn. eauto. - pfold. econstructor. pupto2 (eq_itree_clo_bind F R). constructor. - + reflexivity. + + eapply Hfg. + eauto. intros; pupto2_final; right; eauto. Qed. -Definition Rhom {E F : Type -> Type} : relation (E ~> F) := - fun l r => - forall x (e : E x), l _ e = r _ e. +Global Instance Proper_interp_eq_itree {E F R f} +: Proper (eq_itree eq ==> eq_itree eq) (@interp E F f R). +Proof. + eapply eq_itree_interp. + red. reflexivity. +Qed. (* Note that this allows rewriting of handlers. *) -Instance eutt_interp : - forall (E F : Type -> Type) (R : Type), - Proper (@Rhom E (itree F) ==> eutt eq ==> eutt eq) - (fun f => interp f R). -Proof. Admitted. +Instance eutt_interp (E F : Type -> Type) (R : Type) : + Proper (@Rhom E (itree F) (fun _ => eutt eq) ==> eutt eq ==> eutt eq) + (fun f => interp f R). +Proof. + (* this is going to be a terrible proof. *) +Admitted. Lemma interp_ret : forall {E F R} x (f : E ~> itree F), @@ -136,7 +152,7 @@ Proof. {red. intros. apply ret_interp. } rewrite H. rewrite bind_ret. reflexivity. -Qed. +Qed. (** ** Composition of [interp] *) @@ -163,7 +179,7 @@ Proof. rewrite H. rewrite ret_bind_. (* TODO: Why does [ret_bind] not work at all. *) pupto2_final. right. apply CIH. -Qed. +Qed. Theorem interp_interp {E F G R} (f : E ~> itree F) (g : F ~> itree G) : @@ -186,16 +202,16 @@ Proof. - rewrite interp_bind. pfold. econstructor. pupto2 eq_itree_clo_bind_h. - apply pbc_intro_h with (RU := eq). + apply pbc_intro_h with (RU := eq). + reflexivity. + intros. pupto2_final. right. subst. apply CIH. -Qed. - +Qed. + (** * [interp1] *) (* SAZ: If we need to introduce these auxilliar definitions to prove - properties about functions like interp1, I think that we shoul + properties about functions like interp1, I think that we should _define_ interp1 in terms of its unfolding. I have experimented with porting interp_state and interp1_state to this form. *) @@ -263,7 +279,7 @@ Proof. eapply (CIH' (go x2) (go x3)); eauto. - rewrite !unfold_bind. fold_bind. genobs t ot. clear Heqot t. - destruct ot; simpl; eauto 10. + destruct ot; simpl; eauto 10. pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. eapply upaco2_mon; eauto. intros. eapply (CIH' (go x2) (go x3)); eauto. @@ -304,7 +320,7 @@ Lemma unfold_interp_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F) Proof. intros E F S R h t s. econstructor. -Qed. +Qed. Instance eq_itree_interp_state {E F S R} (h : E ~> Monads.stateT S (itree F)) : @@ -312,7 +328,7 @@ Instance eq_itree_interp_state {E F S R} (h : E ~> Monads.stateT S (itree F)) : (interp_state h R). Proof. repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros h x y H0 x2 y0 H1. + pcofix CIH. intros h x y H0 x2 y0 H1. rewrite itree_eta, (itree_eta (interp_state h _ y y0)), !unfold_interp_state. unfold interp_state_match. punfold H0; red in H0. @@ -330,32 +346,32 @@ Lemma unfold_interp1_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F observe (interp1_state h _ t s) = observe (interp1_state_match h (interp1_state h R) t s). Proof. - intros E F S R h t s. + intros E F S R h t s. econstructor. -Qed. +Qed. Instance eq_itree_interp1_state {E F S R} (h : E ~> Monads.stateT S (itree F)) : Proper (eq_itree eq ==> eq ==> eq_itree eq) (interp1_state h R). Proof. repeat intro. pupto2_init. revert_until R. - pcofix CIH. intros h x y H0 x2 y0 H1. + pcofix CIH. intros h x y H0 x2 y0 H1. rewrite itree_eta, (itree_eta (interp1_state h _ y y0)), !unfold_interp1_state. unfold interp1_state_match. punfold H0; red in H0. - genobs x ox; destruct ox; simpobs; dependent destruction H0; simpobs; pclearbot. + genobs x ox; destruct ox; simpobs; dependent destruction H0; simpobs; pclearbot. - pupto2_final. pfold. red. cbn. subst. eauto. - pupto2_final. pfold. red. cbn. subst. eauto. - pfold. destruct e. * econstructor. pupto2 (eq_itree_clo_bind F (S * R)). - constructor. + constructor. + subst. reflexivity. + intros. pupto2_final. right. eauto. * econstructor. intros. pupto2_final. right. eauto. Qed. - + Lemma interp_state_ret {E F : Type -> Type} {R S : Type} (f : forall T, E T -> S -> itree F (S * T)%type) @@ -406,7 +422,7 @@ Lemma interp_state_tau : forall {E F:Type -> Type} S {T : Type} (t:itree E T) (s (h : E ~> Monads.stateT S (itree F)), interp_state h _ (Tau t) s ≅ Tau (interp_state h _ t s). Proof. - intros E F S T t s h. + intros E F S T t s h. rewrite itree_eta. reflexivity. Qed. @@ -414,7 +430,7 @@ Lemma interp1_state_tau : forall {E F:Type -> Type} S {T : Type} (t:itree (E +' (h : E ~> Monads.stateT S (itree F)), interp1_state h _ (Tau t) s ≅ Tau (interp1_state h _ t s). Proof. - intros E F S T t s h. + intros E F S T t s h. rewrite itree_eta. reflexivity. Qed. @@ -423,7 +439,7 @@ Lemma interp_state_liftE {E F : Type -> Type} {R S : Type} (s : S) (e : E R) : (interp_state f _ (ITree.liftE e) s) ≅ Tau (f _ e s). Proof. - unfold ITree.liftE. rewrite interp_state_vis. + unfold ITree.liftE. rewrite interp_state_vis. assert (pointwise_relation _ (eq_itree eq) (fun sx : S * R => interp_state f R (Ret (snd sx)) (fst sx)) (fun sx => Ret sx)). { intros sx. destruct sx. simpl. rewrite itree_eta. cbn. reflexivity. } @@ -437,7 +453,7 @@ Lemma interp1_state_liftE1 {E F : Type -> Type} {R S : Type} (s : S) (e : E R) : (interp1_state f _ (ITree.liftE (inl1 e)) s) ≅ Tau (f _ e s). Proof. - unfold ITree.liftE. rewrite interp1_state_vis1. + unfold ITree.liftE. rewrite interp1_state_vis1. assert (pointwise_relation _ (eq_itree eq) (fun sx : S * R => interp1_state f R (Ret (snd sx)) (fst sx)) (fun sx => Ret sx)). { intros sx. destruct sx. simpl. rewrite itree_eta. cbn. reflexivity. } @@ -481,7 +497,7 @@ Proof. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. + intros. specialize (CIH _ (k0 (snd v)) k (fst v)). auto. -Qed. +Qed. Lemma interp1_state_bind {E F : Type -> Type} {A B S : Type} (f : forall T, E T -> S -> itree F (S * T)%type) @@ -570,7 +586,7 @@ Proof. { reflexivity. } rewrite H. unfold ITree.liftE in CIH. - rewrite <- itree_eta. + rewrite <- itree_eta. pupto2_final. right. apply CIH. Qed. @@ -585,7 +601,7 @@ Notation "f ≡ g" := (eh_eq f g) (at level 70). Lemma eh_compose_id_left_strong : forall A R (t : itree A R), interp eh_id R t ≈ t. Proof. - intros A R. + intros A R. intros t. pupto2_init. revert t. @@ -600,20 +616,20 @@ Proof. - pfold. econstructor. right. rewrite interp_unfold. unfold interp_u. unfold handleF. apply CIH'. - - pfold. econstructor. cbn. econstructor. intros. + - pfold. econstructor. cbn. econstructor. intros. assert (ITree.bind' (fun x0 : u => interp eh_id R (k x0)) (Ret x) = (x0 <- Ret x ;; interp eh_id R (k x0))). { intros; reflexivity. } rewrite H. rewrite ret_bind_. (* TODO: [ret_bind] doesn't work *) pupto2_final. right. apply CIH. -Qed. - +Qed. + Lemma eh_compose_id_left : forall A B (f : A ~> itree B), eh_compose eh_id f ≡ f. Proof. intros A B f X e. unfold eh_compose. apply eh_compose_id_left_strong. -Qed. +Qed. Lemma eh_compose_id_right : @@ -629,8 +645,8 @@ Proof. { red. intros. apply interp_ret. } rewrite H. rewrite bind_ret. reflexivity. -Qed. - +Qed. + Lemma eh_both_left_right_id : forall A B X e, eh_both eh_left eh_right X e = (@eh_id (A +' B)) X e. Proof. intros A B X e. @@ -673,7 +689,7 @@ Proof. rewrite itree_eta. unfold_bind. cbn. reflexivity. Qed. - + Lemma eh_swap_swap_id : forall A B, eh_compose eh_swap eh_swap ≡ (eh_id : (A +' B) ~> itree (A +' B)). Proof. intros A B X e. From 24b8eab404abb61106c0808696caa910797729d3 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 26 Feb 2019 11:03:28 -0500 Subject: [PATCH 104/142] converting some (eq ==> ..) to `pointwise_relation _ ..` --- theories/FixFacts.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/theories/FixFacts.v b/theories/FixFacts.v index f8566a06..b3db4b3f 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -198,7 +198,7 @@ Proof. unfold interp_match. unfold mrec. eapply eutt_interp. - { red. destruct e; try reflexivity. + { red. intro. red. destruct a; try reflexivity. destruct c. reflexivity. } reflexivity. @@ -637,7 +637,7 @@ Qed. End eutt_loop. Instance sutt_loop {E A B C} : - Proper ((eq ==> sutt eq) ==> eq ==> sutt eq) (@loop E A B C). + Proper (pointwise_relation _ (sutt eq) ==> eq ==> sutt eq) (@loop E A B C). Proof. repeat intro; subst. apply sutt_is_sutt1. @@ -647,7 +647,7 @@ Proof. Qed. Instance eutt_loop {E A B C} : - Proper ((eq ==> eutt eq) ==> eq ==> eutt eq) (@loop E A B C). + Proper (pointwise_relation _ (eutt eq) ==> eq ==> eutt eq) (@loop E A B C). Proof. repeat intro; subst. repeat red in H. From 4c2684ad68d19081624adf0d18cf73809db0bf11 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 26 Feb 2019 11:22:00 -0500 Subject: [PATCH 105/142] unifying Rhom and eh_eq (adding eh_eutt) --- theories/Morphisms.v | 12 ++++++------ theories/MorphismsFacts.v | 34 ++++++++++++++++++++-------------- 2 files changed, 26 insertions(+), 20 deletions(-) diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 5264ae83..702ec045 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -51,16 +51,16 @@ A Monad Transformer MT is given by: such that: Monad (MT m) - lift o return = return - lift o (bind t1 k) = + lift o return = return + lift o (bind t1 k) = EXAMPLE: stateT S m a := S -> m (S * a) lift : m `{Monad m} {a}, fun (c: m a) (s:S) => y <- c ;; ret (s, y) -operations +operations get : m `{Monad m} stateT S m S := fun s => ret_m (s, s) - put : m `{Monad m}, S -> stateT S m unit := fun s' => fun s => ret_m (s', tt) + put : m `{Monad m}, S -> stateT S m unit := fun s' => fun s => ret_m (s', tt) (* category *) id : A ~> MT (itree A) @@ -230,7 +230,7 @@ Definition interp_state_match {E F S R} (h : E ~> stateT S (itree F)) fun s => match t.(observe) with | RetF r => Ret (s, r) - | VisF e k => + | VisF e k => Tau (ITree.bind (h _ e s) (fun sx => rec (k (snd sx)) (fst sx))) | TauF t => Tau (rec t s) @@ -261,7 +261,7 @@ Definition interp1_state_match {E F S R} (h : E ~> stateT S (itree F)) CoFixpoint interp1_state {E F S} (h : E ~> stateT S (itree F)) : itree (E +' F) ~> stateT S (itree F) := fun R => interp1_state_match h (interp1_state h R). - + Definition translate1_state {E F S} (h : E ~> state S) : itree (E +' F) ~> stateT S (itree F) := diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index f5f6d75c..20355ba0 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -17,6 +17,22 @@ From ITree Require Import Eq.UpToTaus TranslateFacts. +(** * Morphism equivalence *) +Definition Rhom {A B : Type -> Type} (R : forall t, B t -> B t -> Prop) + (f g : A ~> B) : Prop := + forall X, pointwise_relation (A X) (R X) (f X) (g X). + +Definition eh_eq {A B : Type -> Type} +: (A ~> itree B) -> (A ~> itree B) -> Prop := + Rhom (fun t => @eq_itree B _ t eq). + +Definition eh_eutt {A B : Type -> Type} +: (A ~> itree B) -> (A ~> itree B) -> Prop := + Rhom (fun t => @eutt B _ t eq). + +Notation "f ≡ g" := (eh_eutt f g) (at level 70). + + (** * [interp] *) (* Proof of @@ -68,16 +84,9 @@ Lemma vis_interp {E F R} {f : E ~> itree F} U (e: E U) (k: U -> itree E R) : Proof. rewrite unfold_interp. reflexivity. Qed. (** ** [interp] properness *) - -(* todo(gmm): unify with eh_eq *) -Definition Rhom {E F : Type -> Type} (R : forall t, F t -> F t -> Prop) -: relation (E ~> F) := - fun f g => - forall X, pointwise_relation (E X) (R X) (f X) (g X). - Instance eq_itree_interp {E F R}: - Proper (@Rhom E (itree F) (fun _ => eq_itree eq) ==> eq_itree eq ==> eq_itree eq) - (fun f => interp f R). + Proper (Rhom (fun _ => eq_itree eq) ==> eq_itree eq ==> eq_itree eq) + (fun f => @interp E F f R). Proof. intros f g Hfg. intros l r Hlr. @@ -106,8 +115,8 @@ Qed. (* Note that this allows rewriting of handlers. *) Instance eutt_interp (E F : Type -> Type) (R : Type) : - Proper (@Rhom E (itree F) (fun _ => eutt eq) ==> eutt eq ==> eutt eq) - (fun f => interp f R). + Proper (Rhom (fun _ => eutt eq) ==> eutt eq ==> eutt eq) + (fun f => @interp E F f R). Proof. (* this is going to be a terrible proof. *) Admitted. @@ -593,9 +602,6 @@ Qed. (* Morphism Category -------------------------------------------------------- *) -Definition eh_eq {A B : Type -> Type} f g := forall X, pointwise_relation (A X) (@eutt B X _ (@eq X)) (f X) (g X). - -Notation "f ≡ g" := (eh_eq f g) (at level 70). Lemma eh_compose_id_left_strong : From adb0a8f877162a217fdaece07f84d174a773bd7e Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 26 Feb 2019 11:30:23 -0500 Subject: [PATCH 106/142] a bit of cleanup in Imp2AsmCorrectness --- examples/Imp2AsmCorrectness.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 6942d599..3d188f9b 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -64,15 +64,14 @@ End Correctness. Section EUTT. - Require Import Paco.paco. - Context {E: Type -> Type}. Instance eq_itree_run_env {E R} {K V map} {Mmap: Maps.Map K V map}: Proper (@eutt (envE K V +' E) R R eq ==> eq ==> @eutt E (prod map R) (prod map R) eq) (run_env R). Proof. - Admitted. + eapply MorphismsFacts.eutt_interp_state. + Qed. End EUTT. @@ -104,7 +103,8 @@ Section Real_correctness. Context {HasExit: Exit -< E'}. Definition E := Locals +' E'. - Definition interp_locals {R: Type} (t: itree E R) (s: alist var value): itree E' (alist var value * R) := + Definition interp_locals {R: Type} (t: itree E R) (s: alist var value) + : itree E' (alist var value * R) := run_env _ (interp1 evalLocals _ t) s. Instance eq_itree_interp_locals {R}: From fcf50ca0652c8d4f236cb80ad34abb11523f478d Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Tue, 26 Feb 2019 11:32:03 -0500 Subject: [PATCH 107/142] emptyE handler and some facts about it --- theories/Morphisms.v | 12 ++++++- theories/MorphismsFacts.v | 74 ++++++++++++++++++++++++++------------- 2 files changed, 60 insertions(+), 26 deletions(-) diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 5264ae83..12205f22 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -184,7 +184,7 @@ Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : (* Morphism Category -------------------------------------------------------- *) -Definition eh_compose {A B C} (g : B ~> itree C) (f : A ~> itree B) : +Definition eh_cmp {A B C} (g : B ~> itree C) (f : A ~> itree B) : A ~> itree C := fun _ e => interp g _ (f _ e). @@ -213,6 +213,16 @@ Definition eh_right {A B} : B ~> itree (A +' B) := Definition eh_swap {A B} : A +' B ~> itree (B +' A) := eh_both eh_right eh_left. +Definition eh_empty {A} : emptyE ~> itree A := + fun _ e => match e with end. + +Definition eh_empty_l {B} : emptyE +' B ~> itree B := + eh_both eh_empty eh_id. + +Definition eh_empty_r {A} : A +' emptyE ~> itree A := + eh_both eh_id eh_empty. + + (** Standard interpreters *) Import ITree.Basics.Monads. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 80bc3a7d..7ffd3d8a 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -582,7 +582,7 @@ Definition eh_eq {A B : Type -> Type} f g := forall X, pointwise_relation (A X) Notation "f ≡ g" := (eh_eq f g) (at level 70). -Lemma eh_compose_id_left_strong : +Lemma eh_cmp_id_left_strong : forall A R (t : itree A R), interp eh_id R t ≈ t. Proof. intros A R. @@ -608,19 +608,19 @@ Proof. Qed. -Lemma eh_compose_id_left : - forall A B (f : A ~> itree B), eh_compose eh_id f ≡ f. +Lemma eh_cmp_id_left : + forall A B (f : A ~> itree B), eh_cmp eh_id f ≡ f. Proof. intros A B f X e. - unfold eh_compose. apply eh_compose_id_left_strong. + unfold eh_cmp. apply eh_cmp_id_left_strong. Qed. -Lemma eh_compose_id_right : - forall A B (f : A ~> itree B), eh_compose f eh_id ≡ f. +Lemma eh_cmp_id_right : + forall A B (f : A ~> itree B), eh_cmp f eh_id ≡ f. Proof. intros B A f X e. - unfold eh_compose. + unfold eh_cmp. unfold eh_id. unfold ITree.liftE. rewrite unfold_interp. unfold interp_u. unfold handleF. @@ -641,11 +641,11 @@ Proof. - unfold eh_right. reflexivity. Qed. -Lemma eh_compose_assoc : forall A B C D (h : C ~> itree D) (g : B ~> itree C) (f : A ~> itree B), - eh_compose h (eh_compose g f) ≡ (eh_compose (eh_compose h g) f). +Lemma eh_cmp_assoc : forall A B C D (h : C ~> itree D) (g : B ~> itree C) (f : A ~> itree B), + eh_cmp h (eh_cmp g f) ≡ (eh_cmp (eh_cmp h g) f). Proof. intros A B C D h g f X e. - unfold eh_compose. rewrite interp_interp. reflexivity. + unfold eh_cmp. rewrite interp_interp. reflexivity. Qed. Lemma eh_par_id : forall A B, eh_par eh_id eh_id ≡ (@eh_id (A +' B)). @@ -665,36 +665,60 @@ Proof. { intros x. rewrite translate_ret. reflexivity. } rewrite H. reflexivity. Qed. - -Lemma bind_vis : forall {E R S T} e (k1 : R -> itree E S) (k2 : S -> itree E T), - (x <- (Vis e k1) ;; k2 x) ≅ Vis e (fun y => x <- (k1 y) ;; k2 x). -Proof. - intros E R S T e k1 k2. - rewrite itree_eta. - unfold_bind. cbn. reflexivity. -Qed. -Lemma eh_swap_swap_id : forall A B, eh_compose eh_swap eh_swap ≡ (eh_id : (A +' B) ~> itree (A +' B)). +Lemma eh_swap_swap_id : forall A B, eh_cmp eh_swap eh_swap ≡ (eh_id : (A +' B) ~> itree (A +' B)). Proof. intros A B X e. - unfold eh_compose. unfold eh_swap. + unfold eh_cmp. unfold eh_swap. rewrite unfold_interp. unfold interp_u. unfold handleF. unfold eh_both. destruct e; cbn. - eapply transitivity. apply tau_eutt. unfold eh_left. - rewrite bind_vis. + rewrite vis_bind_. unfold eh_id. unfold ITree.liftE. apply eutt_Vis. - intros x. + intros x. rewrite itree_eta. cbn. reflexivity. - eapply transitivity. apply tau_eutt. unfold eh_right. - rewrite bind_vis. + rewrite vis_bind_. unfold eh_id. unfold ITree.liftE. apply eutt_Vis. - intros x. + intros x. rewrite itree_eta. cbn. reflexivity. -Qed. \ No newline at end of file +Qed. + +Lemma eh_empty_unit_l : forall A, eh_cmp eh_empty_r eh_left ≡ (eh_id : A ~> itree A). +Proof. + intros A X e. + unfold eh_cmp. + unfold eh_empty_r. + unfold eh_both. unfold eh_left. + rewrite vis_interp. + rewrite tau_eutt. + assert (pointwise_relation _ (@eq_itree _ _ _ eq) (fun x => interp (fun (T : Type) (e0 : (A +' emptyE) T) => match e0 with + | inl1 e1 => eh_id T e1 + | inr1 e2 => eh_empty T e2 + end) X (Ret x)) (fun x => Ret x)). + { intros x. rewrite interp_ret. reflexivity. } + rewrite H. rewrite bind_ret. reflexivity. +Qed. + +Lemma eh_empty_unit_r : forall A, eh_cmp eh_empty_l eh_right ≡ (eh_id : A ~> itree A). +Proof. + intros A X e. + unfold eh_cmp. + unfold eh_empty_l. + unfold eh_both. unfold eh_right. + rewrite vis_interp. + rewrite tau_eutt. + assert (pointwise_relation _ (@eq_itree _ _ _ eq) (fun x => interp (fun (T : Type) (e0 : (emptyE +' A) T) => match e0 with + | inl1 e1 => eh_empty T e1 + | inr1 e2 => eh_id T e2 + end) X (Ret x)) (fun x => Ret x)). + { intros x. rewrite interp_ret. reflexivity. } + rewrite H. rewrite bind_ret. reflexivity. +Qed. From 321e72658cd38ed71a08259a49ad1920059e03ec Mon Sep 17 00:00:00 2001 From: Steve Zdancewic Date: Tue, 26 Feb 2019 12:17:13 -0500 Subject: [PATCH 108/142] clean up eh proofs by properly lifting them from event morphisms, probably still missing a few --- theories/Morphisms.v | 30 +++++++++++------- theories/MorphismsFacts.v | 65 ++++++++++++--------------------------- 2 files changed, 39 insertions(+), 56 deletions(-) diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 7fbe8363..4890d1ac 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -204,23 +204,31 @@ Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) : (A +' C) ~> i | inr1 e2 => g _ e2 end. -Definition eh_left {A B} : A ~> itree (A +' B) := - fun _ e => Vis (inl1 e) (fun x => Ret x). +Definition eh_lift {A B} (m : A ~> B) : A ~> itree B := + fun _ e => ITree.liftE (m _ e). -Definition eh_right {A B} : B ~> itree (A +' B) := - fun _ e => Vis (inr1 e) (fun x => Ret x). +Definition eh_inl {A B} : A ~> itree (A +' B) := + eh_lift (fun _ e => inl1 e). + +Definition eh_inr {A B} : B ~> itree (A +' B) := + eh_lift (fun _ e => inr1 e). Definition eh_swap {A B} : A +' B ~> itree (B +' A) := - eh_both eh_right eh_left. + eh_lift Sum1.swap. + +Definition eh_elim_empty {A} : emptyE ~> itree A := + eh_lift Sum1.elim_emptyE. -Definition eh_empty {A} : emptyE ~> itree A := - fun _ e => match e with end. +Definition eh_empty_left {B} : emptyE +' B ~> itree B := + eh_lift Sum1.emptyE_left. -Definition eh_empty_l {B} : emptyE +' B ~> itree B := - eh_both eh_empty eh_id. +Definition eh_empty_right {A} : A +' emptyE ~> itree A := + eh_lift Sum1.emptyE_right. -Definition eh_empty_r {A} : A +' emptyE ~> itree A := - eh_both eh_id eh_empty. +(* SAZ: do we need the assoc2 too -- add to Sum.v ? *) +Definition eh_assoc {A B C} : (A +' (B +' C)) ~> itree ((A +' B) +' C) := + eh_lift Sum1.assoc. + (** Standard interpreters *) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 0191e73e..b1df7fea 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -653,14 +653,14 @@ Proof. reflexivity. Qed. -Lemma eh_both_left_right_id : forall A B X e, eh_both eh_left eh_right X e = (@eh_id (A +' B)) X e. +Lemma eh_both_left_right_id : forall A B X e, eh_both eh_inl eh_inr X e = (@eh_id (A +' B)) X e. Proof. intros A B X e. unfold eh_both. unfold eh_id. unfold ITree.liftE. destruct e. - - unfold eh_left. reflexivity. - - unfold eh_right. reflexivity. + - unfold eh_inl. reflexivity. + - unfold eh_inr. reflexivity. Qed. Lemma eh_cmp_assoc : forall A B C D (h : C ~> itree D) (g : B ~> itree C) (f : A ~> itree B), @@ -692,56 +692,31 @@ Qed. Lemma eh_swap_swap_id : forall A B, eh_cmp eh_swap eh_swap ≡ (eh_id : (A +' B) ~> itree (A +' B)). Proof. intros A B X e. - unfold eh_cmp. unfold eh_swap. - rewrite unfold_interp. unfold interp_u. - unfold handleF. - unfold eh_both. destruct e; cbn. - - eapply transitivity. apply tau_eutt. - unfold eh_left. - rewrite vis_bind_. - unfold eh_id. unfold ITree.liftE. - apply eutt_Vis. - intros x. - rewrite itree_eta. cbn. - reflexivity. - - eapply transitivity. apply tau_eutt. - unfold eh_right. - rewrite vis_bind_. - unfold eh_id. unfold ITree.liftE. - apply eutt_Vis. - intros x. - rewrite itree_eta. cbn. - reflexivity. -Qed. - -Lemma eh_empty_unit_l : forall A, eh_cmp eh_empty_r eh_left ≡ (eh_id : A ~> itree A). + unfold eh_cmp. unfold eh_swap. unfold eh_lift. + rewrite interp_liftE. rewrite tau_eutt. destruct e; simpl; reflexivity. +Qed. + +Lemma eh_empty_unit_l : forall A, eh_cmp eh_empty_right eh_inl ≡ (eh_id : A ~> itree A). Proof. intros A X e. unfold eh_cmp. - unfold eh_empty_r. - unfold eh_both. unfold eh_left. - rewrite vis_interp. + unfold eh_empty_right. + unfold eh_inl. + unfold eh_lift. + rewrite interp_liftE. rewrite tau_eutt. - assert (pointwise_relation _ (@eq_itree _ _ _ eq) (fun x => interp (fun (T : Type) (e0 : (A +' emptyE) T) => match e0 with - | inl1 e1 => eh_id T e1 - | inr1 e2 => eh_empty T e2 - end) X (Ret x)) (fun x => Ret x)). - { intros x. rewrite interp_ret. reflexivity. } - rewrite H. rewrite bind_ret. reflexivity. + simpl. unfold Sum1.idE. reflexivity. Qed. -Lemma eh_empty_unit_r : forall A, eh_cmp eh_empty_l eh_right ≡ (eh_id : A ~> itree A). +Lemma eh_empty_unit_r : forall A, eh_cmp eh_empty_left eh_inr ≡ (eh_id : A ~> itree A). Proof. intros A X e. unfold eh_cmp. - unfold eh_empty_l. - unfold eh_both. unfold eh_right. - rewrite vis_interp. + unfold eh_empty_left. + unfold eh_inr. + unfold eh_lift. + rewrite interp_liftE. rewrite tau_eutt. - assert (pointwise_relation _ (@eq_itree _ _ _ eq) (fun x => interp (fun (T : Type) (e0 : (emptyE +' A) T) => match e0 with - | inl1 e1 => eh_empty T e1 - | inr1 e2 => eh_id T e2 - end) X (Ret x)) (fun x => Ret x)). - { intros x. rewrite interp_ret. reflexivity. } - rewrite H. rewrite bind_ret. reflexivity. + simpl. unfold Sum1.idE. reflexivity. Qed. + From 87e34e1298c5b3f6d9e590c05d72ba9981631e6d Mon Sep 17 00:00:00 2001 From: Paul He Date: Tue, 26 Feb 2019 12:55:31 -0500 Subject: [PATCH 109/142] Proved equivalence of (sutt eq) and trace_incl --- theories/Eq/UpToTaus.v | 4 +- theories/Trace.v | 147 ++++++++++++++++++++++++++--------------- 2 files changed, 95 insertions(+), 56 deletions(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index ddc4bfd0..db328429 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -769,7 +769,7 @@ Proof. - simpobs. rewrite finite_taus_tau. reflexivity. - intros t1' t2' H1 H2. eapply unalltaus_tau in H1; eauto. - assert (X := unalltaus_injective _ _ _ H1 H2). + pose proof (unalltaus_injective _ _ _ H1 H2). subst; apply Reflexive_eq_notauF; eauto. left. apply reflexivity. Qed. @@ -892,7 +892,7 @@ Lemma eutt_tau {E R1 R2} (RR : R1 -> R2 -> Prop) (t1 : itree E R1) (t2 : itree E R2) : eutt RR t1 t2 -> eutt RR (Tau t1) (Tau t2). Proof. - intros H. + intros H. pfold. eapply euttF_tau. reflexivity. reflexivity. punfold H. Qed. diff --git a/theories/Trace.v b/theories/Trace.v index ae809502..bc59a611 100644 --- a/theories/Trace.v +++ b/theories/Trace.v @@ -6,12 +6,16 @@ Import ListNotations. From ITree Require Import Core - Eq.UpToTaus. + Eq.UpToTaus + Eq.SimUpToTaus. + Local Open Scope itree. From Paco Require Import paco. +(* TODO: Add different return types, as in eutt and sutt *) + Inductive event (E : Type -> Type) : Type := | Event : forall X, E X -> X -> event E (* An effect without any response from the context (e.g. if X is uninhabited) *) @@ -110,8 +114,42 @@ Lemma is_trace_unalltaus_add: forall {E R} (t1 t2 : itree E R) tr r, is_trace t1 tr r. Proof. intros. eapply is_traceF_unalltaus_add; eauto. Qed. -Lemma eutt_trace_incl : forall {E R} (t1 t2 : itree E R), - t1 ≈ t2 -> trace_incl t1 t2. +Lemma is_trace_tau : forall {E R} (t : itree E R) tr r, + is_trace t tr r <-> + is_trace (Tau t) tr r. +Proof. + intros. split; intros. + - constructor. unfold is_trace in *. remember (observe t). + generalize dependent t. + induction H; intros; subst; constructor; eapply IHis_traceF; auto. + - inversion H; subst; try constructor; auto. +Qed. + +Lemma tauF_sutt_eq : forall {E R} (t1 t2 t : itree E R), + sutt eq t1 t2 -> + TauF t = observe t1 -> + sutt eq t t2. +Proof. + intros. pinversion H. pfold. constructor; simpobs. + - intros. apply FIN. rewrite finite_taus_tau. assumption. + - intros t1' t2' H1 H2. + apply EQV; auto. + eapply unalltaus_tau'; auto. +Qed. + +Lemma suttF_tau_right {E R} r (t1 t2 t2' : itree E R) + (OBS: TauF t2 = observe t2') + (REL: sutt_ eq r t1 t2'): + sutt_ eq r t1 t2. +Proof. + intros. destruct REL. constructor. + - intros. apply FIN in H. simpobs. rewrite <- finite_taus_tau. auto. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. + econstructor; eauto. +Qed. + +Lemma sutt_trace_incl : forall {E R} (t1 t2 : itree E R), + sutt eq t1 t2 -> trace_incl t1 t2. Proof. red. intros. red in H0. remember (observe t1). generalize dependent t1. generalize dependent t2. @@ -122,23 +160,22 @@ Proof. rewrite Heqi. constructor; auto. red. rewrite <- Heqi. auto. } assert (FIN2: finite_tausF (observe t1)) by (eexists; apply Hunall). - rewrite FIN in FIN2. inv FIN2. + apply FIN in FIN2. inv FIN2. specialize (EQV _ _ Hunall H0). inv EQV. red. eapply is_trace_unalltaus_add. + simpobs. auto. + red. rewrite <- Heqi. constructor. - apply IHis_traceF with (t1:=t); auto. - rewrite <- H. symmetry. apply tauF_eutt. assumption. + eapply tauF_sutt_eq; eauto. - pinversion H. assert (Hunall: unalltausF (observe t1) (VisF e k)). { rewrite Heqi. constructor; auto. red. rewrite <- Heqi. auto. } assert (FIN2: finite_tausF (observe t1)) by (eexists; apply Hunall). - rewrite FIN in FIN2. inv FIN2. + apply FIN in FIN2. inv FIN2. specialize (EQV _ _ Hunall H1). inv EQV. invert_existTs. inv H1. specialize (H6 x). - red. remember (VisF _ _) in H2. remember (observe t2). generalize dependent t2. induction H2; intros; subst. @@ -146,43 +183,23 @@ Proof. pfold. inversion H6. pinversion H1. inversion H1. + constructor. eapply IHuntausF; auto. - * rewrite FIN. apply finite_taus_tau; auto. - * eapply euttF_tau_right; eauto. + * intros. apply finite_taus_tau; auto. + * eapply suttF_tau_right; eauto. - pinversion H. assert (Hunall: unalltausF (observe t1) (VisF e k)). { rewrite Heqi. constructor; auto. red. rewrite <- Heqi. auto. } assert (FIN2: finite_tausF (observe t1)) by (eexists; apply Hunall). - rewrite FIN in FIN2. inv FIN2. + apply FIN in FIN2. inv FIN2. specialize (EQV _ _ Hunall H0). inv EQV. invert_existTs. inv H0. - red. remember (VisF _ _) in H1. remember (observe t2). generalize dependent t2. induction H1; intros; subst; constructor. eapply IHuntausF; auto. - + rewrite FIN. apply finite_taus_tau; auto. - + eapply euttF_tau_right; eauto. -Qed. - -Lemma eutt_trace_eq : forall {E R} (t1 t2 : itree E R), - t1 ≈ t2 -> trace_eq t1 t2. -Proof. - split. - - apply eutt_trace_incl; auto. - - symmetry in H. apply eutt_trace_incl; auto. -Qed. - -Lemma is_trace_tau : forall {E R} (t : itree E R) tr r, - is_trace t tr r <-> - is_trace (Tau t) tr r. -Proof. - intros. split; intros. - - constructor. unfold is_trace in *. remember (observe t). - generalize dependent t. - induction H; intros; subst; constructor; eapply IHis_traceF; auto. - - inversion H; subst; try constructor; auto. + + intros. apply finite_taus_tau; auto. + + eapply suttF_tau_right; eauto. Qed. Lemma trace_incl_finite_taus : forall {E R} (t1 t2 : itree E R), @@ -212,38 +229,60 @@ Proof. intros. apply H. red. rewrite <- Heqi. apply is_trace_tau; auto. Qed. -Lemma trace_eq_eutt : forall {E R} (t1 t2 : itree E R), - trace_eq t1 t2 -> t1 ≈ t2. +Lemma trace_incl_sutt : forall {E R} (t1 t2 : itree E R), + trace_incl t1 t2 -> sutt eq t1 t2. Proof. - intros E R. pcofix CIH. intros t1 t2 Heq. pfold. constructor. - - destruct Heq. split; intros; eapply trace_incl_finite_taus; eauto. - - intros. destruct Heq as [H12 H21]. unfold trace_incl in *. unfold is_trace in *. - assert (Heq' : forall tr r, is_traceF ot1' tr r <-> is_traceF ot2' tr r). + intros E R. pcofix CIH. intros t1 t2 Hincl. pfold. constructor. + - apply trace_incl_finite_taus; auto. + - intros. unfold trace_incl in *. unfold is_trace in *. + assert (Hincl' : forall tr r, is_traceF ot1' tr r -> is_traceF ot2' tr r). { - intros. split; intros. - - pose proof (is_traceF_unalltaus_add _ _ _ _ UNTAUS1 H). - eapply is_traceF_unalltaus_remove; eauto. - - pose proof (is_traceF_unalltaus_add _ _ _ _ UNTAUS2 H). - eapply is_traceF_unalltaus_remove; eauto. + intros. pose proof (is_traceF_unalltaus_add _ _ _ _ UNTAUS1 H). + eapply is_traceF_unalltaus_remove; eauto. } destruct ot1', ot2'; try solve [inv UNTAUS1; inv H0]; try solve [inv UNTAUS2; inv H0]. + assert (is_traceF (RetF r0 : itreeF E R (itree E R)) [] (Some r0)) by constructor. - rewrite Heq' in H. inv H. constructor; auto. + apply Hincl' in H. inv H. constructor; auto. + assert (is_traceF (RetF r0 : itreeF E R (itree E R)) [] (Some r0)) by constructor. - rewrite Heq' in H. inv H. + apply Hincl' in H. inv H. + assert (is_traceF (VisF e k) [EventOut e] None) by constructor. - rewrite Heq' in H. inv H. + apply Hincl' in H. inv H. + assert (is_traceF (VisF e k) [EventOut e] None) by constructor. - rewrite Heq' in H. inv H. invert_existTs. - - constructor. intros. right. apply CIH. - red. split; red; intros. - * assert (is_traceF (VisF e k) ((Event e x) :: tr) r_) by (constructor; auto). - rewrite Heq' in H0. inv H0. invert_existTs. auto. - * assert (is_traceF (VisF e k0) ((Event e x) :: tr) r_) by (constructor; auto). - rewrite <- Heq' in H0. inv H0. invert_existTs. auto. + apply Hincl' in H. inv H. invert_existTs. + constructor. intros. right. apply CIH. intros. + assert (is_traceF (VisF e k) ((Event e x) :: tr) r_) by (constructor; auto). + apply Hincl' in H0. inv H0. invert_existTs. auto. +Qed. + +Theorem trace_incl_iff_sutt : forall {E R} (t1 t2 : itree E R), + sutt eq t1 t2 <-> trace_incl t1 t2. +Proof. + split. + - apply sutt_trace_incl. + - apply trace_incl_sutt. +Qed. + +Lemma eutt_trace_eq : forall {E R} (t1 t2 : itree E R), + t1 ≈ t2 -> trace_eq t1 t2. +Proof. + split. + - apply eutt_sutt in H. apply sutt_trace_incl; auto. + - symmetry in H. apply eutt_sutt in H. apply sutt_trace_incl; auto. +Qed. + +Lemma trace_eq_eutt : forall {E R} (t1 t2 : itree E R), + trace_eq t1 t2 -> t1 ≈ t2. +Proof. + intros E R t1 t2 [? ?]. apply sutt_eutt. + - apply trace_incl_sutt; auto. + - apply trace_incl_sutt in H0. clear H. + generalize dependent t1. generalize dependent t2. pcofix CIH; intros. + pinversion H0. pfold. constructor; auto. intros. + specialize (EQV _ _ UNTAUS1 UNTAUS2). destruct EQV; constructor; auto. + + rewrite H. reflexivity. + + intros. right. apply CIH. pclearbot. apply H. Qed. Theorem trace_eq_iff_eutt : forall {E R} (t1 t2 : itree E R), From 1970d2bda4a12385bbd7b121817741b5c31aff8b Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 26 Feb 2019 13:02:37 -0500 Subject: [PATCH 110/142] Proving loop_den related lemmas --- examples/Den.v | 162 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 108 insertions(+), 54 deletions(-) diff --git a/examples/Den.v b/examples/Den.v index da9ecc0a..0a863dda 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -153,6 +153,11 @@ Section Den. erewrite (H a); reflexivity. Qed. + Lemma lift_den_id {A: Type}: @id_den A ⩰ lift_den id. + Proof. + unfold id_den, lift_den; reflexivity. + Qed. + Fact compose_lift_den {A B C} (ab : A -> B) (bc : B -> C) : (lift_den ab >=> lift_den bc) ⩰ (lift_den (bc ∘ ab)). Proof. @@ -197,6 +202,23 @@ Section Den. intro; reflexivity. Qed. + (** *** [associators] *) + Lemma assoc_lr {A B C} : + @assoc_den_l A B C >=> assoc_den_r ⩰ id_den. + Proof. + unfold assoc_den_l, assoc_den_r. + rewrite compose_lift_den. + intros [| []]; reflexivity. + Qed. + + Lemma assoc_rl {A B C} : + @assoc_den_r A B C >=> assoc_den_l ⩰ id_den. + Proof. + unfold assoc_den_l, assoc_den_r. + rewrite compose_lift_den. + intros [[]|]; reflexivity. + Qed. + (** *** [sum_elim] lemmas *) Fact compose_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : @@ -272,6 +294,13 @@ Section Den. reflexivity. Qed. + Lemma tensor_id {A B} : + id_den ⊗ id_den ⩰ @id_den (A + B). + Proof. + unfold tensor_den, ITree.cat, id_den. + intros []; cbn; rewrite ret_bind_; reflexivity. + Qed. + Lemma assoc_I {A B}: @assoc_den_r A I B >=> id_den ⊗ λ_den ⩰ ρ_den ⊗ id_den. Proof. @@ -284,9 +313,14 @@ Section Den. destruct i. Qed. - Lemma lift_den_id {A: Type}: @id_den A ⩰ lift_den id. + Lemma cat_tensor {A1 A2 A3 B1 B2 B3} + (f1 : @den E A1 A2) (f2 : den A2 A3) + (g1 : den B1 B2) (g2 : den B2 B3) : + (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩰ (f1 >=> f2) ⊗ (g1 >=> g2). Proof. - unfold id_den, lift_den; reflexivity. + unfold tensor_den, ITree.cat, lift_den; simpl. + intros []; simpl; + rewrite !bind_bind; setoid_rewrite ret_bind_; reflexivity. Qed. Lemma sum_elim_compose {A B C D F}: @@ -413,9 +447,7 @@ Section Den. repeat intro. unfold loop_den. apply eutt_loop; [| reflexivity]. - intros ? z ->. - unfold compose. - rewrite (H z); reflexivity. + auto. Qed. Lemma bind_map: forall {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z), @@ -452,8 +484,15 @@ A----B----###----C loop_den ((id_den ⊗ ab) >=> bc_) ⩰ ab >=> loop_den bc_. Proof. - Admitted. - + intros bc_ ab a. + rewrite (loop_natural_l ab bc_ a). + unfold loop_den. + apply eutt_loop; [intros [] | reflexivity]. + all: unfold tensor_den, sym_den, ITree.cat, assoc_den_l, assoc_den_r, id_den, lift_den; simpl. + - rewrite bind_bind, ret_bind_; reflexivity. + - rewrite bind_bind, map_bind. + setoid_rewrite ret_bind_; reflexivity. + Qed. (* Naturality of (loop_den I A B) in B *) (* Or more diagrammatically: @@ -479,7 +518,18 @@ A----###----B----C forall (ab_: denE (I + A) (I + B)) (bc: denE B B'), loop_den (ab_ >=> (id_den ⊗ bc)) ⩰ loop_den ab_ >=> bc. - Admitted. + intros bc_ ab a. + rewrite (loop_natural_r ab bc_ a). + unfold loop_den. + apply eutt_loop; [intros [] | reflexivity]. + all: unfold tensor_den, sym_den, ITree.cat, assoc_den_l, assoc_den_r, id_den, lift_den; simpl. + - apply eutt_bind; [reflexivity | intros []; simpl]. + rewrite ret_bind_; reflexivity. + reflexivity. + - apply eutt_bind; [reflexivity | intros []; simpl]. + rewrite ret_bind_; reflexivity. + reflexivity. + Qed. (* Dinaturality of (loop_den I A B) in I *) @@ -487,13 +537,30 @@ A----###----B----C forall (ab_: denE (I + A) (J + B)) (ji: denE J I), loop_den (ab_ >=> (ji ⊗ id_den)) ⩰ loop_den ((ji ⊗ id_den) >=> ab_). + Proof. Admitted. + Lemma map_is_cat {R S: Type}: + forall (f: R -> S) (t: itree E R), + ITree.map f t ≈ ITree.cat (fun _:unit => t) (fun x => Ret (f x)) tt. + Proof. + intros; reflexivity. + Qed. + (* Loop over the empty set can be erased *) Lemma vanishing_den {A B: Type}: forall (f: denE (I + A) (I + B)), loop_den f ⩰ λ_den' >=> f >=> λ_den. - Admitted. + Proof. + intros f a. + unfold loop_den. + rewrite vanishing1. + unfold λ_den,λ_den'. + unfold ITree.cat, ITree.map, lift_den. + rewrite bind_bind. + rewrite ret_bind_. + reflexivity. + Qed. (* [loop_loop]: @@ -527,60 +594,48 @@ These two loops: forall (ab__: denE (I + (J + A)) (I + (J + B))), loop_den (loop_den ab__) ⩰ loop_den (assoc_den_r >=> ab__ >=> assoc_den_l). - Admitted. + Proof. + intros ab_ a; unfold loop_den. + rewrite vanishing2. + apply eutt_loop; [intros [[]|] | reflexivity]. + all: unfold ITree.map, ITree.cat, assoc_den_r, assoc_den_l, lift_den; cbn. + all: rewrite bind_bind. + all: rewrite ret_bind_. + all: reflexivity. + Qed. + Lemma fold_map {R S}: + forall (f: R -> S) (t: itree E R), + (x <- t;; Ret (f x)) ≅ (ITree.map f t). + Proof. + intros; reflexivity. + Qed. + Lemma tensor_den_loop {I A B C D} (ab : denE (I + A) (I + B)) (cd : denE C D) : (loop_den ab) ⊗ cd ⩰ loop_den (assoc_den_l >=> (ab ⊗ cd) >=> assoc_den_r). Proof. - Admitted. + unfold loop_den, tensor_den, ITree.cat, assoc_den_l, assoc_den_r, lift_den, sum_elim. + intros []; simpl. + all:setoid_rewrite bind_bind. + all:setoid_rewrite ret_bind_. + all:rewrite fold_map. + 1:rewrite (@superposing1 E A B I C D). + 2:rewrite (@superposing2 E A B I C D). + all:unfold sum_bimap, ITree.map, sum_assoc_r,sum_elim; cbn. + all:apply eutt_loop; [intros [| []]; cbn | reflexivity]. + all: setoid_rewrite bind_bind. + all:setoid_rewrite ret_bind_. + all:reflexivity. + Qed. Lemma yanking_den {A: Type}: loop_den sym_den ⩰ @id_den A. - Admitted. - (* Lemma loop_relabel {I J A B} *) - (* (f : I -> J) {f' : J -> I} *) - (* {ISO_f : Iso f f'} *) - (* (ab : den (I + A) (I + B)) : *) - (* eq_den (loop_den ab) *) - (* (loop_den (rewire_den' (sum_bimap f' id) (sum_bimap f id) ab)). *) - (* Proof. *) - (* Admitted. *) - - (* TODO: Find the right place for these *) - - Lemma cat_tensor {A1 A2 A3 B1 B2 B3} - (f1 : @den E A1 A2) (f2 : den A2 A3) - (g1 : den B1 B2) (g2 : den B2 B3) : - (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩰ (f1 >=> f2) ⊗ (g1 >=> g2). - Proof. - unfold tensor_den, ITree.cat, lift_den; simpl. - intros []; simpl; - rewrite !bind_bind; setoid_rewrite ret_bind_; reflexivity. - Qed. - - Lemma assoc_lr {A B C} : - @assoc_den_l A B C >=> assoc_den_r ⩰ id_den. Proof. - unfold assoc_den_l, assoc_den_r. - rewrite compose_lift_den. - intros [| []]; reflexivity. - Qed. - - Lemma assoc_rl {A B C} : - @assoc_den_r A B C >=> assoc_den_l ⩰ id_den. - Proof. - unfold assoc_den_l, assoc_den_r. - rewrite compose_lift_den. - intros [[]|]; reflexivity. - Qed. - - Lemma tensor_id {A B} : - id_den ⊗ id_den ⩰ @id_den (A + B). - Proof. - unfold tensor_den, ITree.cat, id_den. - intros []; cbn; rewrite ret_bind_; reflexivity. + unfold loop_den, sym_den, lift_den. + intros ?; rewrite yanking. + apply tau_eutt. Qed. Lemma loop_rename_internal' {I J A B} (ij : den I J) (ji: den J I) @@ -612,4 +667,3 @@ Hint Rewrite @tensor_id_lift : lift_den. Hint Rewrite @tensor_lift_id : lift_den. Hint Rewrite @lift_sum_elim : lift_den. - From 431fba5225edfa3a5c69192ec2074003dd4fe1a5 Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 26 Feb 2019 14:29:11 -0500 Subject: [PATCH 111/142] Proved remaining admit --- examples/Den.v | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/examples/Den.v b/examples/Den.v index 0a863dda..28c6da06 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -538,7 +538,35 @@ A----###----B----C loop_den (ab_ >=> (ji ⊗ id_den)) ⩰ loop_den ((ji ⊗ id_den) >=> ab_). Proof. - Admitted. + intros; unfold loop_den. + unfold tensor_den, ITree.cat, lift_den, sum_elim. + + assert (EQ:forall (x: J + B), + match x with + | inl a => a0 <- ji a;; Ret (inl a0) + | inr b => a <- id_den b;; Ret (inr a) + end ≈ + match x with + | inl a => Tau (ITree.map (@inl I B) (ji a)) + | inr b => Ret (inr b) + end). + { + intros []. + symmetry; apply tau_eutt. + unfold id_den. + rewrite ret_bind_; reflexivity. + } + intros ?. + setoid_rewrite EQ. + rewrite loop_dinatural. + apply eutt_loop; [intros [] | reflexivity]. + all: unfold id_den. + all: repeat rewrite bind_bind. + 2: repeat rewrite ret_bind_; reflexivity. + apply eutt_bind; [reflexivity | intros ?]. + apply eutt_bind; [| intros ?; reflexivity]. + apply tau_eutt. + Qed. Lemma map_is_cat {R S: Type}: forall (f: R -> S) (t: itree E R), From f1e91356f274ce716859385969f018ab92520cf6 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 26 Feb 2019 16:55:42 -0500 Subject: [PATCH 112/142] reduce eutt_interp to sutt_interp --- theories/Eq/SimUpToTaus.v | 150 +++++++++++++++++++++++++++++++++++++- theories/Morphisms.v | 13 ++-- 2 files changed, 155 insertions(+), 8 deletions(-) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index c3338086..61c30677 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -31,7 +31,7 @@ Section SUTT. Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -Inductive suttF (eutt : itree E R1 -> itree E R2 -> Prop) +Variant suttF (eutt : itree E R1 -> itree E R2 -> Prop) (ot1 : itreeF E R1 (itree E R1)) (ot2 : itreeF E R2 (itree E R2)) : Prop := | suttF_ (FIN: finite_tausF ot1 -> finite_tausF ot2) @@ -57,7 +57,7 @@ Proof. eapply unalltaus_injective; eauto. Qed. -Inductive suttF0 (eutt : itree E R1 -> itree E R2 -> Prop) +Variant suttF0 (eutt : itree E R1 -> itree E R2 -> Prop) (ot1 : itreeF E R1 (itree E R1)) (ot2 : itreeF E R2 (itree E R2)) : Prop := | suttF0_notau ot2' : @@ -319,6 +319,152 @@ Proof. pclearbot; subst; auto. Qed. +Require Import ITree.MorphismsFacts ITree.Morphisms. + +Require Import Coq.Relations.Relations. + +Lemma eq_itree_vis_l {E R1 R2} {RR : R1 -> R2 -> Prop} {C1 C2 RC T} + (e : E T) (k : _ -> _) + (it : itreeF E _ _) + (H : @eq_itreeF E R1 R2 RR C1 C2 RC (VisF e k) it) + : + exists k', it = VisF e k' /\ + (forall x, RC (k x) (k' x)). +Proof. + refine + match H in eq_itreeF _ _ x y + return + match x return Prop with + | @VisF _ _ _ u e k => + exists k' : _ -> C2, y = VisF e k' /\ (forall x : u, RC (k x) (k' x)) + | _ => True + end + with + | EqVis _ _ _ _ _ Ek => ltac:(eexists; split; [ reflexivity | eassumption ]) + | _ => I + end. +Qed. + +(* todo: this could be made stronger with eutt rather than eq_itree + *) +Instance Proper_sutt {E : Type -> Type} {R1 R2 : Type} +: Proper (pointwise_relation _ (pointwise_relation _ Basics.impl) ==> + eq_itree eq ==> eq_itree eq ==> Basics.impl) + (@sutt E R1 R2). +Proof. + red. red. + unfold pointwise_relation. + intros x y Hxy. + unfold impl. + red. red. + do 5 intro. do 2 rewrite sutt_is_sutt1. + revert x0 y0 H x1 y1. + pcofix CIH. + intros. + punfold H0. + punfold H1. + red in H0. red in H1. + pfold. + punfold H2. + revert H0 H1. + generalize dependent (observe y0). + generalize dependent (observe y1). + generalize dependent (observe x2). + generalize dependent (observe x3). + induction 1; eauto. + { inversion 1; subst. + inversion 1; subst. + constructor. eapply Hxy. + assumption. } + { intros. + eapply eq_itree_vis_l in H0. + eapply eq_itree_vis_l in H1. + destruct H0 as [ ? [ ? ? ] ]. + destruct H1 as [ ? [ ? ? ] ]. + rewrite H. rewrite H1. + constructor. + intros. + right. + specialize (H0 x4). + specialize (H2 x4). + pclearbot. + eapply CIH; eauto. } + { intros. + inversion H1; clear H1; subst. + constructor. + eapply IHsuttF1; eauto. + pclearbot. + punfold REL. } + { intros. + inversion H0; clear H0; subst. + constructor. + right. + change i with (observe {| _observe := i |}). + pclearbot. + eapply CIH. + - eassumption. + - instantiate (1:={| _observe := ot2 |}). + pfold. red. eapply H1. + - eapply EQTAUS. } +Qed. + +Instance sutt_interp (E F : Type -> Type) (R : Type) : + Proper (Rhom (fun _ => sutt eq) ==> sutt eq ==> sutt eq) + (fun f => @interp E F f R). +Proof. + (* note(gmm): this theorem needs to do up-to reasoning *) + red. red. red. + intros x y Hxy. + intros l r. + do 2 rewrite sutt_is_sutt1. + pcofix CIH. + intros. + eapply sutt_to_sutt1. + { intros; eapply H. } + punfold H0. + pfold. red. + do 2 rewrite interp_unfold. + induction H0; eauto. + { subst. + cbn. constructor. admit. intros. + eapply unalltausF_ret in UNTAUS1. + eapply unalltausF_ret in UNTAUS2. + subst. constructor. reflexivity. } + { cbn. + admit. } + { admit. } + { admit. } +Admitted. + +Instance eutt_interp (E F : Type -> Type) (R : Type) : + Proper (Rhom (fun _ => eutt eq) ==> eutt eq ==> eutt eq) + (fun f => @interp E F f R). +Proof. + do 3 red. intros. + eapply sutt_eutt. + { eapply sutt_interp. + { clear - H. + unfold Rhom in *. + intros; red. + intros. eapply eutt_sutt. + eapply H. } + { eapply eutt_sutt. eapply H0. } } + { eapply Proper_sutt. + { instantiate (1:=eq). + compute. intros. congruence. } + { reflexivity. } + { reflexivity. } + eapply sutt_interp. + { clear - H. + unfold Rhom in *. + intros; red. + intros. eapply eutt_sutt. + eapply Symmetric_eutt; eauto. + eapply H. } + { eapply eutt_sutt. + eapply Symmetric_eutt; eauto. } } +Qed. + (** Generalized heterogeneous version of [eutt_bind] *) Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: forall t1 t2, diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 4890d1ac..bfc89e69 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -122,6 +122,7 @@ Definition handleF1 {E F G : Type -> Type} {I R : Type} end end. Hint Unfold handleF1. +(* note(gmm): i'd propose to remove handleF1 *) (** Shallow effect handling: pass the first [Vis] node to the given handler [h]. *) @@ -137,6 +138,7 @@ Definition handle1 {E F G : Type -> Type} {R : Type} itree (E +' F) R -> itree G R := cofix handle1_ t := handleF1 handle1_ h (observe t). Hint Unfold handle1. +(* note(gmm): i'd propose to remove handle1 *) (** An itree effect handler [E ~> itree F] defines an itree morphism [itree E ~> itree F]. *) @@ -177,10 +179,7 @@ Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : (** Effects [E, F : Type -> Type] and itree [E ~> itree F] form a category. *) -(* todo(gmm): it would be good to have notation for this. - * - if there was a "category" class like in Haskell, then we could - * get composition from something like that. - *) + (* Morphism Category -------------------------------------------------------- *) @@ -190,14 +189,16 @@ Definition eh_cmp {A B C} (g : B ~> itree C) (f : A ~> itree B) : Definition eh_id {A} : A ~> itree A := @ITree.liftE A. -Definition eh_par {A B C D} (f : A ~> itree B) (g : C ~> itree D) : (A +' C) ~> itree (B +' D) := +Definition eh_par {A B C D} (f : A ~> itree B) (g : C ~> itree D) +: (A +' C) ~> itree (B +' D) := fun _ e => match e with | inl1 e1 => translate (@inl1 _ _) (f _ e1) | inr1 e2 => translate (@inr1 _ _) (g _ e2) end. -Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) : (A +' C) ~> itree B := +Definition eh_both {A B C} (f : A ~> itree B) (g : C ~> itree B) +: (A +' C) ~> itree B := fun _ e => match e with | inl1 e1 => f _ e1 From c8fd4e8afc6452e8ed47da8558f5bea3fd2221bc Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 26 Feb 2019 18:26:29 -0500 Subject: [PATCH 113/142] The meaning of zero in conditional must be reversed between imp's if and asm's ifz --- examples/Imp2Asm.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index fc42b9e3..6acd514a 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -72,7 +72,7 @@ Definition tmp_if := gen_tmp 0. (* Conditional *) Definition cond_asm (e : list instr) : asm unit (unit + unit) := - raw_asm_block (after e (Bbrz tmp_if (inl tt) (inr tt))). + raw_asm_block (after e (Bbrz tmp_if (inr tt) (inl tt))). (** [if_asm e tp fp] [[ From 7287670138928363f05318f939f698cc754c51d7 Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 26 Feb 2019 20:02:08 -0500 Subject: [PATCH 114/142] If case in the proof of the compiler --- examples/Imp2AsmCorrectness.v | 57 ++++++++++++++++++++++++----------- 1 file changed, 39 insertions(+), 18 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 3d188f9b..a7b94275 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -11,6 +11,7 @@ From Coq Require Import From ITree Require Import Basics_Functions Effect.Env + MorphismsFacts ITree. From ExtLib Require Import @@ -495,7 +496,7 @@ Qed. (fun _ => denote_list e ;; v <- lift (GetVar tmp_if) ;; - if v : value then denote_asm tp tt else denote_asm fp tt). + if v : value then denote_asm fp tt else denote_asm tp tt). Proof. unfold if_asm. rewrite seq_asm_correct. @@ -508,23 +509,23 @@ Qed. apply eutt_bind; [reflexivity | intros ?]. apply eutt_bind; [reflexivity | intros []]. - rewrite ret_bind_. - rewrite (relabel_asm_correct _ _ _ (inl tt)). + rewrite (relabel_asm_correct _ _ _ (inr tt)). unfold ITree.cat; simpl. rewrite bind_bind. unfold lift_den; rewrite ret_bind_. - setoid_rewrite (app_asm_correct tp fp (inl tt)). + setoid_rewrite (app_asm_correct tp fp (inr tt)). setoid_rewrite bind_bind. - rewrite <- (bind_ret (denote_asm tp tt)) at 2. + rewrite <- (bind_ret (denote_asm fp tt)) at 2. eapply eutt_bind; [ reflexivity | intros ? ]. unfold lift_den; rewrite ret_bind_; reflexivity. - rewrite ret_bind_. - rewrite (relabel_asm_correct _ _ _ (inr tt)). + rewrite (relabel_asm_correct _ _ _ (inl tt)). unfold ITree.cat; simpl. rewrite bind_bind. unfold lift_den; rewrite ret_bind_. - setoid_rewrite (app_asm_correct tp fp (inr tt)). + setoid_rewrite (app_asm_correct tp fp (inl tt)). setoid_rewrite bind_bind. - rewrite <- (bind_ret (denote_asm fp tt)) at 2. + rewrite <- (bind_ret (denote_asm tp tt)) at 2. eapply eutt_bind; [reflexivity | intros ?]. unfold lift_den; rewrite ret_bind_; reflexivity. Qed. @@ -538,9 +539,9 @@ Qed. denote_list e ;; v <- lift (GetVar tmp_if) ;; if v : value then - denote_asm p tt;; Ret (inl tt) - else Ret (inr tt) + else + denote_asm p tt;; Ret (inl tt) | inr tt => Ret (inl tt) end)). Proof. @@ -557,16 +558,16 @@ Qed. apply eutt_bind; [reflexivity | intros []]. rewrite bind_bind. apply eutt_bind; [reflexivity | intros []]. + + rewrite (pure_asm_correct _ tt). + unfold lift_den. + repeat rewrite ret_bind_. + reflexivity. + rewrite (relabel_asm_correct _ _ _ tt). unfold ITree.cat. simpl; repeat setoid_rewrite bind_bind. unfold lift_den; rewrite ret_bind_. apply eutt_bind; [reflexivity | intros []]. repeat rewrite ret_bind_; reflexivity. - + rewrite (pure_asm_correct _ tt). - unfold lift_den. - repeat rewrite ret_bind_. - reflexivity. - rewrite itree_eta; cbn; reflexivity. Qed. @@ -585,6 +586,17 @@ Admitted. Lemma fold_ff f : f tt = ff f. Proof. reflexivity. Qed. +Lemma sim_rel_get_tmp0: + forall g_asm0 g_asm g_imp v, + sim_rel g_asm0 0 (g_asm,tt) (g_imp,v) -> + interp_locals (lift (GetVar (%0))) g_asm = Ret (g_asm,v). +Proof. + intros. + destruct H as [_ [eq _]]. + unfold interp_locals. + unfold run_env. +Admitted. + Lemma compile_correct: forall s (g_imp g_asm : alist var value), Renv g_asm g_imp -> @@ -592,7 +604,7 @@ Lemma compile_correct: (interp_locals (denote_asm (compile s) tt) g_asm) (interp_locals (denoteStmt s) g_imp). Proof. - induction s; intros. + induction s; intros g_imp g_asm Hsim. - (* Assign *) simpl. rewrite raw_asm_block_correct. @@ -612,23 +624,32 @@ Proof. rewrite 2 interp_locals_bind. eapply eutt_bind_gen. { auto. } - intros. destruct H0. destruct (snd r2). rewrite H1. + intros. destruct H. destruct (snd r2). rewrite H0. auto. - (* If *) - rewrite fold_ff; simpl. + rewrite fold_ff. simpl. rewrite if_asm_correct. unfold ff. rewrite 2 interp_locals_bind. eapply eutt_bind_gen. { apply compile_expr_correct. auto. } intros. - admit. + destruct r2 as [g_imp' v]; simpl. + rewrite interp_locals_bind. + destruct r1 as [g_asm' []]. + generalize H; intros EQ; apply sim_rel_get_tmp0 in EQ. + setoid_rewrite EQ; clear EQ. + rewrite ret_bind_. + simpl. + apply sim_rel_Renv in H. + destruct v; simpl; auto. - (* While *) simpl; rewrite fold_ff. rewrite while_asm_correct. + admit. (* TODO: Should use some loop_den lemmas to make the two loops line up. *) - admit. + - (* Skip *) rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). cbn. From 84a42de748bce9961ac2c19907ae952ad21fe5ce Mon Sep 17 00:00:00 2001 From: Yannick Date: Tue, 26 Feb 2019 22:09:49 -0500 Subject: [PATCH 115/142] Minor changes in the compiler's proof --- examples/Imp2AsmCorrectness.v | 57 +++++++++++++++++++++++++++++++---- 1 file changed, 51 insertions(+), 6 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index a7b94275..dc56c96d 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -10,6 +10,7 @@ From Coq Require Import From ITree Require Import Basics_Functions + Core Effect.Env MorphismsFacts ITree. @@ -37,8 +38,6 @@ Section Correctness. *) - Import ITree.Core. - Variable E: Type -> Type. Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. @@ -581,21 +580,42 @@ Qed. Definition ff (f : @den E unit unit) : itree E unit := f tt. Global Instance Proper_ff : Proper (eq_den ==> eutt eq) ff. -Admitted. +Proof. + repeat intro; unfold ff; auto. +Qed. Lemma fold_ff f : f tt = ff f. Proof. reflexivity. Qed. +Lemma interp1_liftE {E F G: Type -> Type} `{F -< G}: + forall (h: forall T: Type, E T -> itree G T) T (e : E T), + @interp1 E F G _ h T (lift e) ≈ h T e. +Proof. +Admitted. + +Definition env_lookupDefault_is_lift {K V : Type} {E: Type -> Type} `{envE K V -< E} (x: K) (v: V): + env_lookupDefault x v = lift (lookupDefaultE x v). +Proof. + reflexivity. +Qed. + Lemma sim_rel_get_tmp0: forall g_asm0 g_asm g_imp v, sim_rel g_asm0 0 (g_asm,tt) (g_imp,v) -> - interp_locals (lift (GetVar (%0))) g_asm = Ret (g_asm,v). + interp_locals (lift (GetVar (%0))) g_asm ≈ Ret (g_asm,v). Proof. intros. destruct H as [_ [eq _]]. unfold interp_locals. + rewrite interp1_liftE. + cbn. unfold run_env. -Admitted. + rewrite env_lookupDefault_is_lift. + unfold lift; rewrite interp_state_liftE. + cbn. + rewrite eq. + apply tau_eutt. +Qed. Lemma compile_correct: forall s (g_imp g_asm : alist var value), @@ -646,7 +666,32 @@ Proof. - (* While *) simpl; rewrite fold_ff. rewrite while_asm_correct. - admit. + (* This is kinda silly *) + assert ( + (fun l : unit + unit => + match l with + | inl tt => + denote_list (compile_expr 0 t);; v <- lift (GetVar tmp_if);; (if (v: value) then Ret (inr tt) else denote_asm (compile s) tt;; Ret (inl tt)) + | inr tt => Ret (inl tt) + end) ⩰ + ((fun _ => denote_list (compile_expr 0 t)) + ⊗ + id_den) >=> + (fun l: unit + unit => match l with + | inl tt => v <- lift (GetVar tmp_if);; (if (v: value) then Ret (inr tt) else denote_asm (compile s)tt;; Ret (inl tt)) + | inr tt => Ret (inl tt) + end) + ) + . + {unfold tensor_den, id_den, lift_den, sum_elim, ITree.cat. + intros [[]|[]]. + repeat rewrite bind_bind. + apply eutt_bind; [reflexivity | intros []]. + repeat rewrite ret_bind_; reflexivity. + repeat rewrite ret_bind_; reflexivity. + } + rewrite H. + admit. (* TODO: Should use some loop_den lemmas to make the two loops line up. *) From 28ec29f2da5c9fe93707179189e97b4c9ac9cb19 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 26 Feb 2019 21:41:07 -0500 Subject: [PATCH 116/142] Define eq_locals --- examples/Imp2AsmCorrectness.v | 106 +++++++++++++++++++++------------- 1 file changed, 67 insertions(+), 39 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index dc56c96d..5a1e15ff 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -119,15 +119,34 @@ Section Real_correctness. (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). Admitted. -(* TODO: maybe some of the correctness lemmas/theorems could - be refactored with this relation on denotations (which needs - fixing). - - Definition eq_locals {R} (t1 t2 : itree E R) : Prop := - forall g1 g2, - Renv g1 g2 -> - eutt (sim_rel _ _) (interp_locals t1 g1) (interp_locals t2 g2). -*) +Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) + (Renv_ : _ -> _ -> Prop) + t1 t2 := + forall g1 g2, + Renv_ g1 g2 -> + eutt (fun a (b : alist var value * R2) => Renv_ (fst a) (fst b) /\ RR (snd a) (snd b)) + (interp_locals t1 g1) + (interp_locals t2 g2). + +Instance eutt_eq_locals (Renv_ : _ -> _ -> Prop) {R} RR : + Proper (eutt eq ==> eutt eq ==> iff) (@eq_locals R R RR Renv_). +Proof. + repeat intro. + split; repeat intro. + - rewrite <- H, <- H0; auto. + - rewrite H, H0; auto. +Qed. + +Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) + {R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) : + forall t1 t2, + eq_locals RR Renv_ t1 t2 -> + forall k1 k2, + (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> + eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). +Proof. +Admitted. Set Nested Proofs Allowed. @@ -431,13 +450,12 @@ Qed. (** Correctness of compilation *) - Lemma compile_assign_correct : forall e g_imp g_asm x, - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b)) - (interp_locals (denote_list (compile_assign x e)) g_asm) - (interp_locals (v <- denoteExpr e ;; lift (SetVar x v)) g_imp). + Lemma compile_assign_correct : forall e x, + eq_locals eq Renv + (denote_list (compile_assign x e)) + (v <- denoteExpr e ;; lift (SetVar x v)). Proof. - simpl; intros. + red; intros. unfold compile_assign. rewrite denote_list_app. do 2 rewrite interp_locals_bind. @@ -451,6 +469,7 @@ Qed. destruct r1, r2. erewrite sim_rel_find_tmp_n; eauto; simpl. destruct H0. + split; auto. eapply Renv_write_local; eauto. Qed. @@ -617,52 +636,62 @@ Proof. apply tau_eutt. Qed. -Lemma compile_correct: - forall s (g_imp g_asm : alist var value), - Renv g_asm g_imp -> - eutt (fun a b => Renv (fst a) (fst b) /\ snd a = snd b) - (interp_locals (denote_asm (compile s) tt) g_asm) - (interp_locals (denoteStmt s) g_imp). +Instance subrelation_eutt_eq_locals {R} (RR : R -> R -> Prop) + : subrelation (eutt RR) (eq_locals RR Renv). +Proof. +Admitted. + +Instance Reflexive_eq_locals {R} (RR : R -> R -> Prop) : + Reflexive RR -> Reflexive (eq_locals RR Renv). +Proof. + repeat intro; apply subrelation_eutt_eq_locals; + auto; reflexivity. +Qed. + +Lemma compile_correct (s : stmt) : + eq_locals eq Renv + (denote_asm (compile s) tt) + (denoteStmt s). Proof. - induction s; intros g_imp g_asm Hsim. + induction s. + - (* Assign *) simpl. rewrite raw_asm_block_correct. rewrite after_correct. rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. + eapply eq_locals_bind_gen. { eapply compile_assign_correct; auto. } - intros. simpl. - rewrite (itree_eta (_ (fst r1))), (itree_eta (_ (fst r2))). - cbn. - apply eutt_Ret. destruct (snd r2). auto. + intros [] [] []. simpl. + reflexivity. + - (* Seq *) rewrite fold_ff; simpl. rewrite seq_asm_correct. unfold ff. unfold ITree.cat. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { auto. } - intros. destruct H. destruct (snd r2). rewrite H0. - auto. + eapply eq_locals_bind_gen. + { eauto. } + intros [] [] []; auto. + - (* If *) + repeat intro. rewrite fold_ff. simpl. rewrite if_asm_correct. unfold ff. rewrite 2 interp_locals_bind. eapply eutt_bind_gen. - { apply compile_expr_correct. auto. } + { apply compile_expr_correct; auto. } intros. destruct r2 as [g_imp' v]; simpl. rewrite interp_locals_bind. destruct r1 as [g_asm' []]. - generalize H; intros EQ; apply sim_rel_get_tmp0 in EQ. + generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. setoid_rewrite EQ; clear EQ. rewrite ret_bind_. simpl. - apply sim_rel_Renv in H. + apply sim_rel_Renv in H0. destruct v; simpl; auto. + - (* While *) simpl; rewrite fold_ff. rewrite while_asm_correct. @@ -696,9 +725,8 @@ Proof. line up. *) - (* Skip *) - rewrite (itree_eta (_ _ g_imp)), (itree_eta (_ _ g_asm)). - cbn. - apply eutt_Ret; auto. + rewrite (itree_eta (denote_asm _ _)), (itree_eta (denoteStmt _)). + reflexivity. Admitted. From e92c49e419277bc24c85b6f1aa145a60c7639d16 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 26 Feb 2019 21:55:21 -0500 Subject: [PATCH 117/142] Close toplevel proof. Auxiliary lemmas remain. --- examples/Imp2AsmCorrectness.v | 100 ++++++++++++++++++++-------------- 1 file changed, 59 insertions(+), 41 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 5a1e15ff..3d15578b 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -146,6 +146,35 @@ Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). Proof. +Admitted. + +Instance subrelation_eutt_eq_locals {R} (RR : R -> R -> Prop) + : subrelation (eutt RR) (eq_locals RR Renv). +Proof. +Admitted. + +Instance Reflexive_eq_locals {R} (RR : R -> R -> Prop) : + Reflexive RR -> Reflexive (eq_locals RR Renv). +Proof. + repeat intro; apply subrelation_eutt_eq_locals; + auto; reflexivity. +Qed. + +Lemma while_is_loop (body : itree E bool) : + while body + ≈ loop (fun l : unit + unit => + match l with + | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) + body + | inr _ => Ret (inl tt) (* Enter loop *) + end) tt. +Proof. +Admitted. + +Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : + (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> + eq_locals eq Renv (loop t1 x) (loop t2 x). +Proof. Admitted. Set Nested Proofs Allowed. @@ -636,18 +665,6 @@ Proof. apply tau_eutt. Qed. -Instance subrelation_eutt_eq_locals {R} (RR : R -> R -> Prop) - : subrelation (eutt RR) (eq_locals RR Renv). -Proof. -Admitted. - -Instance Reflexive_eq_locals {R} (RR : R -> R -> Prop) : - Reflexive RR -> Reflexive (eq_locals RR Renv). -Proof. - repeat intro; apply subrelation_eutt_eq_locals; - auto; reflexivity. -Qed. - Lemma compile_correct (s : stmt) : eq_locals eq Renv (denote_asm (compile s) tt) @@ -695,39 +712,40 @@ Proof. - (* While *) simpl; rewrite fold_ff. rewrite while_asm_correct. - (* This is kinda silly *) - assert ( - (fun l : unit + unit => - match l with - | inl tt => - denote_list (compile_expr 0 t);; v <- lift (GetVar tmp_if);; (if (v: value) then Ret (inr tt) else denote_asm (compile s) tt;; Ret (inl tt)) - | inr tt => Ret (inl tt) - end) ⩰ - ((fun _ => denote_list (compile_expr 0 t)) - ⊗ - id_den) >=> - (fun l: unit + unit => match l with - | inl tt => v <- lift (GetVar tmp_if);; (if (v: value) then Ret (inr tt) else denote_asm (compile s)tt;; Ret (inl tt)) - | inr tt => Ret (inl tt) - end) - ) - . - {unfold tensor_den, id_den, lift_den, sum_elim, ITree.cat. - intros [[]|[]]. - repeat rewrite bind_bind. - apply eutt_bind; [reflexivity | intros []]. - repeat rewrite ret_bind_; reflexivity. - repeat rewrite ret_bind_; reflexivity. - } - rewrite H. - admit. - (* TODO: Should use some loop_den lemmas to make the two loops - line up. *) + rewrite while_is_loop. + unfold ff, loop_den. + apply eq_locals_loop. + intros [[]|[]]; try reflexivity. + unfold ITree.map. rewrite bind_bind. + + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { apply compile_expr_correct; auto. } + intros. + destruct r2 as [g_imp' v]; simpl. + rewrite interp_locals_bind. + destruct r1 as [g_asm' []]. + generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. + rewrite interp_locals_bind. + setoid_rewrite EQ; clear EQ. + rewrite ret_bind_. + simpl. + apply sim_rel_Renv in H0. + destruct v; simpl; auto. + + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. + apply eutt_Ret. auto. + + rewrite 2 interp_locals_bind, bind_bind. + eapply eutt_bind_gen. + { eapply IHs; auto. } + intros. + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. + apply eutt_Ret. destruct H1; auto. - (* Skip *) rewrite (itree_eta (denote_asm _ _)), (itree_eta (denoteStmt _)). reflexivity. -Admitted. +Qed. (* From 8725e7be6025d12c9d4095ce8eaa84e981f0a21a Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 26 Feb 2019 21:59:35 -0500 Subject: [PATCH 118/142] Move to_itree to a safe place --- examples/Den.v | 12 ++++++++++++ examples/Imp2AsmCorrectness.v | 29 ++++++----------------------- 2 files changed, 18 insertions(+), 23 deletions(-) diff --git a/examples/Den.v b/examples/Den.v index 28c6da06..1f81e924 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -695,3 +695,15 @@ Hint Rewrite @tensor_id_lift : lift_den. Hint Rewrite @tensor_lift_id : lift_den. Hint Rewrite @lift_sum_elim : lift_den. +(* A trick to allow rewriting with eq_den in pointful contexts. *) +Definition to_itree {E} (f : @den E unit unit) : itree E unit := f tt. + +Global Instance Proper_to_itree {E} : + Proper (eq_den ==> eutt eq) (@to_itree E). +Proof. + repeat intro. + apply H. +Qed. + +Lemma fold_to_itree {E} (f : @den E unit unit) : f tt = to_itree f. +Proof. reflexivity. Qed. diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 3d15578b..c9f5b72d 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -618,23 +618,6 @@ Qed. - rewrite itree_eta; cbn; reflexivity. Qed. -(* - Global Instance subrelation_eq_den {E A B} : - subrelation (@eq_den E A B) (pointwise_relation _ (eutt eq))%signature. - Proof. - Admitted. -*) -(* a trick to allow rewriting with eq_den *) -Definition ff (f : @den E unit unit) : itree E unit := f tt. - -Global Instance Proper_ff : Proper (eq_den ==> eutt eq) ff. -Proof. - repeat intro; unfold ff; auto. -Qed. - -Lemma fold_ff f : f tt = ff f. -Proof. reflexivity. Qed. - Lemma interp1_liftE {E F G: Type -> Type} `{F -< G}: forall (h: forall T: Type, E T -> itree G T) T (e : E T), @interp1 E F G _ h T (lift e) ≈ h T e. @@ -683,8 +666,8 @@ Proof. reflexivity. - (* Seq *) - rewrite fold_ff; simpl. - rewrite seq_asm_correct. unfold ff. + rewrite fold_to_itree; simpl. + rewrite seq_asm_correct. unfold to_itree. unfold ITree.cat. eapply eq_locals_bind_gen. { eauto. } @@ -692,9 +675,9 @@ Proof. - (* If *) repeat intro. - rewrite fold_ff. simpl. + rewrite fold_to_itree. simpl. rewrite if_asm_correct. - unfold ff. + unfold to_itree. rewrite 2 interp_locals_bind. eapply eutt_bind_gen. { apply compile_expr_correct; auto. } @@ -710,10 +693,10 @@ Proof. destruct v; simpl; auto. - (* While *) - simpl; rewrite fold_ff. + simpl; rewrite fold_to_itree. rewrite while_asm_correct. rewrite while_is_loop. - unfold ff, loop_den. + unfold to_itree, loop_den. apply eq_locals_loop. intros [[]|[]]; try reflexivity. unfold ITree.map. rewrite bind_bind. From 16f0ec808e2922a60b818db47dd0d6b7fae54b54 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Tue, 26 Feb 2019 22:59:25 -0500 Subject: [PATCH 119/142] Remove invalid assumptions --- examples/Imp2AsmCorrectness.v | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index c9f5b72d..4be98cb1 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -146,18 +146,11 @@ Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). Proof. -Admitted. - -Instance subrelation_eutt_eq_locals {R} (RR : R -> R -> Prop) - : subrelation (eutt RR) (eq_locals RR Renv). -Proof. -Admitted. - -Instance Reflexive_eq_locals {R} (RR : R -> R -> Prop) : - Reflexive RR -> Reflexive (eq_locals RR Renv). -Proof. - repeat intro; apply subrelation_eutt_eq_locals; - auto; reflexivity. + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { eapply H; auto. } + intros. eapply H0; destruct H2; auto. Qed. Lemma while_is_loop (body : itree E bool) : @@ -663,7 +656,9 @@ Proof. eapply eq_locals_bind_gen. { eapply compile_assign_correct; auto. } intros [] [] []. simpl. - reflexivity. + repeat intro. + rewrite itree_eta, (itree_eta (_ _ g2)); cbn. + apply eutt_Ret; auto. - (* Seq *) rewrite fold_to_itree; simpl. @@ -698,7 +693,10 @@ Proof. rewrite while_is_loop. unfold to_itree, loop_den. apply eq_locals_loop. - intros [[]|[]]; try reflexivity. + intros [[]|[]]. + 2:{ repeat intro. + rewrite itree_eta, (itree_eta (_ _ g2)); cbn. + apply eutt_Ret; auto. } unfold ITree.map. rewrite bind_bind. repeat intro. @@ -726,8 +724,11 @@ Proof. apply eutt_Ret. destruct H1; auto. - (* Skip *) - rewrite (itree_eta (denote_asm _ _)), (itree_eta (denoteStmt _)). - reflexivity. + repeat intro. + rewrite (itree_eta (_ (denote_asm _ _) _)), + (itree_eta (_ (denoteStmt _) _)); + cbn. + apply eutt_Ret; auto. Qed. From ce8384e95cbf37da12daedac7f73b95a991ca519 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 27 Feb 2019 00:48:44 -0500 Subject: [PATCH 120/142] Prove while_is_loop --- examples/Imp.v | 70 +++++++++++++++++++++++++++++++++++ examples/Imp2AsmCorrectness.v | 11 ------ theories/FixFacts.v | 22 ++++++----- theories/MorphismsFacts.v | 25 +++++++++---- 4 files changed, 101 insertions(+), 27 deletions(-) diff --git a/examples/Imp.v b/examples/Imp.v index 6a52f9ad..3909d916 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -171,9 +171,79 @@ Definition ImpEval (s: stmt): itree emptyE (env * unit) := let p := interp evalLocals _ (denoteStmt s) in run_env _ p empty. +(* (* some simple examples. Dumb right now, nothing computes *) Eval unfold ex1 in ImpEval ex1. Eval simpl in ImpEval ex2. +*) +From ITree Require Import FixFacts MorphismsFacts. +Require Import Paco.paco. +Lemma interp1_bind {E F R S} (h : E ~> itree F) (t : _ R) (k : _ -> itree (E +' F) S) : + interp1 h _ (t >>= k) ≅ interp1 h _ t >>= fun x => interp1 h _ (k x). +Proof. + pupto2_init. + revert t; pcofix self; intros. + rewrite 2 unfold_interp1. rewrite unfold_bind. + destruct (observe t); cbn. + - rewrite ret_bind_. rewrite <- unfold_interp1. + pupto2_final. apply RelationClasses.reflexivity. + - rewrite tau_bind_. pfold; constructor; auto. + - destruct e. + + rewrite tau_bind_. rewrite bind_bind. pfold; constructor. + pupto2 eq_itree_clo_bind. constructor. + reflexivity. auto. + + rewrite vis_bind_. pfold; constructor; auto. +Qed. + +Lemma translate_interp1 {E F R} (h : F ~> itree E) : + forall (t : itree E R), + interp1 h _ (translate (fun _ e => inr1 e) t) ≅ t. +Proof. + pcofix self; intros. + pfold; red. + rewrite interp1_unfold. + rewrite TranslateFacts.unfold_translate. + destruct (observe t); cbn; auto. +Qed. + +Lemma while_is_loop {E} (body : itree E bool) : + while body + ≈ loop (fun l : unit + unit => + match l with + | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) + body + | inr _ => Ret (inl tt) (* Enter loop *) + end) tt. +Proof. + unfold while. + unfold loop. + rewrite unfold_loop'. + unfold loop_once_. + rewrite ret_bind_. + rewrite tau_eutt. + apply subrelation_eq_eutt. + pupto2_init; pcofix self. + rewrite rec_unfold', unfold_loop'. + unfold loop_once_; cbn. + rewrite interp1_bind, map_bind. + rewrite translate_interp1. + pupto2 eq_itree_clo_bind; constructor; try reflexivity. + intros []. + - rewrite itree_eta; cbn. + pupto2 eq_itree_clo_trans; econstructor. + apply eq_itree_tau. + eapply eq_itree_bind. + reflexivity. + intros [] ? []. + rewrite unfold_interp1; cbn. + instantiate (1 := fun x => Ret x). + reflexivity. + reflexivity. rewrite bind_ret. + pfold; constructor. + pupto2_final. + right; auto. + - rewrite itree_eta; cbn. pfold; constructor; auto. +Qed. diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 4be98cb1..12fd54c9 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -153,17 +153,6 @@ Proof. intros. eapply H0; destruct H2; auto. Qed. -Lemma while_is_loop (body : itree E bool) : - while body - ≈ loop (fun l : unit + unit => - match l with - | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) - body - | inr _ => Ret (inl tt) (* Enter loop *) - end) tt. -Proof. -Admitted. - Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> eq_locals eq Renv (loop t1 x) (loop t2 x). diff --git a/theories/FixFacts.v b/theories/FixFacts.v index b3db4b3f..cf05349a 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -186,21 +186,25 @@ Qed. End Facts. +Lemma rec_unfold' {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : + rec f x ≅ interp1 (fun _ e => calling' (rec f) _ e) _ (f x). +Proof. + unfold rec. unfold mrec. + rewrite unfold_interp_mrec. + unfold interp_match. + unfold mrec. eapply eq_itree_interp1_. + - intros ? []; reflexivity. + - reflexivity. +Qed. + Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : rec f x ≈ interp (fun _ e => match e with | inl1 e => calling' (rec f) _ e | inr1 e => ITree.liftE e end) _ (f x). Proof. - unfold rec. unfold mrec. - rewrite unfold_interp_mrec. - repeat rewrite <- interp_is_interp1. - unfold interp_match. - unfold mrec. - eapply eutt_interp. - { red. intro. red. destruct a; try reflexivity. - destruct c. - reflexivity. } + rewrite rec_unfold'. + rewrite <- interp_is_interp1. reflexivity. Qed. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index b1df7fea..a095936c 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -294,22 +294,33 @@ Proof. eapply (CIH' (go x2) (go x3)); eauto. Qed. -Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : - Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +Lemma eq_itree_interp1_ {E F R} (h1 h2 : E ~> itree F) : + (forall T (e : E T), h1 _ e ≅ h2 _ e) -> + forall t1 t2 : itree (E +' F) R, + t1 ≅ t2 -> interp1 h1 _ t1 ≅ interp1 h2 _ t2. Proof. - repeat intro. pupto2_init. revert_until R. + intros Hh t1 t2 Ht. + pupto2_init. revert_until R. pcofix CIH. intros. rewrite !unfold_interp1. - punfold H0; red in H0. - destruct H0; pclearbot. + punfold Ht; red in Ht. + destruct Ht; pclearbot. - pupto2_final. pfold. red. cbn. eauto. - pupto2_final. pfold. red. cbn. eauto. - pfold. destruct e; cbn; econstructor. + pupto2 (eq_itree_clo_bind F R). constructor. - * reflexivity. + * auto. * intros; pupto2_final; eauto. - + intros. pupto2_final. eauto. + + intros; pupto2_final; eauto. +Qed. + +Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +Proof. + repeat intro. + eapply eq_itree_interp1_; auto. + reflexivity. Qed. Instance eutt_interp1 {E F: Type -> Type} (h: E ~> itree F) R: From 78697c4d79c1524dbf4ee54f93ea175333d5ae35 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 27 Feb 2019 08:05:02 -0500 Subject: [PATCH 121/142] Prove interp_locals_bind --- examples/Imp.v | 28 ---------------------------- examples/Imp2AsmCorrectness.v | 9 ++++++++- theories/MorphismsFacts.v | 31 +++++++++++++++++++++++++++++-- 3 files changed, 37 insertions(+), 31 deletions(-) diff --git a/examples/Imp.v b/examples/Imp.v index 3909d916..4400ea5c 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -181,34 +181,6 @@ Eval simpl in ImpEval ex2. From ITree Require Import FixFacts MorphismsFacts. Require Import Paco.paco. -Lemma interp1_bind {E F R S} (h : E ~> itree F) (t : _ R) (k : _ -> itree (E +' F) S) : - interp1 h _ (t >>= k) ≅ interp1 h _ t >>= fun x => interp1 h _ (k x). -Proof. - pupto2_init. - revert t; pcofix self; intros. - rewrite 2 unfold_interp1. rewrite unfold_bind. - destruct (observe t); cbn. - - rewrite ret_bind_. rewrite <- unfold_interp1. - pupto2_final. apply RelationClasses.reflexivity. - - rewrite tau_bind_. pfold; constructor; auto. - - destruct e. - + rewrite tau_bind_. rewrite bind_bind. pfold; constructor. - pupto2 eq_itree_clo_bind. constructor. - reflexivity. auto. - + rewrite vis_bind_. pfold; constructor; auto. -Qed. - -Lemma translate_interp1 {E F R} (h : F ~> itree E) : - forall (t : itree E R), - interp1 h _ (translate (fun _ e => inr1 e) t) ≅ t. -Proof. - pcofix self; intros. - pfold; red. - rewrite interp1_unfold. - rewrite TranslateFacts.unfold_translate. - destruct (observe t); cbn; auto. -Qed. - Lemma while_is_loop {E} (body : itree E bool) : while body ≈ loop (fun l : unit + unit => diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 12fd54c9..2ce11fb0 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -117,7 +117,14 @@ Section Real_correctness. @eutt E' _ _ eq (interp_locals (ITree.bind t k) s) (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). - Admitted. + Proof. + intros. + unfold interp_locals. + unfold run_env. + rewrite interp1_bind. + rewrite interp_state_bind. + reflexivity. + Qed. Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) (Renv_ : _ -> _ -> Prop) diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index a095936c..f41d7da1 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -235,11 +235,11 @@ Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) end). -Lemma interp1_unfold {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : +Lemma interp1_unfold {E F G} `{F -< G} {R} {f : E ~> itree G} (t : itree (E +' F) R) : observe (interp1 f _ t) = observe (interp1_u f _ (observe t)). Proof. eauto. Qed. -Lemma unfold_interp1 {E F R} {f : E ~> itree F} (t : itree (E +' F) R) : +Lemma unfold_interp1 {E F G} `{F -< G} {R} {f : E ~> itree G} (t : itree (E +' F) R) : interp1 f _ t ≅ interp1_u f _ (observe t). Proof. rewrite itree_eta, interp1_unfold, <-itree_eta. reflexivity. Qed. @@ -731,3 +731,30 @@ Proof. simpl. unfold Sum1.idE. reflexivity. Qed. +Lemma interp1_bind {E F G} `{F -< G} {R S} (h : E ~> itree G) (t : _ R) (k : _ -> itree (E +' F) S) : + interp1 h _ (t >>= k) ≅ interp1 h _ t >>= fun x => interp1 h _ (k x). +Proof. + pupto2_init. + revert t; pcofix self; intros. + rewrite 2 unfold_interp1. rewrite unfold_bind. + destruct (observe t); cbn. + - rewrite ret_bind_. rewrite <- unfold_interp1. + pupto2_final. apply RelationClasses.reflexivity. + - rewrite tau_bind_. pfold; constructor; auto. + - destruct e. + + rewrite tau_bind_. rewrite bind_bind. pfold; constructor. + pupto2 eq_itree_clo_bind. constructor. + reflexivity. auto. + + rewrite vis_bind_. pfold; constructor; auto. +Qed. + +Lemma translate_interp1 {E F R} (h : F ~> itree E) : + forall (t : itree E R), + interp1 h _ (translate (fun _ e => inr1 e) t) ≅ t. +Proof. + pcofix self; intros. + pfold; red. + rewrite interp1_unfold. + rewrite TranslateFacts.unfold_translate. + destruct (observe t); cbn; auto. +Qed. From a22f0ede89973a2ffcd8f6da76340272b5d06f58 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 27 Feb 2019 08:22:24 -0500 Subject: [PATCH 122/142] Prove eutt_interp_locals --- examples/Imp2AsmCorrectness.v | 15 +++++------ theories/MorphismsFacts.v | 50 ++++++++++++++++++++++++----------- 2 files changed, 41 insertions(+), 24 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 2ce11fb0..3499cb76 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -107,11 +107,16 @@ Section Real_correctness. : itree E' (alist var value * R) := run_env _ (interp1 evalLocals _ t) s. - Instance eq_itree_interp_locals {R}: + Instance eutt_interp_locals {R}: Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) interp_locals. Proof. - Admitted. + repeat intro. + unfold interp_locals. + unfold run_env. + rewrite H0. rewrite H. + reflexivity. + Qed. Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), @eutt E' _ _ eq @@ -606,12 +611,6 @@ Qed. repeat rewrite ret_bind_; reflexivity. - rewrite itree_eta; cbn; reflexivity. Qed. - -Lemma interp1_liftE {E F G: Type -> Type} `{F -< G}: - forall (h: forall T: Type, E T -> itree G T) T (e : E T), - @interp1 E F G _ h T (lift e) ≈ h T e. -Proof. -Admitted. Definition env_lookupDefault_is_lift {K V : Type} {E: Type -> Type} `{envE K V -< E} (x: K) (v: V): env_lookupDefault x v = lift (lookupDefaultE x v). diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index f41d7da1..16037552 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -245,23 +245,27 @@ Proof. rewrite itree_eta, interp1_unfold, <-itree_eta. reflexivity. Qed. (** ** [interp1] is equivalent to [interp] *) -Definition interp_match {E F} (f: E ~> itree F) : (E +' F) ~> itree F := - fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis e (fun r => Ret r) end. +Section interp1_is_interp. -Inductive interp_inv {E F R} (f: E ~> itree F) : relation (itree' F R) := +Context {E F G : Type -> Type} `{F -< G} (f : E ~> itree G). + +Definition interp_match : (E +' F) ~> itree G := + fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis (subeffect _ e) (fun r => Ret r) end. + +Inductive interp_inv {R} : relation (itree' G R) := | _interp_inv_main t: - interp_inv f - (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)) + interp_inv + (observe (interp interp_match _ t)) (observe (interp1 f _ t)) | _interp_inv_bind u t (k: u -> _): - interp_inv f - (observe (ITree.bind t (fun x => interp (interp_match f) _ (k x)))) + interp_inv + (observe (ITree.bind t (fun x => interp interp_match _ (k x)))) (observe (ITree.bind t (fun x => interp1 f _ (k x)))) . Hint Constructors interp_inv. -Lemma interp_inv_main_step E F R (f: E ~> itree F) (t: itree _ R) : - euttF' (fun x y => interp_inv f (observe x) (observe y)) (interp_inv f) - (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)). +Lemma interp_inv_main_step R (t: itree _ R) : + euttF' (fun x y => interp_inv (observe x) (observe y)) interp_inv + (observe (interp interp_match _ t)) (observe (interp1 f _ t)). Proof. rewrite interp_unfold, interp1_unfold. genobs t ot. clear Heqot t. @@ -272,11 +276,11 @@ Proof. fold_bind. rewrite unfold_bind. simpl. eauto. Qed. -Lemma interp_is_interp1 E F R (f: E ~> itree F) (t: itree _ R) : - interp (interp_match f) _ t ≈ interp1 f _ t. +Lemma interp_is_interp1 R (t: itree _ R) : + interp interp_match _ t ≈ interp1 f _ t. Proof. revert t. - cut (forall (t1 t2: itree _ R) (REL: interp_inv f (observe t1) (observe t2)), t1 ≈ t2). + cut (forall (t1 t2: itree _ R) (REL: interp_inv (observe t1) (observe t2)), t1 ≈ t2). { eauto. } intros. apply eutt_is_eutt'. @@ -294,6 +298,8 @@ Proof. eapply (CIH' (go x2) (go x3)); eauto. Qed. +End interp1_is_interp. + Lemma eq_itree_interp1_ {E F R} (h1 h2 : E ~> itree F) : (forall T (e : E T), h1 _ e ≅ h2 _ e) -> forall t1 t2 : itree (E +' F) R, @@ -315,7 +321,7 @@ Proof. + intros; pupto2_final; eauto. Qed. -Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : +Instance eq_itree_interp1 {E F G} `{F -< G} {R} (h : E ~> itree F) : Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). Proof. repeat intro. @@ -323,8 +329,8 @@ Proof. reflexivity. Qed. -Instance eutt_interp1 {E F: Type -> Type} (h: E ~> itree F) R: - Proper (eutt eq ==> eutt eq) (@interp1 E F F _ h R). +Instance eutt_interp1 {E F G: Type -> Type} `{F -< G} (h: E ~> itree G) R: + Proper (eutt eq ==> eutt eq) (@interp1 E F G _ h R). Proof. repeat intro. rewrite <- 2 interp_is_interp1. @@ -758,3 +764,15 @@ Proof. rewrite TranslateFacts.unfold_translate. destruct (observe t); cbn; auto. Qed. + +Lemma interp1_liftE {E F G: Type -> Type} `{F -< G}: + forall (h: forall T: Type, E T -> itree G T) T (e : E T), + @interp1 E F G _ h T (lift e) ≈ h T e. +Proof. + intros. unfold lift. + rewrite unfold_interp1; cbn. + rewrite tau_eutt. + setoid_rewrite unfold_interp1; cbn. + rewrite bind_ret. + reflexivity. +Qed. From 42bf65b6f142568ee425449ee2eabac8d5734aaf Mon Sep 17 00:00:00 2001 From: Lysxia Date: Wed, 27 Feb 2019 08:48:25 -0500 Subject: [PATCH 123/142] Reduce proof of eq_locals_loop --- examples/Imp2AsmCorrectness.v | 7 ++++++- theories/FixFacts.v | 22 ++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 3499cb76..1b240d42 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -13,6 +13,7 @@ From ITree Require Import Core Effect.Env MorphismsFacts + FixFacts ITree. From ExtLib Require Import @@ -169,7 +170,11 @@ Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> eq_locals eq Renv (loop t1 x) (loop t2 x). Proof. -Admitted. + unfold eq_locals, interp_locals, run_env. + intros. + rewrite 2 interp1_loop. + eapply interp_state_loop; auto. +Qed. Set Nested Proofs Allowed. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index cf05349a..94bf4945 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -667,3 +667,25 @@ Proof. red; auto. + auto. Qed. + +Lemma interp_state_loop {E F S A B C} (RS : S -> S -> Prop) + (h : E ~> Monads.stateT S (itree F)) + (t1 t2 : C + A -> itree E (C + B)) : + (forall ca s1 s2, RS s1 s2 -> + eutt (fun a b => RS (fst a) (fst b) /\ snd a = snd b) + (interp_state h _ (t1 ca) s1) + (interp_state h _ (t2 ca) s2)) -> + (forall a s1 s2, RS s1 s2 -> + eutt (fun a b => RS (fst a) (fst b) /\ snd a = snd b) + (interp_state h _ (loop t1 a) s1) + (interp_state h _ (loop t2 a) s2)). +Proof. +Admitted. + +Require Import ITree.OpenSum. + +Lemma interp1_loop {E F G} `{F -< G} (f : E ~> itree G) {A B C} + (t : C + A -> itree (E +' F) (C + B)) a : + interp1 f _ (loop t a) ≅ loop (fun ca => interp1 f _ (t ca)) a. +Proof. +Admitted. From 6bbd0679762bf643b5bfe9bec8349d5cd36ac1aa Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 27 Feb 2019 17:53:15 -0500 Subject: [PATCH 124/142] Rephrased while using loop --- examples/Imp.v | 64 +++++++++++++++----------------------------------- 1 file changed, 19 insertions(+), 45 deletions(-) diff --git a/examples/Imp.v b/examples/Imp.v index 4400ea5c..29a20c27 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -95,9 +95,13 @@ Section Denote. end. Definition while {eff} (t : itree eff bool) : itree eff unit := - rec (fun _ : unit => - continue <- translate (fun _ x => inr1 x) t ;; - if continue : bool then lift (Call tt) else Monad.ret tt) tt. + @loop eff unit unit unit + (fun l : unit + unit => + match l with + | inr _ => ret (inl tt) + | inl _ => continue <- t ;; + if continue : bool then ret (inl tt) else ret (inr tt) + end) tt. (* the meaning of a statement *) Fixpoint denoteStmt (s : stmt) : itree eff unit := @@ -171,51 +175,21 @@ Definition ImpEval (s: stmt): itree emptyE (env * unit) := let p := interp evalLocals _ (denoteStmt s) in run_env _ p empty. -(* -(* some simple examples. Dumb right now, nothing computes *) -Eval unfold ex1 in ImpEval ex1. - -Eval simpl in ImpEval ex2. -*) - From ITree Require Import FixFacts MorphismsFacts. -Require Import Paco.paco. Lemma while_is_loop {E} (body : itree E bool) : - while body - ≈ loop (fun l : unit + unit => - match l with - | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) - body - | inr _ => Ret (inl tt) (* Enter loop *) - end) tt. + while body + ≈ loop (fun l : unit + unit => + match l with + | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) + body + | inr _ => Ret (inl tt) (* Enter loop *) + end) tt. Proof. unfold while. - unfold loop. - rewrite unfold_loop'. - unfold loop_once_. - rewrite ret_bind_. - rewrite tau_eutt. - apply subrelation_eq_eutt. - pupto2_init; pcofix self. - rewrite rec_unfold', unfold_loop'. - unfold loop_once_; cbn. - rewrite interp1_bind, map_bind. - rewrite translate_interp1. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - intros []. - - rewrite itree_eta; cbn. - pupto2 eq_itree_clo_trans; econstructor. - apply eq_itree_tau. - eapply eq_itree_bind. - reflexivity. - intros [] ? []. - rewrite unfold_interp1; cbn. - instantiate (1 := fun x => Ret x). - reflexivity. - reflexivity. rewrite bind_ret. - pfold; constructor. - pupto2_final. - right; auto. - - rewrite itree_eta; cbn. pfold; constructor; auto. + apply eutt_loop; [intros [[]|[]]; simpl | reflexivity]. + 2: reflexivity. + unfold ITree.map. + apply eutt_bind; [reflexivity | intros []; reflexivity]. Qed. + From 7e33e12c35d20d1c720bed4bd60d472eb8525576 Mon Sep 17 00:00:00 2001 From: Gil Hur Date: Fri, 1 Mar 2019 02:50:56 +0900 Subject: [PATCH 125/142] Make default the more corecursive version of `eutt`. - Simplify several proofs directly using this new `eutt`. --- _CoqConfig | 2 + examples/Imp.v | 64 +- theories/Core.v | 6 +- theories/Eq/Eq.v | 158 ++-- theories/Eq/Shallow.v | 10 +- theories/Eq/SimUpToTaus.v | 19 +- theories/Eq/Untaus.v | 319 ++++++++ theories/Eq/UpToTaus.v | 1409 ++++++++------------------------ theories/Eq/UpToTausExplicit.v | 744 +++++++++++++++++ theories/FixFacts.v | 174 ++-- theories/Morphisms.v | 18 +- theories/MorphismsFacts.v | 350 ++++---- theories/Trace.v | 1 + theories/TranslateFacts.v | 41 +- 14 files changed, 1755 insertions(+), 1560 deletions(-) create mode 100644 theories/Eq/Untaus.v create mode 100644 theories/Eq/UpToTausExplicit.v diff --git a/_CoqConfig b/_CoqConfig index 7d3fff29..3446dcec 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -7,6 +7,8 @@ theories/Core.v theories/Eq/Shallow.v theories/Eq/Eq.v theories/Eq/UpToTaus.v +theories/Eq/UpToTausExplicit.v +theories/Eq/Untaus.v theories/Eq/SimUpToTaus.v theories/Effect/Sum.v diff --git a/examples/Imp.v b/examples/Imp.v index 4400ea5c..29a20c27 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -95,9 +95,13 @@ Section Denote. end. Definition while {eff} (t : itree eff bool) : itree eff unit := - rec (fun _ : unit => - continue <- translate (fun _ x => inr1 x) t ;; - if continue : bool then lift (Call tt) else Monad.ret tt) tt. + @loop eff unit unit unit + (fun l : unit + unit => + match l with + | inr _ => ret (inl tt) + | inl _ => continue <- t ;; + if continue : bool then ret (inl tt) else ret (inr tt) + end) tt. (* the meaning of a statement *) Fixpoint denoteStmt (s : stmt) : itree eff unit := @@ -171,51 +175,21 @@ Definition ImpEval (s: stmt): itree emptyE (env * unit) := let p := interp evalLocals _ (denoteStmt s) in run_env _ p empty. -(* -(* some simple examples. Dumb right now, nothing computes *) -Eval unfold ex1 in ImpEval ex1. - -Eval simpl in ImpEval ex2. -*) - From ITree Require Import FixFacts MorphismsFacts. -Require Import Paco.paco. Lemma while_is_loop {E} (body : itree E bool) : - while body - ≈ loop (fun l : unit + unit => - match l with - | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) - body - | inr _ => Ret (inl tt) (* Enter loop *) - end) tt. + while body + ≈ loop (fun l : unit + unit => + match l with + | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) + body + | inr _ => Ret (inl tt) (* Enter loop *) + end) tt. Proof. unfold while. - unfold loop. - rewrite unfold_loop'. - unfold loop_once_. - rewrite ret_bind_. - rewrite tau_eutt. - apply subrelation_eq_eutt. - pupto2_init; pcofix self. - rewrite rec_unfold', unfold_loop'. - unfold loop_once_; cbn. - rewrite interp1_bind, map_bind. - rewrite translate_interp1. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - intros []. - - rewrite itree_eta; cbn. - pupto2 eq_itree_clo_trans; econstructor. - apply eq_itree_tau. - eapply eq_itree_bind. - reflexivity. - intros [] ? []. - rewrite unfold_interp1; cbn. - instantiate (1 := fun x => Ret x). - reflexivity. - reflexivity. rewrite bind_ret. - pfold; constructor. - pupto2_final. - right; auto. - - rewrite itree_eta; cbn. pfold; constructor; auto. + apply eutt_loop; [intros [[]|[]]; simpl | reflexivity]. + 2: reflexivity. + unfold ITree.map. + apply eutt_bind; [reflexivity | intros []; reflexivity]. Qed. + diff --git a/theories/Core.v b/theories/Core.v index e7517827..4ec8d9c6 100644 --- a/theories/Core.v +++ b/theories/Core.v @@ -72,8 +72,8 @@ Definition observe {E R} := @_observe E R. Ltac fold_observe := change @_observe with @observe in *. Ltac unfold_observe := unfold observe in *. -Ltac genobs x ox := remember (observe x) as ox; simpl observe. - +Ltac genobs x ox := remember (observe x) as ox. +Ltac genobs_clear x ox := genobs x ox; match goal with [H: ox = observe x |- _] => clear H x end. Ltac simpobs := fold_observe; repeat match goal with [H: _ = observe _ |- _] => rewrite_everywhere_except (@eq_sym _ _ _ H) H @@ -152,7 +152,7 @@ CoFixpoint spin {E R} : itree E R := Tau spin. (** Repeat a computation infinitely. *) Definition forever {E R S} (t : itree E R) : itree E S := - cofix forever_t := bind t (fun _ => Tau forever_t). + cofix forever_t := Tau (bind t (fun _ => forever_t)). (* this definition exists in ExtLib (or should because it is * generic to Monads) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index f9030cfa..0d0ae001 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -84,13 +84,15 @@ Notation "t1 ≅ t2" := (eq_itree eq t1%itree t2%itree) (at level 70). Section eq_itree_h. -Lemma itree_eq_tau {E R1 R2 RR} (t1 : itree E R1) (t2 : itree E R2) : +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Lemma itree_eq_tau (t1 : itree E R1) (t2 : itree E R2) : eq_itree RR t1 t2 -> eq_itree RR (Tau t1) (Tau t2). Proof. intro; pfold. econstructor. left. assumption. Qed. -Lemma itree_eq_vis {E U R1 R2 RR} (e : E U) +Lemma itree_eq_vis {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : (forall u, eq_itree RR (k1 u) (k2 u)) -> eq_itree RR (Vis e k1) (Vis e k2). @@ -98,8 +100,65 @@ Proof. intro H; pfold. econstructor. intros v. left. eapply H. Qed. +Inductive eq_itree_trans_clo (r : itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| eq_itree_trans_clo_intro t1 t2 t3 t4 + (EQVl: eq_itree eq t1 t2) + (EQVr: eq_itree eq t4 t3) + (RELATED: r t2 t3) + : eq_itree_trans_clo r t1 t4 +. +Hint Constructors eq_itree_trans_clo. + +Lemma eq_itree_clo_trans : weak_respectful2 (eq_itree_ RR) eq_itree_trans_clo. +Proof. + econstructor; [pmonauto|]. + intros. dependent destruction PR. + apply GF in RELATED. + punfold EQVl. punfold EQVr. red in RELATED. red. unfold_eq_itree. + inversion EQVl; clear EQVl; + inversion EQVr; clear EQVr; + inversion RELATED; clear RELATED; + subst; simpobs; try discriminate. + + - inversion H0; inversion H3; auto. + - inversion H; inversion H3; subst; pclearbot; eauto using rclo2. + + - inversion H; inversion H3; subst; auto_inj_pair2; subst. + pclearbot. + econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto using rclo2. +Qed. + +Inductive eq_itree_bind_clo (r : itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| pbc_intro_h U1 U2 (RU : U1 -> U2 -> Prop) t1 t2 k1 k2 + (EQV: eq_itree RU t1 t2) + (REL: forall u1 u2, RU u1 u2 -> r (k1 u1) (k2 u2)) + : eq_itree_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) +. +Hint Constructors eq_itree_bind_clo. + +Lemma eq_itree_clo_bind : + weak_respectful2 (eq_itree_ RR) eq_itree_bind_clo. +Proof. + econstructor; try pmonauto. + intros. dependent destruction PR. + punfold EQV. unfold_eq_itree. + rewrite !unfold_bind; inv EQV; simpobs. + - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. + - simpl. fold_bind. pclearbot. eauto 7 using rclo2. + - econstructor. + intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. +Qed. + End eq_itree_h. +Arguments eq_itree_clo_trans : clear implicits. +Arguments eq_itree_clo_bind : clear implicits. + +Hint Constructors eq_itree_trans_clo. +Hint Constructors eq_itree_bind_clo. + Section eq_itree_eq. Context {E : Type -> Type} {R : Type}. @@ -187,35 +246,6 @@ Proof. constructor; red in H. pfold; econstructor. left. apply H. Qed. -Inductive eq_itree_trans_clo (r : itree E R -> itree E R -> Prop) : - itree E R -> itree E R -> Prop := -| eq_itree_trans_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: eq_itree t1 t2) - (EQVr: eq_itree t4 t3) - (RELATED: r t2 t3) - : eq_itree_trans_clo r t1 t4 -. -Hint Constructors eq_itree_trans_clo. - -Lemma eq_itree_clo_trans : weak_respectful2 eq_itree_ eq_itree_trans_clo. -Proof. - econstructor; [pmonauto|]. - intros. dependent destruction PR. - apply GF in RELATED. - punfold EQVl. punfold EQVr. red in RELATED. red. unfold_eq_itree. - inversion EQVl; clear EQVl; - inversion EQVr; clear EQVr; - inversion RELATED; clear RELATED; - subst; simpobs; try discriminate. - - - inversion H0; inversion H3; auto. - - inversion H; inversion H3; subst; pclearbot; eauto using rclo2. - - - inversion H; inversion H3; subst; auto_inj_pair2; subst. - pclearbot. - econstructor. intros. specialize (REL v). specialize (REL0 v). pclearbot. eauto using rclo2. -Qed. - Global Instance observing_eq_itree_eq_ r `{Reflexive _ r} : subrelation (observing eq) (eq_itree_ r). Proof. @@ -229,18 +259,14 @@ Qed. left; apply reflexivity. Qed. -(* TODO: This should follow from [itree_eta_] and [observing eq] - being a subrelation of [eq_itree], but at the moment instance - resolution is somehow slow for [observing eq]. - (e.g., [interp_bind]) *) -Lemma itree_eta (t: itree E R): eq_itree t (go (observe t)). -Proof. rewrite <- itree_eta_. reflexivity. Qed. +Lemma itree_eta (t : itree E R) : t ≅ go (observe t). +Proof. apply observing_eq_itree_eq. econstructor. reflexivity. Qed. -End eq_itree_eq. +Lemma itree_eta' (ot : itree' E R) : ot = observe (go ot). +Proof. reflexivity. Qed. -Arguments eq_itree_clo_trans : clear implicits. +End eq_itree_eq. -Hint Constructors eq_itree_trans_clo. Lemma eq_itree_tau {E R1 R2} (RR : R1 -> R2 -> Prop) (t1 : itree E R1) (t2 : itree E R2) : @@ -308,6 +334,7 @@ Qed. (* TODO (LATER): I keep these [...bind_] lemmas around temporarily in case I run some issues with slow typeclass resolution. *) + Lemma unfold_bind_ {E R S} (t : itree E R) (k : R -> itree E S) : ITree.bind t k ≅ ITree.bind_match k (fun t => ITree.bind t k) (observe t). @@ -315,58 +342,15 @@ Proof. rewrite unfold_bind. reflexivity. Qed. Lemma ret_bind_ {E R S} (r : R) (k : R -> itree E S) : ITree.bind (Ret r) k ≅ (k r). -Proof. apply unfold_bind_. Qed. +Proof. rewrite ret_bind. reflexivity. Qed. Lemma tau_bind_ {E R} U t (k: U -> itree E R) : ITree.bind (Tau t) k ≅ Tau (ITree.bind t k). -Proof. apply @unfold_bind_. Qed. +Proof. rewrite tau_bind. reflexivity. Qed. Lemma vis_bind_ {E R} U V (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : ITree.bind (Vis e ek) k ≅ Vis e (fun x => ITree.bind (ek x) k). -Proof. apply @unfold_bind_. Qed. - -Inductive eq_itree_bind_clo_h {E R1 R2} (RR : R1 -> R2 -> Prop) - (r : itree E R1 -> itree E R2 -> Prop) : - itree E R1 -> itree E R2 -> Prop := -| pbc_intro_h U1 U2 (RU : U1 -> U2 -> Prop) t1 t2 k1 k2 - (EQV: eq_itree RU t1 t2) - (REL: forall u1 u2, RU u1 u2 -> r (k1 u1) (k2 u2)) - : eq_itree_bind_clo_h RR r (ITree.bind t1 k1) (ITree.bind t2 k2) -. -Hint Constructors eq_itree_bind_clo_h. - -Lemma eq_itree_clo_bind_h E R1 R2 (RR : R1 -> R2 -> Prop) : - weak_respectful2 (eq_itree_ RR) (@eq_itree_bind_clo_h E _ _ RR). -Proof. - econstructor; try pmonauto. - intros. dependent destruction PR. - punfold EQV. unfold_eq_itree. - rewrite !unfold_bind; inv EQV; simpobs. - - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. - - simpl. fold_bind. pclearbot. eauto 7 using rclo2. - - econstructor. - intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. -Qed. - -Inductive eq_itree_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| pbc_intro U t1 t2 (k1 k2: U -> _) - (EQV: t1 ≅ t2) - (REL: forall v, r (k1 v) (k2 v)) - : eq_itree_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) -. -Hint Constructors eq_itree_bind_clo. - -Lemma eq_itree_clo_bind E R: weak_respectful2 (eq_itree_ eq) (@eq_itree_bind_clo E R). -Proof. - econstructor; try pmonauto. - intros. dependent destruction PR. - punfold EQV. unfold_eq_itree. - rewrite !unfold_bind; inv EQV; simpobs. - - eapply eq_itreeF_mono; [eapply GF |]; eauto using rclo2. - - simpl. fold_bind. pclearbot. eauto 7 using rclo2. - - econstructor. - intros x. specialize (REL0 x). fold_bind. pclearbot. eauto 7 using rclo2. -Qed. +Proof. rewrite vis_bind. reflexivity. Qed. Lemma eq_itree_bind {E R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) (RS : S1 -> S2 -> Prop) @@ -376,7 +360,7 @@ Lemma eq_itree_bind {E R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) @eq_itree E _ _ RS (ITree.bind t1 k1) (ITree.bind t2 k2). Proof. repeat intro. pupto2_init. - pupto2 eq_itree_clo_bind_h. econstructor; eauto. + pupto2 eq_itree_clo_bind. econstructor; eauto. intros. pupto2_final; apply H0; auto. Qed. diff --git a/theories/Eq/Shallow.v b/theories/Eq/Shallow.v index b6b540f5..16ed7bfe 100644 --- a/theories/Eq/Shallow.v +++ b/theories/Eq/Shallow.v @@ -66,12 +66,6 @@ Proof. - intros ? ? ? [] []; eauto. Qed. -(* TODO: Ideally, this should subsume [Eq.Eq.itree_eta], - see note over there. *) -Lemma itree_eta_ (t : itree E R) : - observing eq t (go (observe t)). -Proof. auto. Qed. - End observing_relations. Lemma unfold_bind {E R S} @@ -103,6 +97,10 @@ Lemma vis_bind {E R U V} (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : (Vis e (fun x => ITree.bind (ek x) k)). Proof. apply @unfold_bind. Qed. +Lemma unfold_forever {E R S} (t: itree E R): + observing eq (@ITree.forever E R S t) (Tau (ITree.bind t (fun _ => ITree.forever t))). +Proof. econstructor. reflexivity. Qed. + (** ** [going]: Lift relations through [go]. *) Inductive going {E R1 R2} (r : itree E R1 -> itree E R2 -> Prop) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index 61c30677..003e776d 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -19,12 +19,14 @@ From Coq Require Import Classes.RelationClasses Classes.Morphisms Setoids.Setoid + Program Relations.Relations. From ITree Require Import Core. From ITree Require Import + Eq.UpToTausExplicit Eq.UpToTaus. Section SUTT. @@ -151,6 +153,7 @@ Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) : forall (t1 : itree E R1) (t2 : itree E R2), sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2. Proof. + intros. apply euttE_impl_eutt. revert_until RR. pcofix self; intros t1 t2 H1 H2. punfold H1. punfold H2. destruct H1 as [FIN1 EQV1], H2 as [FIN2 EQV2]. @@ -171,6 +174,7 @@ Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) r : forall (t1 : itree E R1) (t2 : itree E R2), paco2 (eutt_ RR) r t1 t2 -> paco2 (sutt_ RR) r t1 t2. Proof. + intros. apply eutt_impl_euttE in H. revert_until r. pcofix self; intros t1 t2 H1. punfold H1. destruct H1 as [FIN1 EQV1]. @@ -423,7 +427,7 @@ Proof. { intros; eapply H. } punfold H0. pfold. red. - do 2 rewrite interp_unfold. + do 2 rewrite unfold_interp. induction H0; eauto. { subst. cbn. constructor. admit. intros. @@ -468,17 +472,16 @@ Qed. (** Generalized heterogeneous version of [eutt_bind] *) Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: forall t1 t2, - eutt RR t1 t2 -> - forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + euttE RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> euttE SS (s1 r1) (s2 r2)) -> @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). Proof. - intros. apply sutt_eutt; eapply sutt_bind_gen. - - apply eutt_sutt; eassumption. + intros. apply euttE_impl_eutt in H. setoid_rewrite <-eutt_is_euttE in H0. + apply sutt_eutt; eapply sutt_bind_gen. + - apply eutt_sutt. eassumption. - intros. apply eutt_sutt. apply H0; auto. - apply eutt_sutt. eapply Symmetric_eutt_; try eassumption; auto. intros ? ? HH; apply HH. - - simpl. intros. apply eutt_sutt. eapply Symmetric_eutt_; try eassumption; eauto. - 2: eapply H0; auto. - auto. + - simpl. intros. apply eutt_sutt. eapply Symmetric_eutt_; eauto; auto. Qed. diff --git a/theories/Eq/Untaus.v b/theories/Eq/Untaus.v new file mode 100644 index 00000000..fb67db2d --- /dev/null +++ b/theories/Eq/Untaus.v @@ -0,0 +1,319 @@ +Require Import Paco.paco. + +From Coq Require Import + Program + Lia + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations. + +From ITree Require Import + Core. + +From ITree Require Export + Eq.Eq. + +Local Open Scope itree. + +(* Taken from paco-v2.0.3: BEGIN *) + +Lemma paco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 + (REL: paco2 gf bot2 x0 x1) + (LEgf: gf <3= gf'): + paco2 gf' r' x0 x1. +Proof. + eapply paco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. +Qed. + +Lemma upaco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 + (REL: upaco2 gf bot2 x0 x1) + (LEgf: gf <3= gf'): + upaco2 gf' r' x0 x1. +Proof. + eapply upaco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. +Qed. + +Lemma rclo2_mon_gen {T0 T1} gf gf' (clo clo': rel2 T0 T1 -> rel2 T0 T1) r r' e0 e1 + (REL: rclo2 gf clo r e0 e1) + (LEgf: gf <3= gf') + (LEclo: clo <3= clo') + (LEr: r <2= r') : + rclo2 gf' clo' r' e0 e1. +Proof. + induction REL. + - econstructor 1. apply LEr, R. + - econstructor 2; [intros; eapply H, PR| apply LEclo, CLOR']. + - econstructor 3; [intros; eapply H, PR| apply LEgf, CLOR']. +Qed. + +(* Taken from paco-v2.0.3: END*) + + + +Section FiniteTaus. + +Context {E : Type -> Type} {R : Type}. + +(* [notau t] holds when [t] does not start with a [Tau]. *) +Definition notauF {I} (t : itreeF E R I) : Prop := + match t with + | TauF _ => False + | _ => True + end. + +Notation notau t := (notauF (observe t)). + +(* [untaus t t'] holds when [t = Tau (... Tau t' ...)]: + [t] steps to [t'] by "peeling off" a finite number of [Tau]. + "Peel off" means to remove only taus at the root of the tree, + not any behind a [Vis] step). *) +Inductive untausF : + itreeF E R (itree E R) -> itreeF E R (itree E R) -> Prop := +| NoTau ot0 : untausF ot0 ot0 +| OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 +. +Hint Constructors untausF. + +Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. +Hint Unfold unalltausF. + +Lemma unalltausF_untausF ot ot0 : unalltausF ot ot0 -> untausF ot ot0. +Proof. intros []; auto. Qed. +Hint Resolve unalltausF_untausF. + +Lemma unalltausF_notauF ot ot0 : unalltausF ot ot0 -> notauF ot0. +Proof. intros []; auto. Qed. +Hint Resolve unalltausF_notauF. + +(* [finite_taus t] holds when [t] has a finite number of taus + to peel. *) +Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. +Hint Unfold finite_tausF. + +(** ** Lemmas *) + +Lemma untaus_all ot ot' : + untausF ot ot' -> notauF ot' -> unalltausF ot ot'. +Proof. induction 1; eauto. Qed. + +Lemma unalltaus_notau ot ot' : unalltausF ot ot' -> notauF ot'. +Proof. intros. induction H; eauto. Qed. + +Lemma notau_tau I (ot : itreeF E R I) (t0 : I) + (NOTAU : notauF ot) + (OBS: TauF t0 = ot): False. +Proof. subst. auto. Qed. +Hint Resolve notau_tau. + +Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. +Proof. subst. red. eauto. Qed. +Hint Resolve notau_ret. + +Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : notauF ot. +Proof. intros. subst. red. eauto. Qed. +Hint Resolve notau_vis. + +(* If [t] does not start with [Tau], removing all [Tau] does + nothing. Can be thought of as [notau_unalltaus] composed with + [unalltaus_injective] (below). *) +Lemma unalltaus_notau_id ot ot' : + unalltausF ot ot' -> notauF ot -> ot = ot'. +Proof. + intros [[ | ]] ?; eauto. exfalso; eauto. +Qed. + +(* There is only one way to peel off all taus. *) +Lemma unalltaus_injective ot ot1 ot2 : + unalltausF ot ot1 -> unalltausF ot ot2 -> ot1 = ot2. +Proof. + intros [Huntaus Hnotau]. revert ot2 Hnotau. + induction Huntaus; intros; eauto using unalltaus_notau_id. + eapply IHHuntaus; eauto. + destruct H as [Huntaus' Hnotau']. + destruct Huntaus'. + + exfalso; eauto. + + subst. inversion OBS0; subst; eauto. +Qed. + +(* Adding a [Tau] to [t1] then peeling them all off produces + the same result as peeling them all off from [t1]. *) +Lemma unalltaus_tau t ot1 ot2 + (OBS: TauF t = ot1) + (TAUS: unalltausF ot1 ot2): + unalltausF (observe t) ot2. +Proof. + destruct TAUS as [Huntaus Hnotau]. + destruct Huntaus. + - exfalso; eauto. + - subst; inversion OBS0; subst; eauto. +Qed. + +Lemma unalltaus_tau' t ot1 ot2 + (OBS: TauF t = ot1) + (TAUS: unalltausF (observe t) ot2): + unalltausF ot1 ot2. +Proof. + destruct TAUS as [Huntaus Hnotau]. + subst. eauto. +Qed. + +Lemma notauF_untausF ot1 ot2 + (NOTAU : notauF ot1) + (UNTAUS : untausF ot1 ot2) : ot1 = ot2. +Proof. + destruct UNTAUS; eauto. + exfalso; eauto. +Qed. + +Definition untausF_shift (t1 t2 : itree E R) : + untausF (TauF t1) (TauF t2) -> untausF (observe t1) (observe t2). +Proof. + intros H. + inversion H; subst. + { constructor. } + clear H. + inversion OBS; subst; clear OBS. + remember (observe t1) as ot1. + remember (TauF t2) as tt2. + generalize dependent t1. + generalize dependent t2. + induction TAUS; intros; subst; econstructor; eauto. +Qed. + +Definition untausF_trans (t1 t2 t3 : itreeF E R _) : + untausF t1 t2 -> untausF t2 t3 -> untausF t1 t3. +Proof. + induction 1; auto. + subst; econstructor; auto. +Qed. + +Definition untausF_strong_ind + (P : itreeF E R _ -> Prop) + (ot1 ot2 : itreeF E R _) + (Huntaus : untausF ot1 ot2) + (Hnotau : notauF ot2) + (STEP : forall ot1 + (Huntaus : untausF ot1 ot2) + (IH: forall t1' oti + (NEXT: ot1 = TauF t1') + (UNTAUS: untausF (observe t1') oti), + P oti), + P ot1) + : P ot1. +Proof. + enough (H : forall oti, + untausF ot1 oti -> + untausF oti ot2 -> + P oti + ). + { apply H; eauto. } + revert STEP. + induction Huntaus; intros; subst. + - eapply STEP; eauto. + intros; subst. dependent destruction H; inv Hnotau. + - destruct H0; auto. + subst. apply STEP; eauto. + intros. inv NEXT. + apply IHHuntaus; eauto. + + clear -H UNTAUS. + remember (TauF t') as ott'. remember (TauF t1') as ott1'. + move H at top. revert_until H. induction H; intros; subst. + * inv Heqott1'. eauto. + * inv Heqott'. dependent destruction H; eauto. + + genobs t1' ot1'. revert UNTAUS. clear -Hnotau H0. induction H0; intros. + * dependent destruction UNTAUS; eauto. + subst. simpobs. inv Hnotau. + * subst. dependent destruction UNTAUS; eauto. +Qed. + +(* If [t] does not start with [Tau], then it starts with finitely + many [Tau]. *) +Lemma notau_finite_taus ot : notauF ot -> finite_tausF ot. +Proof. eauto. Qed. + +(* [Vis] and [Ret] start with no taus, of course. *) +Lemma finite_taus_ret ot (r : R) (OBS: RetF r = ot) : finite_tausF ot. +Proof. eauto 10. Qed. + +Lemma finite_taus_vis {u} ot (e : E u) (k : u -> itree E R) (OBS: VisF e k = ot): + finite_tausF ot. +Proof. eauto 10. Qed. + +(* [finite_taus] is preserved by removing or adding one [Tau]. *) +Lemma finite_taus_tau t': + finite_tausF (TauF t') <-> finite_tausF (observe t'). +Proof. + split; intros [? [Huntaus Hnotau]]; eauto 10. + inv Huntaus. + - contradiction. + - inv OBS; eauto. +Qed. + +(* (* [finite_taus] is preserved by removing or adding any finite *) +(* number of [Tau]. *) *) +Lemma untaus_finite_taus ot ot': + untausF ot ot' -> (finite_tausF ot <-> finite_tausF ot'). +Proof. + induction 1; intros; subst. + - reflexivity. + - erewrite finite_taus_tau; eauto. +Qed. + +Lemma untaus_untaus : forall (ot1 ot2 ot3: itreeF E R _), + untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. +Proof. + intros t1 t2 t3. induction 1; simpl; eauto. +Qed. + +Lemma untaus_unalltaus_rev (ot1 ot2 ot3: itreeF E R _) : + untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. +Proof. + intros H. revert ot3. + induction H; intros. + - eauto with arith. + - destruct H0 as [Huntaus Hnotau]. + destruct Huntaus. + + exfalso; eauto. + + inv OBS0. inversion H0; subst; eauto. +Qed. + +Lemma unalltausF_ret : forall x (t: itree' E R), + unalltausF (RetF x) t -> t = RetF x. +Proof. + intros x t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. +Qed. + +Lemma unalltausF_vis {S}: forall e (k: S -> itree E R) (t: itree' E R), + unalltausF (VisF e k) t -> t = VisF e k. +Proof. + intros e k t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. +Qed. + +End FiniteTaus. + +Arguments untaus_unalltaus_rev : clear implicits. + +Hint Resolve unalltausF_notauF. +Hint Resolve unalltausF_untausF. + +Hint Constructors untausF. +Hint Unfold unalltausF. +Hint Unfold finite_tausF. +Hint Resolve notau_ret. +Hint Resolve notau_vis. +Hint Resolve notau_tau. + +Notation finite_taus t := (finite_tausF (observe t)). +Notation untaus t t' := (untausF (observe t) (observe t')). +Notation unalltaus t t' := (unalltausF (observe t) (observe t')). + +Ltac auto_untaus := + repeat match goal with + | [ H1 : notauF ?X, H2 : unalltausF ?X ?Y |- _ ] => + assert_fails (unify X Y); + replace Y with X in * by apply (unalltaus_notau_id _ _ H2 H1) + | [ H1 : unalltausF ?X ?Y, H2 : unalltausF ?X ?Z |- _ ] => + assert_fails (unify Y Z); + replace Z with Y in * by apply (unalltaus_injective _ _ _ H1 H2) + end; auto. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index db328429..0eefc02c 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -27,364 +27,59 @@ From Coq Require Import Relations.Relations. From ITree Require Import - Core. + Core + UpToTausExplicit. From ITree Require Export Eq.Eq. Local Open Scope itree. -Section FiniteTaus. - -Context {E : Type -> Type} {R : Type}. - -(* [notau t] holds when [t] does not start with a [Tau]. *) -Definition notauF {I} (t : itreeF E R I) : Prop := - match t with - | TauF _ => False - | _ => True - end. - -Notation notau t := (notauF (observe t)). - -(* [untaus t t'] holds when [t = Tau (... Tau t' ...)]: - [t] steps to [t'] by "peeling off" a finite number of [Tau]. - "Peel off" means to remove only taus at the root of the tree, - not any behind a [Vis] step). *) -Inductive untausF : - itreeF E R (itree E R) -> itreeF E R (itree E R) -> Prop := -| NoTau ot0 : untausF ot0 ot0 -| OneTau ot t' ot0 (OBS: TauF t' = ot) (TAUS: untausF (observe t') ot0): untausF ot ot0 -. -Hint Constructors untausF. - -Definition unalltausF ot ot0 := untausF ot ot0 /\ notauF ot0. -Hint Unfold unalltausF. - -Lemma unalltausF_untausF ot ot0 : unalltausF ot ot0 -> untausF ot ot0. -Proof. intros []; auto. Qed. -Hint Resolve unalltausF_untausF. - -Lemma unalltausF_notauF ot ot0 : unalltausF ot ot0 -> notauF ot0. -Proof. intros []; auto. Qed. -Hint Resolve unalltausF_notauF. - -(* [finite_taus t] holds when [t] has a finite number of taus - to peel. *) -Definition finite_tausF ot : Prop := exists ot', unalltausF ot ot'. -Hint Unfold finite_tausF. - -(** ** Lemmas *) - -Lemma untaus_all ot ot' : - untausF ot ot' -> notauF ot' -> unalltausF ot ot'. -Proof. induction 1; eauto. Qed. - -Lemma unalltaus_notau ot ot' : unalltausF ot ot' -> notauF ot'. -Proof. intros. induction H; eauto. Qed. - -Lemma notau_tau I (ot : itreeF E R I) (t0 : I) - (NOTAU : notauF ot) - (OBS: TauF t0 = ot): False. -Proof. subst. auto. Qed. -Hint Resolve notau_tau. - -Lemma notau_ret I (ot: itreeF E R I) r (OBS: RetF r = ot) : notauF ot. -Proof. subst. red. eauto. Qed. -Hint Resolve notau_ret. - -Lemma notau_vis I (ot : itreeF E R I) u (e: E u) k (OBS: VisF e k = ot) : notauF ot. -Proof. intros. subst. red. eauto. Qed. -Hint Resolve notau_vis. - -(* If [t] does not start with [Tau], removing all [Tau] does - nothing. Can be thought of as [notau_unalltaus] composed with - [unalltaus_injective] (below). *) -Lemma unalltaus_notau_id ot ot' : - unalltausF ot ot' -> notauF ot -> ot = ot'. -Proof. - intros [[ | ]] ?; eauto. exfalso; eauto. -Qed. - -(* There is only one way to peel off all taus. *) -Lemma unalltaus_injective ot ot1 ot2 : - unalltausF ot ot1 -> unalltausF ot ot2 -> ot1 = ot2. -Proof. - intros [Huntaus Hnotau]. revert ot2 Hnotau. - induction Huntaus; intros; eauto using unalltaus_notau_id. - eapply IHHuntaus; eauto. - destruct H as [Huntaus' Hnotau']. - destruct Huntaus'. - + exfalso; eauto. - + subst. inversion OBS0; subst; eauto. -Qed. - -(* Adding a [Tau] to [t1] then peeling them all off produces - the same result as peeling them all off from [t1]. *) -Lemma unalltaus_tau t ot1 ot2 - (OBS: TauF t = ot1) - (TAUS: unalltausF ot1 ot2): - unalltausF (observe t) ot2. -Proof. - destruct TAUS as [Huntaus Hnotau]. - destruct Huntaus. - - exfalso; eauto. - - subst; inversion OBS0; subst; eauto. -Qed. - -Lemma unalltaus_tau' t ot1 ot2 - (OBS: TauF t = ot1) - (TAUS: unalltausF (observe t) ot2): - unalltausF ot1 ot2. -Proof. - destruct TAUS as [Huntaus Hnotau]. - subst. eauto. -Qed. - -Lemma notauF_untausF ot1 ot2 - (NOTAU : notauF ot1) - (UNTAUS : untausF ot1 ot2) : ot1 = ot2. -Proof. - destruct UNTAUS; eauto. - exfalso; eauto. -Qed. - -Definition untausF_shift (t1 t2 : itree E R) : - untausF (TauF t1) (TauF t2) -> untausF (observe t1) (observe t2). -Proof. - intros H. - inversion H; subst. - { constructor. } - clear H. - inversion OBS; subst; clear OBS. - remember (observe t1) as ot1. - remember (TauF t2) as tt2. - generalize dependent t1. - generalize dependent t2. - induction TAUS; intros; subst; econstructor; eauto. -Qed. - -Definition untausF_trans (t1 t2 t3 : itreeF E R _) : - untausF t1 t2 -> untausF t2 t3 -> untausF t1 t3. -Proof. - induction 1; auto. - subst; econstructor; auto. -Qed. - -Definition untausF_strong_ind - (P : itreeF E R _ -> Prop) - (ot1 ot2 : itreeF E R _) - (Huntaus : untausF ot1 ot2) - (Hnotau : notauF ot2) - (STEP : forall ot1 - (Huntaus : untausF ot1 ot2) - (IH: forall t1' oti - (NEXT: ot1 = TauF t1') - (UNTAUS: untausF (observe t1') oti), - P oti), - P ot1) - : P ot1. -Proof. - enough (H : forall oti, - untausF ot1 oti -> - untausF oti ot2 -> - P oti - ). - { apply H; eauto. } - revert STEP. - induction Huntaus; intros; subst. - - eapply STEP; eauto. - intros; subst. dependent destruction H; inv Hnotau. - - destruct H0; auto. - subst. apply STEP; eauto. - intros. inv NEXT. - apply IHHuntaus; eauto. - + clear -H UNTAUS. - remember (TauF t') as ott'. remember (TauF t1') as ott1'. - move H at top. revert_until H. induction H; intros; subst. - * inv Heqott1'. eauto. - * inv Heqott'. dependent destruction H; eauto. - + genobs t1' ot1'. revert UNTAUS. clear -Hnotau H0. induction H0; intros. - * dependent destruction UNTAUS; eauto. - subst. simpobs. inv Hnotau. - * subst. dependent destruction UNTAUS; eauto. -Qed. - -(* If [t] does not start with [Tau], then it starts with finitely - many [Tau]. *) -Lemma notau_finite_taus ot : notauF ot -> finite_tausF ot. -Proof. eauto. Qed. - -(* [Vis] and [Ret] start with no taus, of course. *) -Lemma finite_taus_ret ot (r : R) (OBS: RetF r = ot) : finite_tausF ot. -Proof. eauto 10. Qed. - -Lemma finite_taus_vis {u} ot (e : E u) (k : u -> itree E R) (OBS: VisF e k = ot): - finite_tausF ot. -Proof. eauto 10. Qed. - -(* [finite_taus] is preserved by removing or adding one [Tau]. *) -Lemma finite_taus_tau t': - finite_tausF (TauF t') <-> finite_tausF (observe t'). -Proof. - split; intros [? [Huntaus Hnotau]]; eauto 10. - inv Huntaus. - - contradiction. - - inv OBS; eauto. -Qed. - -(* (* [finite_taus] is preserved by removing or adding any finite *) -(* number of [Tau]. *) *) -Lemma untaus_finite_taus ot ot': - untausF ot ot' -> (finite_tausF ot <-> finite_tausF ot'). -Proof. - induction 1; intros; subst. - - reflexivity. - - erewrite finite_taus_tau; eauto. -Qed. - -Lemma untaus_untaus : forall (ot1 ot2 ot3: itreeF E R _), - untausF ot1 ot2 -> untausF ot2 ot3 -> untausF ot1 ot3. -Proof. - intros t1 t2 t3. induction 1; simpl; eauto. -Qed. - -Lemma untaus_unalltaus_rev (ot1 ot2 ot3: itreeF E R _) : - untausF ot1 ot2 -> unalltausF ot1 ot3 -> unalltausF ot2 ot3. -Proof. - intros H. revert ot3. - induction H; intros. - - eauto with arith. - - destruct H0 as [Huntaus Hnotau]. - destruct Huntaus. - + exfalso; eauto. - + inv OBS0. inversion H0; subst; eauto. -Qed. - -Lemma unalltausF_ret : forall x (t: itree' E R), - unalltausF (RetF x) t -> t = RetF x. -Proof. - intros x t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. -Qed. - -Lemma unalltausF_vis {S}: forall e (k: S -> itree E R) (t: itree' E R), - unalltausF (VisF e k) t -> t = VisF e k. -Proof. - intros e k t [UNT NOT]; inversion UNT; subst; clear UNT; [reflexivity | easy]. -Qed. - -End FiniteTaus. - -Arguments untaus_unalltaus_rev : clear implicits. - -Hint Resolve unalltausF_notauF. -Hint Resolve unalltausF_untausF. - -Hint Constructors untausF. -Hint Unfold unalltausF. -Hint Unfold finite_tausF. -Hint Resolve notau_ret. -Hint Resolve notau_vis. -Hint Resolve notau_tau. - -Notation finite_taus t := (finite_tausF (observe t)). -Notation untaus t t' := (untausF (observe t) (observe t')). -Notation unalltaus t t' := (unalltausF (observe t) (observe t')). - -Ltac auto_untaus := - repeat match goal with - | [ H1 : notauF ?X, H2 : unalltausF ?X ?Y |- _ ] => - assert_fails (unify X Y); - replace Y with X in * by apply (unalltaus_notau_id _ _ H2 H1) - | [ H1 : unalltausF ?X ?Y, H2 : unalltausF ?X ?Z |- _ ] => - assert_fails (unify Y Z); - replace Z with Y in * by apply (unalltaus_injective _ _ _ H1 H2) - end; auto. Section EUTT. Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -(* Equivalence between visible steps of computation (i.e., [Vis] or - [Ret], parameterized by a relation [eutt] between continuations - in the [Vis] case. *) -Variant eq_notauF {I J} (eutt : I -> J -> Prop) -: itreeF E R1 I -> itreeF E R2 J -> Prop := -| Eutt_ret : forall r1 r2, - RR r1 r2 -> - eq_notauF eutt (RetF r1) (RetF r2) -| Eutt_vis : forall u (e : E u) k1 k2, - (forall x, eutt (k1 x) (k2 x)) -> - eq_notauF eutt (VisF e k1) (VisF e k2). -Hint Constructors eq_notauF. - -Lemma eq_notauF_vis_inv1 {I J} {eutt : I -> J -> Prop} {U} - ot (e : E U) k : - eq_notauF eutt ot (VisF e k) -> - exists k', - ot = VisF e k' /\ (forall x, eutt (k' x) (k x)). -Proof. - intros. remember (VisF e k) as t. - inversion H; subst; try discriminate. - inversion H2; subst; auto_inj_pair2; subst; eauto. -Qed. - -(* -Variant eq_notauF' {I} (eutt : relation I) -: relation (itreeF E R I) := -| Eutt_ret' : forall r, eq_notauF' eutt (RetF r) (RetF r) -| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, - eq_dep _ E _ e1 _ e2 -> - (forall x1 x2, JMeq x1 x2 -> eutt (k1 x1) (k2 x2)) -> - eq_notauF' eutt (VisF e1 k1) (VisF e2 k2). -Hint Constructors eq_notauF'. - -Lemma eq_notauF_eq_eq_notauF': forall I (eutt : relation I) t s, - eq_notauF eutt t s <-> eq_notauF' eutt t s. -Proof. - split; intros EUTT; destruct EUTT; eauto. - - econstructor; intros; subst; eauto. - - assert (u1 = u2) by (inv H; eauto). - subst. apply eq_dep_eq in H. subst. eauto. -Qed. -*) - -(* [eutt_ eutt t1 t2] means that, if [t1] or [t2] ever takes a - visible step ([Vis] or [Ret]), then the other takes the same - step, and the subsequent continuations (in the [Vis] case) are - related by [eutt]. In particular, [(t1 = spin)%eq_itree] if - and only if [(t2 = spin)%eq_itree]. Note also that in that - case, the parameter [eutt] is irrelevant. - - This is the relation we will take a fixpoint of. *) -Inductive euttF (eutt : itree E R1 -> itree E R2 -> Prop) - (ot1 : itreeF E R1 (itree E R1)) - (ot2 : itreeF E R2 (itree E R2)) : Prop := -| euttF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) - (EQV: forall ot1' ot2' - (UNTAUS1: unalltausF ot1 ot1') - (UNTAUS2: unalltausF ot2 ot2'), - eq_notauF eutt ot1' ot2') +Inductive euttF + (eutt: itree E R1 -> itree E R2 -> Prop) + (eutt_taus: itreeF E R1 _ -> itreeF E R2 _ -> Prop) + : itreeF E R1 _ -> itreeF E R2 _ -> Prop := +| euttF_ret r1 r2 + (RBASE: RR r1 r2): + euttF eutt eutt_taus (RetF r1) (RetF r2) +| euttF_vis u (e : E u) k1 k2 + (EUTTK: forall x, eutt (k1 x) (k2 x)): + euttF eutt eutt_taus (VisF e k1) (VisF e k2) +| euttF_tau_tau t1 t2 + (EQTAUS: eutt_taus (observe t1) (observe t2)): + euttF eutt eutt_taus (TauF t1) (TauF t2) +| euttF_tau_left t1 ot2 + (EQTAUS: euttF eutt eutt_taus (observe t1) ot2): + euttF eutt eutt_taus (TauF t1) ot2 +| euttF_tau_right ot1 t2 + (EQTAUS: euttF eutt eutt_taus ot1 (observe t2)): + euttF eutt eutt_taus ot1 (TauF t2) . Hint Constructors euttF. -Definition eutt_ (eutt : itree E R1 -> itree E R2 -> Prop) - (t1 : itree E R1) (t2 : itree E R2) : Prop := - euttF eutt (observe t1) (observe t2). +Definition eutt_ eutt t1 t2 := paco2 (euttF eutt) bot2 (observe t1) (observe t2). Hint Unfold eutt_. -(* Paco takes the greatest fixpoints of monotone relations. *) +Lemma euttF_mon r r' s s' x y + (EUTT: euttF r s x y) + (LEr: r <2= r') + (LEs: s <2= s'): + euttF r' s' x y. +Proof. + induction EUTT; eauto. +Qed. -Lemma monotone_eq_notauF : forall I J (r r' : I -> J -> Prop) x1 x2 - (IN: eq_notauF r x1 x2) - (LE: r <2= r'), - eq_notauF r' x1 x2. -Proof. pmonauto. Qed. -Hint Resolve monotone_eq_notauF. +Lemma monotone_euttF eutt : monotone2 (euttF eutt). +Proof. repeat intro. eauto using euttF_mon. Qed. +Hint Resolve monotone_euttF : paco. -(* [eutt_] is monotone. *) Lemma monotone_eutt_ : monotone2 eutt_. -Proof. pmonauto. Qed. +Proof. red. eauto using euttF_mon, paco2_mon_gen. Qed. Hint Resolve monotone_eutt_ : paco. (* We now take the greatest fixpoint of [eutt_]. *) @@ -393,251 +88,62 @@ Hint Resolve monotone_eutt_ : paco. [eutt t1 t2]: [t1] is equivalent to [t2] up to taus. *) Definition eutt : itree E R1 -> itree E R2 -> Prop := paco2 eutt_ bot2. +Hint Unfold eutt. Global Arguments eutt t1%itree t2%itree. -Infix "≈" := eutt (at level 70) : itree_scope. - -(* Lemmas about the auxiliary relations. *) - -(* Many have a name [X_Y] to represent an implication - [X _ -> Y _] (possibly with more arguments on either side). *) - -(**) - -Lemma euttF_tau r t1 t2 t1' t2' - (OBS1: TauF t1' = observe t1) - (OBS2: TauF t2' = observe t2) - (REL: eutt_ r t1' t2'): - eutt_ r t1 t2. -Proof. - intros. destruct REL. econstructor. - - simpobs. rewrite !finite_taus_tau. eauto. - - intros. eapply EQV; eapply unalltaus_tau; eauto. -Qed. - -Lemma euttF_tau_left r t1 t2 t1' - (OBS: TauF t1 = observe t1') - (REL: eutt_ r t1' t2): - eutt_ r t1 t2. -Proof. - intros. destruct REL. econstructor. - - rewrite <- FIN. symmetry. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. - - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS1. constructor; auto. - econstructor; eauto. -Qed. - -Lemma euttF_tau_right r t1 t2 t2' - (OBS: TauF t2 = observe t2') - (REL: eutt_ r t1 t2'): - eutt_ r t1 t2. -Proof. - intros. destruct REL. econstructor. - - rewrite FIN. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. - - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. - econstructor; eauto. -Qed. - -Lemma euttF_vis {u} (r : _ -> _ -> Prop) t1 t2 (e : _ u) k1 k2 - (OBS1: VisF e k1 = observe t1) - (OBS2: VisF e k2 = observe t2) - (REL: forall x, r (k1 x) (k2 x)): - eutt_ r t1 t2. -Proof. - intros. econstructor. - - split; intros; eapply notau_finite_taus; eauto. - - intros. - apply unalltaus_notau_id in UNTAUS1; eauto. - apply unalltaus_notau_id in UNTAUS2; eauto. - simpobs. subst. eauto. -Qed. - -(**) - -Lemma eutt_strengthen : - forall r (t1 : itree E R1) (t2 : itree E R2) - (FIN: finite_taus t1 <-> finite_taus t2) - (EQV: forall t1' t2' - (UNT1: unalltaus t1 t1') - (UNT2: unalltaus t2 t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1' t2'), - paco2 (eutt_ ∘ gres2 eutt_) r t1 t2. -Proof. - intros. pfold. econstructor; eauto. - intros. - hexploit (EQV (go ot1') (go ot2')); eauto. - intros EQV'. punfold EQV'. destruct EQV'. - eapply EQV0; - repeat constructor; eauto. -Qed. - -(**) - -Lemma eq_unalltaus (t1 : itree E R1) (t2 : itree E R2) ot1' - (FT: unalltausF (observe t1) ot1') - (EQV: eq_itree RR t1 t2) : - exists ot2', unalltausF (observe t2) ot2'. -Proof. - genobs t1 ot1. revert t1 Heqot1 t2 EQV. - destruct FT as [Huntaus Hnotau]. - induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. - - eexists. constructor; eauto. inv EQV; simpl; eauto. - - inv EQV; simpobs; try inv Heqot1. - pclearbot. edestruct IHHuntaus as [? []]; eauto. -Qed. - -Lemma eq_unalltaus_eqF (t : itree E R1) (s : itree E R2) ot' - (UNTAUS : unalltausF (observe t) ot') - (EQV: eq_itree RR t s) : - exists os', unalltausF (observe s) os' /\ eq_itreeF RR (eq_itree RR) ot' os'. -Proof. - destruct UNTAUS as [Huntaus Hnotau]. - remember (observe t) as ot. revert s t Heqot EQV. - induction Huntaus; intros; punfold EQV; unfold_eq_itree. - - eexists (observe s). split. - inv EQV; simpobs; eauto. - subst; eauto. - eapply eq_itreeF_mono; eauto. - intros ? ? [| []]; eauto. - - inv EQV; simpobs; inversion Heqot; subst. - destruct REL as [| []]. - edestruct IHHuntaus as [? [[]]]; eauto 10. -Qed. - -Lemma eq_unalltaus_eq (t : itree E R1) (s : itree E R2) t' - (UNTAUS : unalltausF (observe t) (observe t')) - (EQV: eq_itree RR t s) : - exists s', unalltausF (observe s) (observe s') /\ eq_itree RR t' s'. -Proof. - eapply eq_unalltaus_eqF in UNTAUS; try eassumption. - destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. - pfold. eapply eq_itreeF_mono; eauto. -Qed. - -Lemma eutt_Ret x y : - RR x y -> eutt (Ret x) (Ret y). -Proof. - intros; pfold. - constructor. - split; intros; eapply finite_taus_ret; reflexivity. - intros. - apply unalltausF_ret in UNTAUS1. - apply unalltausF_ret in UNTAUS2. - subst; constructor; assumption. -Qed. - -Lemma eutt_Vis {U} (e: E U) k k' : - (forall x, eutt (k x) (k' x)) -> - eutt (Vis e k) (Vis e k'). -Proof. - intros. - pfold; constructor. - split; intros; eapply finite_taus_vis; reflexivity. - intros. - cbn in *. - apply unalltausF_vis in UNTAUS1. - apply unalltausF_vis in UNTAUS2. - subst; constructor. - intros x; specialize (H x). - punfold H. -Qed. - End EUTT. -Hint Resolve monotone_eq_notauF. -Hint Constructors eq_notauF. Hint Constructors euttF. +Hint Unfold eutt_. +Hint Resolve monotone_euttF : paco. Hint Resolve monotone_eutt_ : paco. +Hint Unfold eutt. + +Infix "≈" := (eutt eq) (at level 70) : itree_scope. -(** *** [eq_notauF] lemmas *) +Section EUTT_homo. -Lemma eq_notauF_and {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} - (eutt1 eutt2 eutt : I -> J -> Prop) : - (forall t1 t2, eutt1 t1 t2 -> eutt2 t1 t2 -> eutt t1 t2) -> - forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), - eq_notauF RR eutt1 ot1 ot2 -> eq_notauF RR eutt2 ot1 ot2 -> - eq_notauF RR eutt ot1 ot2. -Proof. - intros ? ? ? [] Hen2; inversion Hen2; auto. - auto_inj_pair2; subst; auto. -Qed. +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). -Lemma eq_notauF_flip {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} - (eutt : I -> J -> Prop) : - forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), - eq_notauF (flip RR) (flip eutt) ot2 ot1 -> - eq_notauF RR eutt ot1 ot2. +Global Instance subrelation_eq_eutt : + @subrelation (itree E R) (eq_itree RR) (eutt RR). Proof. - intros ? ? []; auto. + pcofix CIH. intros. pfold. revert_until CIH. pcofix CIH'. intros. + punfold H0. pfold. inv H0; pclearbot; eauto 7. Qed. -Delimit Scope eutt_scope with eutt. - -(** ** Generalized symmetry and transitivity *) - -Lemma Symmetric_eq_notauF_ {E R1 R2} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) - {I J} (r1 : I -> J -> Prop) (r2 : J -> I -> Prop) - (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) - (SYM_r : forall i j, r1 i j -> r2 j i) - (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J) : - eq_notauF RR1 r1 ot1 ot2 -> - eq_notauF RR2 r2 ot2 ot1. -Proof. intros []; auto. Qed. - -Lemma Transitive_eq_notauF_ {E R1 R2 R3} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) - (RR3 : R1 -> R3 -> Prop) - {I J K} (r1 : I -> J -> Prop) (r2 : J -> K -> Prop) - (r3 : I -> K -> Prop) - (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) - (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) - (ot1 : itreeF E R1 I) ot2 ot3 : - eq_notauF RR1 r1 ot1 ot2 -> - eq_notauF RR2 r2 ot2 ot3 -> - eq_notauF RR3 r3 ot1 ot3. +Global Instance Reflexive_eutt_gen `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive (paco2 (eutt_ RR) r). Proof. - intros [] I2; inversion I2; eauto. - auto_inj_pair2; subst; eauto. + pcofix CIH. intros. pfold. revert x. pcofix CIH'. intros. + genobs x ox. destruct ox; eauto. Qed. -Lemma Symmetric_euttF_ {E R1 R2} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) - (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) - (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) - (SYM_r : forall i j, r1 i j -> r2 j i) - (ot1 : itree' E R1) (ot2 : itree' E R2) : - euttF RR1 r1 ot1 ot2 -> - euttF RR2 r2 ot2 ot1. +Global Instance Reflexive_euttF_gen `{Reflexive _ RR} + (r : relation (itree E R)) (r' : relation (itree' E R)) : + Reflexive (euttF RR (upaco2 (eutt_ RR) r) (upaco2 (euttF RR (upaco2 (eutt_ RR) r)) r')). Proof. - intros []; split. - - split; apply FIN. - - intros. specialize (EQV _ _ UNTAUS2 UNTAUS1). - eapply Symmetric_eq_notauF_; eauto. + repeat intro. assert (X := Reflexive_eutt_gen r (go x)). do 2 punfold X. + eauto using euttF_mon, upaco2_mon_bot. Qed. -Lemma Transitive_euttF_ {E R1 R2 R3} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) - (RR3 : R1 -> R3 -> Prop) - (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) - (r3 : _ -> _ -> Prop) - (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) - (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) - (ot1 : itree' E R1) ot2 ot3 : - euttF RR1 r1 ot1 ot2 -> - euttF RR2 r2 ot2 ot3 -> - euttF RR3 r3 ot1 ot3. +Global Instance Symmetric_eutt_gen `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) + (Sr : Symmetric r) : + Symmetric (paco2 (eutt_ RR) r). Proof. - intros [] []. - constructor. - - etransitivity; eauto. - - intros t1' t3' H1 H3. - assert (FIN2 : finite_tausF ot2). - { apply FIN; eauto. } - destruct FIN2 as [t2' []]. - eapply Transitive_eq_notauF_; eauto. + pcofix CIH. intros. pfold. revert_until CIH. pcofix CIH'. intros. + punfold H1. punfold H1. pfold. + genobs_clear x ox. genobs_clear y oy. + induction H1; pclearbot; eauto. + - econstructor. intros. destruct (EUTTK x); eauto. + - punfold EQTAUS. eauto 8. Qed. +End EUTT_homo. + Lemma Symmetric_eutt_ {E R1 R2} (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) @@ -646,105 +152,226 @@ Lemma Symmetric_eutt_ {E R1 R2} forall (t1 : itree E R1) (t2 : itree E R2), paco2 (eutt_ RR1) r1 t1 t2 -> paco2 (eutt_ RR2) r2 t2 t1. Proof. - pcofix self. - intros t1 t2 H12. - punfold H12. - pfold. - eapply Symmetric_euttF_; try eassumption. - intros ? ? []; auto. + pcofix CIH. intros. + pfold. revert_until CIH. pcofix CIH'. intros. + pfold. do 2 punfold H0. + genobs_clear t1 ot1. genobs_clear t2 ot2. + induction H0; pclearbot; eauto 7. + econstructor; intros. edestruct EUTTK; eauto. Qed. -Lemma Transitive_eutt_ {E R1 R2 R3} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) - (RR3 : R1 -> R3 -> Prop) - (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) : - forall (t1 : itree E R1) t2 t3, - eutt RR1 t1 t2 -> eutt RR2 t2 t3 -> eutt RR3 t1 t3. -Proof. - pcofix self. - intros t1 t2 t3 H12 H23. - punfold H12; punfold H23; pfold. - eapply Transitive_euttF_; try eassumption. - intros; pclearbot; eauto. -Qed. +Section EUTT_eq_EUTTE. -Section EUTT_rel. +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). +Lemma euttE__impl_eutt_ r t1 t2 : + @euttE_ E R1 R2 RR r t1 t2 -> eutt_ RR r t1 t2. +Proof. + revert t1 t2. pcofix CIH'. intros. destruct H0. + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) + by (destruct ot1, ot2; simpl; tauto). + destruct EM as [EM|[EM|EM]]. + - destruct FIN as [FIN _]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS1. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct FIN as [_ FIN]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS2. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct ot1, ot2; simpl in *; try tauto. + pfold. econstructor. right. apply CIH'. + econstructor. + + rewrite !finite_taus_tau in FIN. eauto. + + eauto using unalltaus_tau'. +Qed. + +Lemma eutt__impl_euttE_ r t1 t2 : + @eutt_ E R1 R2 RR r t1 t2 -> euttE_ RR r t1 t2. +Proof. + intros. punfold H. econstructor; intros. + - split; intros. + + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. + move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. + induction UNTAUS1. + + induction 1; intros. + * inv H; try contradiction; eauto. + * subst. inv H; try contradiction. eauto. + + induction 1; intros; subst. + * inv H; try contradiction; eauto. + * inv H; try contradiction; eauto. + pclearbot. eapply IHUNTAUS1; eauto. + punfold EQTAUS. +Qed. + +Lemma eutt__is_euttE_ r t1 t2 : + @eutt_ E R1 R2 RR r t1 t2 <-> euttE_ RR r t1 t2. +Proof. split; eauto using euttE__impl_eutt_, eutt__impl_euttE_. Qed. + +Lemma euttE_impl_eutt r t1 t2 : + paco2 (@euttE_ E R1 R2 RR) r t1 t2 -> paco2 (eutt_ RR) r t1 t2. +Proof. + split; intros; eapply paco2_mon_gen; eauto; intros; apply euttE__impl_eutt_; eauto. +Qed. + +Lemma eutt_impl_euttE r t1 t2 : + paco2 (@eutt_ E R1 R2 RR) r t1 t2 -> paco2 (euttE_ RR) r t1 t2. +Proof. + split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__impl_euttE_; eauto. +Qed. + +Lemma eutt_is_euttE r t1 t2 : + paco2 (@eutt_ E R1 R2 RR) r t1 t2 <-> paco2 (euttE_ RR) r t1 t2. +Proof. split; eauto using euttE_impl_eutt, eutt_impl_euttE. Qed. + +End EUTT_eq_EUTTE. + +Section EUTT_trans. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Ltac convert_eutt_to_euttE := + try (apply euttE__impl_eutt_ || apply euttE_impl_eutt); + repeat match goal with [H: eutt_ _ _ _ _ |- _] => apply eutt__impl_euttE_ in H end; + repeat match goal with [H: eutt _ _ _ |- _] => apply eutt_impl_euttE in H end. -(* Reflexivity of [eq_notauF], modulo a few assumptions. *) -Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) : - Reflexive eq_ -> - forall (ot : itreeF E R I), notauF ot -> eq_notauF RR eq_ ot ot. +Inductive eutt_trans_clo (r: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| eutt_pre_clo_intro t1 t2 t3 t4 + (EQVl: t1 ≈ t2) + (EQVr: t4 ≈ t3) + (REL: r t2 t3) + : eutt_trans_clo r t1 t4 +. +Hint Constructors eutt_trans_clo. + +Lemma eutt_clo_trans : + weak_respectful2 (@eutt_ E R1 R2 RR) eutt_trans_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. + convert_eutt_to_euttE. + destruct (euttE_clo_trans E _ _ RR). clear WEAK_MON. + hexploit WEAK_RESPECTFUL. + { apply LE. } + { intros. apply GF in PR. convert_eutt_to_euttE. auto. } + { econstructor; [apply EQVl|apply EQVr|apply REL]. } + intros EUTT. + eapply monotone_euttE_; eauto; intros. + eapply rclo2_mon_gen; eauto; intros. + - convert_eutt_to_euttE. auto. + - destruct PR0. econstructor; convert_eutt_to_euttE; eauto. +Qed. + +Global Instance eutt_cong_eutt r : + Proper (eutt eq ==> eutt eq ==> flip impl) + (paco2 (@eutt_ E R1 R2 RR ∘ gres2 (eutt_ RR)) r). Proof. - intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. + repeat intro. pupto2 eutt_clo_trans. eauto. Qed. -Global Instance Symmetric_eq_notauF `{Symmetric _ RR} I (eq_ : I -> I -> Prop) : - Symmetric eq_ -> Symmetric (@eq_notauF E _ _ RR _ _ eq_). +Global Instance eutt_cong_gres_eutt_ r : + Proper (eutt eq ==> eutt eq ==> flip impl) + (gres2 (@eutt_ E R1 R2 RR) r). Proof. - repeat intro. eapply Symmetric_eq_notauF_; eauto. + repeat intro. pupto2 eutt_clo_trans. eauto. Qed. -Global Instance Transitive_eq_notauF `{Transitive _ RR} I (eq_ : I -> I -> Prop) : - Transitive eq_ -> Transitive (@eq_notauF E _ _ RR _ _ eq_). +Global Instance eutt_eq_under_rr_impl : + Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> flip impl) (eutt RR). Proof. - repeat intro. eapply Transitive_eq_notauF_; eauto. + repeat red. intros. pupto2_init. rewrite H, H0. pupto2_final. eauto. Qed. -Global Instance subrelation_eq_eutt : - @subrelation (itree E R) (eq_itree RR) (eutt RR). -Proof. - pcofix CIH. intros. - pfold. econstructor. - { split; [|apply flip_eq_itree in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } +End EUTT_trans. - intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. - hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. - inv EQV'; simpobs; eauto. - eapply unalltaus_notau in UNTAUS1. contradiction. -Qed. +Arguments eutt_clo_trans : clear implicits. +Hint Constructors eutt_trans_clo. -Global Instance Reflexive_euttF `{Reflexive _ RR} - (r : itree E R -> itree E R -> Prop) : - Reflexive r -> Reflexive (euttF RR r). -Proof. - split. - - reflexivity. - - intros. - erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply Reflexive_eq_notauF; eauto. -Qed. +Section EUTT_nested_trans. -Global Instance Symmetric_euttF `{Symmetric _ RR} - (r : itree E R -> itree E R -> Prop) : - Symmetric r -> Symmetric (euttF RR r). -Proof. - intros SYM x y. apply Symmetric_euttF_; auto. -Qed. +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -Global Instance Transitive_euttF `{Transitive _ RR} - (r : itree E R -> itree E R -> Prop) : - Transitive r -> Transitive (euttF RR r). +Inductive eutt_nested_trans_clo (r: itree' E R1 -> itree' E R2 -> Prop) : + itree' E R1 -> itree' E R2 -> Prop := +| eutt_nested_pre_clo_intro ot1 ot2 ot3 ot4 + (EQVl: go ot1 ≅ go ot2) + (EQVr: go ot4 ≅ go ot3) + (REL: r ot2 ot3) + : eutt_nested_trans_clo r ot1 ot4 +. +Hint Constructors eutt_nested_trans_clo. + +Lemma eutt_nested_clo_trans r : + weak_respectful2 (euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r))) + eutt_nested_trans_clo. Proof. - intros TRANS x y z. apply Transitive_euttF_; auto. + econstructor; [pmonauto|]. + intros. destruct PR. + apply GF in REL. clear l LE GF. + punfold EQVl; red in EQVl. punfold EQVr; red in EQVr. simpl in *. + move REL before r0. revert_until REL. + induction REL; intros; subst; + try (dependent destruction EQVl; dependent destruction EQVr; [ idtac ]; pclearbot). + - eauto. + - econstructor. intros. rewrite REL, REL0. eauto. + - econstructor. eapply rclo2_step. econstructor. + + rewrite REL. reflexivity. + + rewrite REL0. reflexivity. + + eauto using rclo2. + - dependent destruction EQVl; pclearbot. punfold REL0. + - dependent destruction EQVr; pclearbot. punfold REL0. Qed. -Global Instance Symmetric_eutt `{Symmetric _ RR} - (r : itree E R -> itree E R -> Prop) - (Sr : Symmetric r) : - Symmetric (paco2 (eutt_ RR) r). -Proof. red; eapply Symmetric_eutt_; eauto. Qed. - -Global Instance Reflexive_eutt `{Reflexive _ RR} - (r : itree E R -> itree E R -> Prop) : - Reflexive (paco2 (eutt_ RR) r). +Global Instance eq_cong_nested_euttF r r0 : + Proper (going (eq_itree eq) ==> going (eq_itree eq) ==> flip impl) + (paco2 (@euttF E R1 R2 RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r)) + ∘ gres2 (euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r)))) r0). Proof. - pcofix CIH. - intros. pfold. red. apply Reflexive_euttF; eauto. + repeat intro. destruct H, H0. + pupto2 eutt_nested_clo_trans. econstructor; eauto. Qed. -End EUTT_rel. +End EUTT_nested_trans. + +Arguments eutt_nested_clo_trans : clear implicits. +Hint Constructors eutt_nested_trans_clo. Section EUTT_eq. @@ -752,310 +379,124 @@ Context {E : Type -> Type} {R : Type}. Let eutt : itree E R -> itree E R -> Prop := eutt eq. -Infix "≈" := eutt (at level 70) : itree_scope. - -Global Instance Transitive_eutt : Transitive eutt. +Global Instance subrelation_observing_eutt: + @subrelation (itree E R) (observing eq) eutt. Proof. - red; eapply Transitive_eutt_; eauto. - intros; subst; eauto. + repeat intro. eapply subrelation_eq_eutt, observing_eq_itree_eq. eauto. Qed. -(**) - -(* [eutt] is preserved by removing one [Tau]. *) -Lemma tauF_eutt (t t': itree E R) (OBS: TauF t' = observe t): t ≈ t'. -Proof. - pfold. split. - - simpobs. rewrite finite_taus_tau. reflexivity. - - intros t1' t2' H1 H2. - eapply unalltaus_tau in H1; eauto. - pose proof (unalltaus_injective _ _ _ H1 H2). - subst; apply Reflexive_eq_notauF; eauto. - left. apply reflexivity. -Qed. +Global Instance Reflexive_eutt: Reflexive eutt. +Proof. apply Reflexive_eutt_gen; eauto. Qed. -Lemma tau_eutt (t: itree E R) : Tau t ≈ t. -Proof. - eapply tauF_eutt. eauto. -Qed. +Global Instance Symmetric_eutt: Symmetric eutt. +Proof. apply Symmetric_eutt_gen; eauto. Qed. -(* [eutt] is preserved by removing all [Tau]. *) -Lemma untaus_eutt (t t' : itree E R) : untausF (observe t) (observe t') -> t ≈ t'. +Global Instance Transitive_eutt : Transitive eutt. Proof. - intros H. - pfold. split. - - eapply untaus_finite_taus; eauto. - - induction H; intros. - + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). - apply Reflexive_eq_notauF; eauto. - left; apply reflexivity. - + eapply unalltaus_tau in UNTAUS1; eauto. + unfold eutt. repeat intro. pupto2_init. + rewrite H, H0. pupto2_final. apply Reflexive_eutt. Qed. (* We can now rewrite with [eutt] equalities. *) Global Instance Equivalence_eutt : @Equivalence (itree E R) eutt. Proof. constructor; typeclasses eauto. Qed. -(**) - -Global Instance eutt_go : Proper (going eutt ==> eutt) go. +Global Instance eutt_cong_go : Proper (going eutt ==> eutt) go. Proof. intros ? ? []; eauto. Qed. -Global Instance eutt_observe : Proper (eutt ==> going eutt) observe. +Global Instance eutt_cong_observe : Proper (eutt ==> going eutt) observe. Proof. constructor. punfold H. pfold. destruct H. econstructor; eauto. Qed. -Global Instance eutt_tauF : Proper (eutt ==> going eutt) (fun t => TauF t). +Global Instance eutt_cong_tauF : Proper (eutt ==> going eutt) (@TauF _ _ _). Proof. - constructor; pfold. punfold H. - destruct H. econstructor. - - split; intros; simpl. - + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. - + rewrite finite_taus_tau, FIN, <-finite_taus_tau; eauto. - - intros. eapply EQV; eapply unalltaus_tau; eauto. + constructor. pfold. pfold. econstructor. punfold H. Qed. -Global Instance eutt_VisF {u} (e: E u) : +Global Instance eutt_cong_VisF {u} (e: E u) : Proper (pointwise_relation _ eutt ==> going eutt) (VisF e). -Proof. - constructor; pfold. red in H. econstructor. - - repeat econstructor. - - intros. - destruct UNTAUS1 as [UNTAUS1 Hnotau1]. - destruct UNTAUS2 as [UNTAUS2 Hnotau2]. - dependent destruction UNTAUS1. - dependent destruction UNTAUS2. simpobs. - econstructor; intros; left; apply H. -Qed. - -Global Instance eq_itree_notauF : - Proper (going (@eq_itree E R _ eq) ==> flip impl) notauF. -Proof. - intros ? ? [] ?; punfold H. inv H; simpl in *; subst; eauto. -Qed. - -(* If [t1] and [t2] are equivalent, then either both start with - finitely many taus, or both [spin]. *) -Global Instance eutt_finite_taus : - Proper (going eutt ==> flip impl) finite_tausF. -Proof. - intros ? ? [] ?; punfold H. eapply H. eauto. -Qed. - -Inductive eutt_trans_clo (r: itree E R -> itree E R -> Prop) : - itree E R -> itree E R -> Prop := -| eutt_pre_clo_intro (t1 t2 t3 t4: itree E R) - (EQVl: t1 ≈ t2) - (EQVr: t4 ≈ t3) - (REL: r t2 t3) - : eutt_trans_clo r t1 t4 -. -Hint Constructors eutt_trans_clo. - -Lemma eutt_clo_trans : weak_respectful2 (eutt_ eq) eutt_trans_clo. -Proof. - econstructor; [pmonauto|]. - intros. inv PR. - punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. - { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } - - intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. - hexploit EQV; eauto. intros EUTT1. - apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. - hexploit EQV0; eauto. intros EUTT2. - apply GF in REL. destruct REL. - hexploit EQV1; eauto. intros EUTT3. - destruct EUTT1; destruct EUTT2; - try (solve [subst; inversion EUTT3; auto]). - remember (VisF _ _) as o2 in EUTT3. - remember (VisF _ _) as o3 in EUTT3. - inversion EUTT3; subst; try discriminate. - inversion H2; clear H2; inversion H3; clear H3. - subst; auto_inj_pair2; subst. - econstructor. intros. - specialize (H x); specialize (H0 x); specialize (H1 x). - pclearbot. eauto using rclo2. +Proof. + constructor. pfold. pfold. econstructor. + intros. specialize (H x0). punfold H. Qed. End EUTT_eq. -Arguments eutt_clo_trans : clear implicits. - -Hint Constructors eutt_trans_clo. - -Infix "≈" := (eutt eq) (at level 70) : itree_scope. - (**) Lemma eutt_tau {E R1 R2} (RR : R1 -> R2 -> Prop) (t1 : itree E R1) (t2 : itree E R2) : eutt RR t1 t2 -> eutt RR (Tau t1) (Tau t2). Proof. - intros H. - pfold. eapply euttF_tau. reflexivity. reflexivity. punfold H. + intros. pfold. pfold. econstructor. punfold H. Qed. -Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) +Lemma eutt_vis {E R1 R2} (RR : R1 -> R2 -> Prop) {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : - (forall u, eq_itree RR (k1 u) (k2 u)) -> - eq_itree RR (Vis e k1) (Vis e k2). -Proof. - intros; pfold; constructor; left. apply H. -Qed. - -Lemma eq_itree_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : - RR r1 r2 -> @eq_itree E _ _ RR (Ret r1) (Ret r2). -Proof. - intros; pfold; eauto; constructor; auto. -Qed. - -(* Lemmas about [bind]. *) - -Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) (observe t')), - untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). -Proof. - intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. - induction UNTAUS; intros; subst. - - rewrite !unfold_bind; simpobs; eauto. - - rewrite unfold_bind. simpobs. cbn. eauto. -Qed. - -Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) t'), - untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). -Proof. - intros; eapply untaus_bind; eauto. -Qed. - -Lemma finite_taus_bind_fst {E R S} - (t : itree E R) (f : R -> itree E S) : - finite_taus (ITree.bind t f) -> finite_taus t. + (forall u, eutt RR (k1 u) (k2 u)) -> + eutt RR (Vis e k1) (Vis e k2). Proof. - intros [tf' [TAUS PROP]]. - genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. - induction TAUS; intros; subst. - - rewrite unfold_bind in PROP. - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - rewrite unfold_bind in Heqobtf. simpobs. inv Heqobtf. unfold_bind. - eapply finite_taus_tau; eauto. + intros. pfold. pfold. econstructor. intros. specialize (H x). punfold H. Qed. -Lemma finite_taus_bind {E R S} - (t : itree E R) (f : R -> itree E S) - (FINt: finite_tausF (observe t)) - (FINk: forall v, finite_tausF (observe (f v))): - finite_tausF (observe (ITree.bind t f)). +Lemma eutt_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + RR r1 r2 -> @eutt E R1 R2 RR (Ret r1) (Ret r2). Proof. - rewrite unfold_bind. - genobs t ot. clear Heqot t. - destruct FINt as [ot' [UNT NOTAU]]. - induction UNT; subst. - - destruct ot0; inv NOTAU; simpl; eauto 7. - - apply finite_taus_tau. eauto. + intros. pfold. pfold. econstructor. eauto. Qed. -Inductive eutt_bind_clo {E R} (r: relation (itree E R)) : relation (itree E R) := -| eutt_bind_clo_intro U (t1 t2: itree E U) k1 k2 - (EQV: t1 ≈ t2) - (REL: forall v, r (k1 v) (k2 v)) - : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) -. -Hint Constructors eutt_bind_clo. - -Lemma bind_clo_finite_taus E U R (t1 t2: itree E U) (k1 k2: U -> itree E R) - (FT: finite_taus (ITree.bind t1 k1)) - (FTk: forall v, finite_taus (k1 v) -> finite_taus (k2 v)) - (EQV: t1 ≈ t2): - finite_taus (ITree.bind t2 k2). -Proof. - punfold EQV. destruct EQV as [[FTt _] EQV]. - assert (FT1 := FT). apply finite_taus_bind_fst in FT1. - assert (FT2 := FT1). apply FTt in FT2. - destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. - rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. - rewrite unfold_bind. genobs t2 ot2. clear Heqot2 t2. - induction FT2. - - destruct ot0; inv NT2; simpl; eauto 7. - hexploit EQV; eauto. intros EQV'. inv EQV'. - rewrite unfold_bind in FT. eauto. - - subst. eapply finite_taus_tau; eauto. - eapply IHFT2; eauto using unalltaus_tau'. -Qed. - -Lemma eutt_clo_bind E R: weak_respectful2 (@eutt_ E R _ eq) eutt_bind_clo. -Proof. - econstructor; [pmonauto|]. - intros. destruct PR. split. - - assert (EQV':=EQV). symmetry in EQV'. - split; intros; eapply bind_clo_finite_taus; eauto; intros. - + edestruct GF; eauto. apply FIN. eauto. - + edestruct GF; eauto. apply FIN. eauto. - - punfold EQV. destruct EQV. - intros. - hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS1|]. intros [a FT1]. - hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS2|]. intros [b FT2]. - specialize (EQV _ _ FT1 FT2). - destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. - hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. - hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. - hexploit @untaus_unalltaus_rev; [apply UT1| |]. eauto. intros UAT1. - hexploit @untaus_unalltaus_rev; [apply UT2| |]; eauto. intros UAT2. - inv EQV. - + rewrite unfold_bind in UAT1, UAT2. simpobs. cbn in *. - eapply GF in REL. destruct REL. - eapply monotone_eq_notauF; eauto using rclo2. - + rewrite unfold_bind in UAT1, UAT2. simpobs. cbn in *. - destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. - dependent destruction UAT1. dependent destruction UAT2. simpobs. - econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. -Qed. - -(* [eutt] is a congruence wrt. [bind] *) - -Global Instance eutt_bind {E R S} : +Global Instance eutt_bind {E S R} : Proper (eutt eq ==> pointwise_relation _ (eutt eq) ==> eutt eq) (@ITree.bind E R S). Proof. - repeat intro. pupto2_init. - pupto2 eutt_clo_bind. econstructor; eauto. - intros. pupto2_final. apply H0. -Qed. - -Global Instance eutt_paco {E R} r: - Proper (eutt eq ==> eutt eq ==> flip impl) - (paco2 (@eutt_ E R _ eq ∘ gres2 (eutt_ eq)) r). -Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. -Qed. - -Global Instance eutt_gres {E R} r: - Proper (eutt eq ==> eutt eq ==> flip impl) - (gres2 (@eutt_ E R _ eq) r). -Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. + repeat intro. do 2 punfold H. + revert_until S. pcofix CIH. intros. + pfold. revert_until CIH. pcofix CIH'. intros. pfold. + rewrite !unfold_bind. genobs_clear x ox. genobs_clear y oy. + move H0 before CIH'. revert_until H0. + induction H0; intros; subst; pclearbot. + - simpl. specialize (H1 r2). do 2 punfold H1. + eauto 7 using euttF_mon, upaco2_mon_bot. + - econstructor. intros. + specialize (EUTTK x). do 2 punfold EUTTK. + - econstructor. intros. punfold EQTAUS. + - econstructor. rewrite unfold_bind. eauto. + - econstructor. rewrite unfold_bind. eauto. Qed. Global Instance eutt_map {E R S} : Proper (pointwise_relation _ eq ==> eutt eq ==> eutt eq) (@ITree.map E R S). Proof. - unfold ITree.map. repeat red. - intros; eapply eutt_bind; eauto. - intro. rewrite H. reflexivity. + unfold ITree.map. do 3 red. intros. + rewrite H0. setoid_rewrite H. reflexivity. Qed. Global Instance eutt_forever {E R S} : Proper (eutt eq ==> eutt eq) (@ITree.forever E R S). Proof. -Admitted. + cut (forall X (t1 t2: itree E X) (x y: itree E R), t1 ≈ t2 -> x ≈ y -> (t1 ;; @ITree.forever E R S x) ≈ (t2 ;; ITree.forever y)). + { repeat intro. + rewrite <-(ret_bind tt (fun _ => ITree.forever x)). + rewrite <-(ret_bind tt (fun _ => ITree.forever y)). + eapply H; eauto; reflexivity. + } + + pcofix CIH. intros. + pfold. revert_until CIH. pcofix CIH'. intros. + do 2 punfold H0. pfold. + rewrite !unfold_bind. genobs_clear t1 ot1. genobs_clear t2 ot2. + induction H0; intros; subst; pclearbot; try (econstructor; eauto 7; fail). + simpl. rewrite (unfold_forever x), (unfold_forever y). + econstructor. eauto 7. +Qed. Global Instance eutt_when {E} (b : bool) : Proper (eutt eq ==> eutt eq) (@ITree.when E b). Proof. -Admitted. + repeat intro. destruct b; simpl; eauto. reflexivity. +Qed. Lemma eutt_map_map {E R S T} (f : R -> S) (g : S -> T) (t : itree E R) : @@ -1065,207 +506,7 @@ Proof. apply subrelation_eq_eutt, map_map. Qed. -Lemma eutt_eq_under_rr_impl {E : Type -> Type} - {R1 R2 : Type} (RR: R1 -> R2 -> Prop): - Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> impl) (eutt RR). -Proof. - repeat intro. - symmetry in H. - eapply Transitive_eutt_; try eassumption. - 2: eapply Transitive_eutt_; try eassumption. - all: intros; subst; eauto. -Qed. - -Global Instance eutt_eq_under_rr {E : Type -> Type} - {R1 R2 : Type} (RR: R1 -> R2 -> Prop): - Proper (@eutt E _ _ eq ==> @eutt _ _ _ eq ==> iff) (eutt RR). -Proof. - repeat intro. - split; eapply eutt_eq_under_rr_impl; auto. - all: symmetry; auto. -Qed. - -Inductive euttF1' {E R} (r : itree E R -> itree E R -> Prop) : - itree' E R -> itree' E R -> Prop := -| euttF1_Tau_L : forall t1 t2, - euttF1' r t1.(observe) t2 -> - euttF1' r (TauF t1) t2 -| euttF1_Tau_R : forall t1 t2, - euttF1' r t1 t2.(observe) -> - euttF1' r t1 (TauF t2) -| euttF1_euttF0 : forall t1 t2, - eq_notauF eq r t1 t2 -> - euttF1' r t1 t2 -. - -Definition euttF1 {E R} (r : relation (itree E R)) : - relation (itree E R) := observing (euttF1' r). - -Lemma euttF1_euttF {E R} (r : relation (itree E R)) : - forall t1 t2, - euttF1 r t1 t2 -> eutt_ eq r t1 t2. -Proof. -Admitted. - -Inductive euttF' {E R} (eutt: relation (itree E R)) (eqtaus: relation (itreeF E R _)) - : relation (itreeF E R _) := -| euttF'_ret r : euttF' eutt eqtaus (RetF r) (RetF r) -| euttF'_vis u (e : E u) k1 k2 - (EUTTK: forall x, eutt (k1 x) (k2 x)): - euttF' eutt eqtaus (VisF e k1) (VisF e k2) -| euttF'_tau_tau t1 t2 - (EQTAUS: eqtaus (observe t1) (observe t2)): - euttF' eutt eqtaus (TauF t1) (TauF t2) -| euttF'_tau_left t1 ot2 - (EQTAUS: euttF' eutt eqtaus (observe t1) ot2): - euttF' eutt eqtaus (TauF t1) ot2 -| euttF'_right ot1 t2 - (EQTAUS: euttF' eutt eqtaus ot1 (observe t2)): - euttF' eutt eqtaus ot1 (TauF t2) -. -Hint Constructors euttF'. - -Definition eutt'_ {E R} eutt t1 t2 := paco2 (@euttF' E R eutt) bot2 (* (fun x y => eutt (go x) (go y)) *) (observe t1) (observe t2). -Hint Unfold eutt'_. - -Definition eutt' {E R} := paco2 (@eutt'_ E R) bot2. -Hint Unfold eutt'. - -Lemma euttF'_mon {E R} r r' s s' x y - (EUTT: @euttF' E R r s x y) - (LEr: r <2= r') - (LEs: s <2= s'): - euttF' r' s' x y. -Proof. - induction EUTT; eauto. -Qed. - -Lemma reflexive_euttF' {E R} eutt eqtaus (r1:Reflexive eutt) (r:Reflexive eqtaus) : Reflexive (@euttF' E R eutt eqtaus). -Proof. - unfold Reflexive. intros x. - destruct x; eauto. -Qed. - -Lemma monotone_euttF' {E R} eutt : monotone2 (@euttF' E R eutt). -Proof. repeat intro. eauto using euttF'_mon. Qed. -Hint Resolve monotone_euttF' : paco. - -Lemma monotone_eutt'_ {E R} : monotone2 (@eutt'_ E R). -Proof. red. eauto using euttF'_mon, paco2_mon_gen. Qed. -Hint Resolve monotone_eutt'_ : paco. - -Lemma eutt__is_eutt'_ {E R} r (t1 t2: itree E R) : - eutt_ eq r t1 t2 <-> eutt'_ r t1 t2. -Proof. - split; intros. - { revert t1 t2 H. pcofix CIH'. intros. destruct H0. - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) - by (destruct ot1, ot2; simpl; tauto). - destruct EM as [EM|[EM|EM]]. - - destruct FIN as [FIN _]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS1. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct FIN as [_ FIN]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS2. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct ot1, ot2; simpl in *; try tauto. - pfold. econstructor. right. apply CIH'. - econstructor. - + rewrite !finite_taus_tau in FIN. eauto. - + eauto using unalltaus_tau'. - } - { punfold H. econstructor; intros. - - split; intros. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. - move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. - induction UNTAUS1. - + induction 1; intros. - * inv H; try contradiction; eauto. - * subst. inv H; try contradiction. eauto. - + induction 1; intros; subst. - * inv H; try contradiction; eauto. - * inv H; try contradiction; eauto. - pclearbot. eapply IHUNTAUS1; eauto. - punfold EQTAUS. - } -Qed. - -Lemma eutt_is_eutt' {E R} r (t1 t2: itree E R) : - paco2 (eutt_ eq) r t1 t2 <-> paco2 eutt'_ r t1 t2. -Proof. - split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__is_eutt'_; eauto. -Qed. - -Lemma eutt_is_eutt'_gres {E R} r (t1 t2: itree E R) : - paco2 (eutt_ eq ∘ gres2 (eutt_ eq)) r t1 t2 <-> paco2 (eutt'_ ∘ gres2 eutt'_) r t1 t2. -Proof. - split; intros. - - eapply paco2_mon_gen; eauto. intros. - red in PR|-*. rewrite <-eutt__is_eutt'_. - eapply monotone_eutt_; eauto. intros. - eapply grespectful2_impl; eauto. intros. - rewrite eutt__is_eutt'_. reflexivity. - - eapply paco2_mon_gen; eauto. intros. - red in PR|-*. rewrite eutt__is_eutt'_. - eapply monotone_eutt'_; eauto. intros. - eapply grespectful2_impl; eauto. intros. - rewrite eutt__is_eutt'_. reflexivity. -Qed. - -Global Instance eutt'_paco {E R} r: - Proper (eutt eq ==> eutt eq ==> flip impl) - (paco2 (@eutt'_ E R ∘ gres2 eutt'_) r). -Proof. - repeat intro. - rewrite <-eutt_is_eutt'_gres. - rewrite <-eutt_is_eutt'_gres in H1. - rewrite H, H0. eauto. -Qed. - -Global Instance eutt'_gres {E R} r: - Proper (eutt eq ==> eutt eq ==> flip impl) - (gres2 (@eutt'_ E R) r). +Lemma tau_eutt {E R} (t: itree E R) : Tau t ≈ t. Proof. - repeat intro. - rewrite grespectful2_iff; [|intros; erewrite eutt__is_eutt'_; reflexivity]. - rewrite grespectful2_iff in H1; [|intros; erewrite eutt__is_eutt'_; reflexivity]. - rewrite H, H0. eauto. + pfold. pfold. econstructor. reflexivity. Qed. diff --git a/theories/Eq/UpToTausExplicit.v b/theories/Eq/UpToTausExplicit.v new file mode 100644 index 00000000..2c1ea19d --- /dev/null +++ b/theories/Eq/UpToTausExplicit.v @@ -0,0 +1,744 @@ +(* Equivalence up to taus *) +(* We consider tau as an "internal step", that should not be + visible to the outside world, so adding or removing [Tau] + constructors from an itree should produce an equivalent itree. + + We must be careful because there may be infinite sequences of + taus (i.e., [spin]). Here we shall only allow inserting finitely + many taus between any two visible steps ([Ret] or [Vis]), so that + [spin] is only related to itself. The main consequence of this + choice is that equivalence up to taus is an equivalence relation. + *) + +(* TODO: + - Generalize Reflexivity, Symmetry, Transitivity to heterogeneous + eutt. + - Make eutt a notation instead of a definition? + *) + +Require Import Paco.paco. + +From Coq Require Import + Program + Lia + Classes.RelationClasses + Classes.Morphisms + Setoids.Setoid + Relations.Relations. + +From ITree Require Import + Core. + +From ITree Require Export + Eq.Eq + Eq.Untaus. + +Local Open Scope itree. + +Section EUTT. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +(* Equivalence between visible steps of computation (i.e., [Vis] or + [Ret], parameterized by a relation [euttE] between continuations + in the [Vis] case. *) +Variant eq_notauF {I J} (euttE : I -> J -> Prop) +: itreeF E R1 I -> itreeF E R2 J -> Prop := +| Eutt_ret : forall r1 r2, + RR r1 r2 -> + eq_notauF euttE (RetF r1) (RetF r2) +| Eutt_vis : forall u (e : E u) k1 k2, + (forall x, euttE (k1 x) (k2 x)) -> + eq_notauF euttE (VisF e k1) (VisF e k2). +Hint Constructors eq_notauF. + +Lemma eq_notauF_vis_inv1 {I J} {euttE : I -> J -> Prop} {U} + ot (e : E U) k : + eq_notauF euttE ot (VisF e k) -> + exists k', + ot = VisF e k' /\ (forall x, euttE (k' x) (k x)). +Proof. + intros. remember (VisF e k) as t. + inversion H; subst; try discriminate. + inversion H2; subst; auto_inj_pair2; subst; eauto. +Qed. + +(* +Variant eq_notauF' {I} (euttE : relation I) +: relation (itreeF E R I) := +| Eutt_ret' : forall r, eq_notauF' euttE (RetF r) (RetF r) +| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, + eq_dep _ E _ e1 _ e2 -> + (forall x1 x2, JMeq x1 x2 -> euttE (k1 x1) (k2 x2)) -> + eq_notauF' euttE (VisF e1 k1) (VisF e2 k2). +Hint Constructors eq_notauF'. + +Lemma eq_notauF_eq_eq_notauF': forall I (euttE : relation I) t s, + eq_notauF euttE t s <-> eq_notauF' euttE t s. +Proof. + split; intros EUTT; destruct EUTT; eauto. + - econstructor; intros; subst; eauto. + - assert (u1 = u2) by (inv H; eauto). + subst. apply eq_dep_eq in H. subst. eauto. +Qed. +*) + +(* [euttE_ euttE t1 t2] means that, if [t1] or [t2] ever takes a + visible step ([Vis] or [Ret]), then the other takes the same + step, and the subsequent continuations (in the [Vis] case) are + related by [euttE]. In particular, [(t1 = spin)%eq_itree] if + and only if [(t2 = spin)%eq_itree]. Note also that in that + case, the parameter [euttE] is irrelevant. + + This is the relation we will take a fixpoint of. *) +Inductive euttEF (euttE : itree E R1 -> itree E R2 -> Prop) + (ot1 : itreeF E R1 (itree E R1)) + (ot2 : itreeF E R2 (itree E R2)) : Prop := +| euttEF_ (FIN: finite_tausF ot1 <-> finite_tausF ot2) + (EQV: forall ot1' ot2' + (UNTAUS1: unalltausF ot1 ot1') + (UNTAUS2: unalltausF ot2 ot2'), + eq_notauF euttE ot1' ot2') +. +Hint Constructors euttEF. + +Definition euttE_ (euttE : itree E R1 -> itree E R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : Prop := + euttEF euttE (observe t1) (observe t2). +Hint Unfold euttE_. + +(* Paco takes the greatest fixpoints of monotone relations. *) + +Lemma monotone_eq_notauF : forall I J (r r' : I -> J -> Prop) x1 x2 + (IN: eq_notauF r x1 x2) + (LE: r <2= r'), + eq_notauF r' x1 x2. +Proof. pmonauto. Qed. +Hint Resolve monotone_eq_notauF. + +(* [euttE_] is monotone. *) +Lemma monotone_euttE_ : monotone2 euttE_. +Proof. pmonauto. Qed. +Hint Resolve monotone_euttE_ : paco. + +(* We now take the greatest fixpoint of [euttE_]. *) + +(* Equivalence Up To Taus. + + [euttE t1 t2]: [t1] is equivalent to [t2] up to taus. *) +Definition euttE : itree E R1 -> itree E R2 -> Prop := paco2 euttE_ bot2. +Hint Unfold euttE. + +Global Arguments euttE t1%itree t2%itree. + +(* Lemmas about the auxiliary relations. *) + +(* Many have a name [X_Y] to represent an implication + [X _ -> Y _] (possibly with more arguments on either side). *) + +(**) + +Lemma euttEF_tau r t1 t2 t1' t2' + (OBS1: TauF t1' = observe t1) + (OBS2: TauF t2' = observe t2) + (REL: euttE_ r t1' t2'): + euttE_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - simpobs. rewrite !finite_taus_tau. eauto. + - intros. eapply EQV; eapply unalltaus_tau; eauto. +Qed. + +Lemma euttEF_tau_left r t1 t2 t1' + (OBS: TauF t1 = observe t1') + (REL: euttE_ r t1' t2): + euttE_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - rewrite <- FIN. symmetry. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS1. constructor; auto. + econstructor; eauto. +Qed. + +Lemma euttEF_tau_right r t1 t2 t2' + (OBS: TauF t2 = observe t2') + (REL: euttE_ r t1 t2'): + euttE_ r t1 t2. +Proof. + intros. destruct REL. econstructor. + - rewrite FIN. rewrite <- OBS. rewrite <- finite_taus_tau; eauto. reflexivity. + - intros. eapply EQV; eauto. rewrite <- OBS. inversion UNTAUS2. constructor; auto. + econstructor; eauto. +Qed. + +Lemma euttEF_vis {u} (r : _ -> _ -> Prop) t1 t2 (e : _ u) k1 k2 + (OBS1: VisF e k1 = observe t1) + (OBS2: VisF e k2 = observe t2) + (REL: forall x, r (k1 x) (k2 x)): + euttE_ r t1 t2. +Proof. + intros. econstructor. + - split; intros; eapply notau_finite_taus; eauto. + - intros. + apply unalltaus_notau_id in UNTAUS1; eauto. + apply unalltaus_notau_id in UNTAUS2; eauto. + simpobs. subst. eauto. +Qed. + +(**) + +Lemma euttE_strengthen : + forall r (t1 : itree E R1) (t2 : itree E R2) + (FIN: finite_taus t1 <-> finite_taus t2) + (EQV: forall t1' t2' + (UNT1: unalltaus t1 t1') + (UNT2: unalltaus t2 t2'), + paco2 (euttE_ ∘ gres2 euttE_) r t1' t2'), + paco2 (euttE_ ∘ gres2 euttE_) r t1 t2. +Proof. + intros. pfold. econstructor; eauto. + intros. + hexploit (EQV (go ot1') (go ot2')); eauto. + intros EQV'. punfold EQV'. destruct EQV'. + eapply EQV0; + repeat constructor; eauto. +Qed. + +(**) + +Lemma eq_unalltaus (t1 : itree E R1) (t2 : itree E R2) ot1' + (FT: unalltausF (observe t1) ot1') + (EQV: eq_itree RR t1 t2) : + exists ot2', unalltausF (observe t2) ot2'. +Proof. + genobs t1 ot1. revert t1 Heqot1 t2 EQV. + destruct FT as [Huntaus Hnotau]. + induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. + - eexists. constructor; eauto. inv EQV; simpl; eauto. + - inv EQV; simpobs; try inv Heqot1. + pclearbot. edestruct IHHuntaus as [? []]; eauto. +Qed. + +Lemma eq_unalltaus_eqF (t : itree E R1) (s : itree E R2) ot' + (UNTAUS : unalltausF (observe t) ot') + (EQV: eq_itree RR t s) : + exists os', unalltausF (observe s) os' /\ eq_itreeF RR (eq_itree RR) ot' os'. +Proof. + destruct UNTAUS as [Huntaus Hnotau]. + remember (observe t) as ot. revert s t Heqot EQV. + induction Huntaus; intros; punfold EQV; unfold_eq_itree. + - eexists (observe s). split. + inv EQV; simpobs; eauto. + subst; eauto. + eapply eq_itreeF_mono; eauto. + intros ? ? [| []]; eauto. + - inv EQV; simpobs; inversion Heqot; subst. + destruct REL as [| []]. + edestruct IHHuntaus as [? [[]]]; eauto 10. +Qed. + +Lemma eq_unalltaus_eq (t : itree E R1) (s : itree E R2) t' + (UNTAUS : unalltausF (observe t) (observe t')) + (EQV: eq_itree RR t s) : + exists s', unalltausF (observe s) (observe s') /\ eq_itree RR t' s'. +Proof. + eapply eq_unalltaus_eqF in UNTAUS; try eassumption. + destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. + pfold. eapply eq_itreeF_mono; eauto. +Qed. + +Lemma euttE_Ret x y : + RR x y -> euttE (Ret x) (Ret y). +Proof. + intros; pfold. + constructor. + split; intros; eapply finite_taus_ret; reflexivity. + intros. + apply unalltausF_ret in UNTAUS1. + apply unalltausF_ret in UNTAUS2. + subst; constructor; assumption. +Qed. + +Lemma euttE_Vis {U} (e: E U) k k' : + (forall x, euttE (k x) (k' x)) -> + euttE (Vis e k) (Vis e k'). +Proof. + intros. + pfold; constructor. + split; intros; eapply finite_taus_vis; reflexivity. + intros. + cbn in *. + apply unalltausF_vis in UNTAUS1. + apply unalltausF_vis in UNTAUS2. + subst; constructor. + intros x; specialize (H x). + punfold H. +Qed. + +End EUTT. + +Hint Unfold euttE_. +Hint Unfold euttE. +Hint Resolve monotone_eq_notauF. +Hint Constructors eq_notauF. +Hint Constructors euttEF. +Hint Resolve monotone_euttE_ : paco. + +(** *** [eq_notauF] lemmas *) + +Lemma eq_notauF_and {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (euttE1 euttE2 euttE : I -> J -> Prop) : + (forall t1 t2, euttE1 t1 t2 -> euttE2 t1 t2 -> euttE t1 t2) -> + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF RR euttE1 ot1 ot2 -> eq_notauF RR euttE2 ot1 ot2 -> + eq_notauF RR euttE ot1 ot2. +Proof. + intros ? ? ? [] Hen2; inversion Hen2; auto. + auto_inj_pair2; subst; auto. +Qed. + +Lemma eq_notauF_flip {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (euttE : I -> J -> Prop) : + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF (flip RR) (flip euttE) ot2 ot1 -> + eq_notauF RR euttE ot1 ot2. +Proof. + intros ? ? []; auto. +Qed. + +Delimit Scope euttE_scope with euttE. + +(** ** Generalized symmetry and transitivity *) + +Lemma Symmetric_eq_notauF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + {I J} (r1 : I -> J -> Prop) (r2 : J -> I -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J) : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot1. +Proof. intros []; auto. Qed. + +Lemma Transitive_eq_notauF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + {I J K} (r1 : I -> J -> Prop) (r2 : J -> K -> Prop) + (r3 : I -> K -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itreeF E R1 I) ot2 ot3 : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot3 -> + eq_notauF RR3 r3 ot1 ot3. +Proof. + intros [] I2; inversion I2; eauto. + auto_inj_pair2; subst; eauto. +Qed. + +Lemma Symmetric_euttEF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itree' E R1) (ot2 : itree' E R2) : + euttEF RR1 r1 ot1 ot2 -> + euttEF RR2 r2 ot2 ot1. +Proof. + intros []; split. + - split; apply FIN. + - intros. specialize (EQV _ _ UNTAUS2 UNTAUS1). + eapply Symmetric_eq_notauF_; eauto. +Qed. + +Lemma Transitive_euttEF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (r3 : _ -> _ -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itree' E R1) ot2 ot3 : + euttEF RR1 r1 ot1 ot2 -> + euttEF RR2 r2 ot2 ot3 -> + euttEF RR3 r3 ot1 ot3. +Proof. + intros [] []. + constructor. + - etransitivity; eauto. + - intros t1' t3' H1 H3. + assert (FIN2 : finite_tausF ot2). + { apply FIN; eauto. } + destruct FIN2 as [t2' []]. + eapply Transitive_eq_notauF_; eauto. +Qed. + +Lemma Symmetric_euttE_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) : + forall (t1 : itree E R1) (t2 : itree E R2), + paco2 (euttE_ RR1) r1 t1 t2 -> paco2 (euttE_ RR2) r2 t2 t1. +Proof. + pcofix self. + intros t1 t2 H12. + punfold H12. + pfold. + eapply Symmetric_euttEF_; try eassumption. + intros ? ? []; auto. +Qed. + +Lemma Transitive_euttE_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) : + forall (t1 : itree E R1) t2 t3, + euttE RR1 t1 t2 -> euttE RR2 t2 t3 -> euttE RR3 t1 t3. +Proof. + pcofix self. + intros t1 t2 t3 H12 H23. + punfold H12; punfold H23; pfold. + eapply Transitive_euttEF_; try eassumption. + intros; pclearbot; eauto. +Qed. + +Section EUTT_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + +(* Reflexivity of [eq_notauF], modulo a few assumptions. *) +Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) : + Reflexive eq_ -> + forall (ot : itreeF E R I), notauF ot -> eq_notauF RR eq_ ot ot. +Proof. + intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. +Qed. + +Global Instance Symmetric_eq_notauF `{Symmetric _ RR} I (eq_ : I -> I -> Prop) : + Symmetric eq_ -> Symmetric (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Symmetric_eq_notauF_; eauto. +Qed. + +Global Instance Transitive_eq_notauF `{Transitive _ RR} I (eq_ : I -> I -> Prop) : + Transitive eq_ -> Transitive (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Transitive_eq_notauF_; eauto. +Qed. + +Global Instance subrelation_eq_euttE : + @subrelation (itree E R) (eq_itree RR) (euttE RR). +Proof. + pcofix CIH. intros. + pfold. econstructor. + { split; [|apply flip_eq_itree in H0]; intros; destruct H as [n [? ?]]; eauto using eq_unalltaus. } + + intros. eapply eq_unalltaus_eqF in H0; eauto. destruct H0 as [s' [UNTAUS' EQV']]. + hexploit @unalltaus_injective; [apply UNTAUS' | apply UNTAUS2 | intro X]; subst. + inv EQV'; simpobs; eauto. + eapply unalltaus_notau in UNTAUS1. contradiction. +Qed. + +Global Instance Reflexive_euttEF `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive r -> Reflexive (euttEF RR r). +Proof. + split. + - reflexivity. + - intros. + erewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). + apply Reflexive_eq_notauF; eauto. +Qed. + +Global Instance Symmetric_euttEF `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) : + Symmetric r -> Symmetric (euttEF RR r). +Proof. + intros SYM x y. apply Symmetric_euttEF_; auto. +Qed. + +Global Instance Transitive_euttEF `{Transitive _ RR} + (r : itree E R -> itree E R -> Prop) : + Transitive r -> Transitive (euttEF RR r). +Proof. + intros TRANS x y z. apply Transitive_euttEF_; auto. +Qed. + +Global Instance Symmetric_euttE `{Symmetric _ RR} + (r : itree E R -> itree E R -> Prop) + (Sr : Symmetric r) : + Symmetric (paco2 (euttE_ RR) r). +Proof. red; eapply Symmetric_euttE_; eauto. Qed. + +Global Instance Reflexive_euttE `{Reflexive _ RR} + (r : itree E R -> itree E R -> Prop) : + Reflexive (paco2 (euttE_ RR) r). +Proof. + pcofix CIH. + intros. pfold. red. apply Reflexive_euttEF; eauto. +Qed. + +End EUTT_rel. + +Section EUTT_eq. + +Context {E : Type -> Type} {R : Type}. + +Let euttE : itree E R -> itree E R -> Prop := euttE eq. + +Global Instance Transitive_euttE : Transitive euttE. +Proof. + red; eapply Transitive_euttE_; eauto. + intros; subst; eauto. +Qed. + +(**) + +(* [euttE] is preserved by removing one [Tau]. *) +Lemma tauF_euttE (t t': itree E R) (OBS: TauF t' = observe t): euttE t t'. +Proof. + pfold. split. + - simpobs. rewrite finite_taus_tau. reflexivity. + - intros t1' t2' H1 H2. + eapply unalltaus_tau in H1; eauto. + pose proof (unalltaus_injective _ _ _ H1 H2). + subst; apply Reflexive_eq_notauF; eauto. + left. apply reflexivity. +Qed. + +Lemma tau_euttE (t: itree E R) : euttE (Tau t) t. +Proof. + eapply tauF_euttE. eauto. +Qed. + +(* [euttE] is preserved by removing all [Tau]. *) +Lemma untaus_euttE (t t' : itree E R) : untausF (observe t) (observe t') -> euttE t t'. +Proof. + intros H. + pfold. split. + - eapply untaus_finite_taus; eauto. + - induction H; intros. + + rewrite (unalltaus_injective _ _ _ UNTAUS1 UNTAUS2). + apply Reflexive_eq_notauF; eauto. + left; apply reflexivity. + + eapply unalltaus_tau in UNTAUS1; eauto. +Qed. + +(* We can now rewrite with [euttE] equalities. *) +Global Instance Equivalence_euttE : @Equivalence (itree E R) euttE. +Proof. constructor; typeclasses eauto. Qed. + +(**) + +Global Instance euttE_go : Proper (going euttE ==> euttE) go. +Proof. intros ? ? []; eauto. Qed. + +Global Instance euttE_observe : Proper (euttE ==> going euttE) observe. +Proof. + constructor. punfold H. pfold. destruct H. econstructor; eauto. +Qed. + +Global Instance euttE_tauF : Proper (euttE ==> going euttE) (fun t => TauF t). +Proof. + constructor; pfold. punfold H. + destruct H. econstructor. + - split; intros; simpl. + + rewrite finite_taus_tau, <-FIN, <-finite_taus_tau; eauto. + + rewrite finite_taus_tau, FIN, <-finite_taus_tau; eauto. + - intros. eapply EQV; eapply unalltaus_tau; eauto. +Qed. + +Global Instance euttE_VisF {u} (e: E u) : + Proper (pointwise_relation _ euttE ==> going euttE) (VisF e). +Proof. + constructor; pfold. red in H. econstructor. + - repeat econstructor. + - intros. + destruct UNTAUS1 as [UNTAUS1 Hnotau1]. + destruct UNTAUS2 as [UNTAUS2 Hnotau2]. + dependent destruction UNTAUS1. + dependent destruction UNTAUS2. simpobs. + econstructor; intros; left; apply H. +Qed. + +Global Instance eq_itree_notauF : + Proper (going (@eq_itree E R _ eq) ==> flip impl) notauF. +Proof. + intros ? ? [] ?; punfold H. inv H; simpl in *; subst; eauto. +Qed. + +(* If [t1] and [t2] are equivalent, then either both start with + finitely many taus, or both [spin]. *) +Global Instance euttE_finite_taus : + Proper (going euttE ==> flip impl) finite_tausF. +Proof. + intros ? ? [] ?; punfold H. eapply H. eauto. +Qed. + +End EUTT_eq. + +(**) + +Lemma euttE_tau {E R1 R2} (RR : R1 -> R2 -> Prop) + (t1 : itree E R1) (t2 : itree E R2) : + euttE RR t1 t2 -> euttE RR (Tau t1) (Tau t2). +Proof. + intros H. + pfold. eapply euttEF_tau. reflexivity. reflexivity. punfold H. +Qed. + +Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) + {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : + (forall u, eq_itree RR (k1 u) (k2 u)) -> + eq_itree RR (Vis e k1) (Vis e k2). +Proof. + intros; pfold; constructor; left. apply H. +Qed. + +Lemma eq_itree_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : + RR r1 r2 -> @eq_itree E _ _ RR (Ret r1) (Ret r2). +Proof. + intros; pfold; eauto; constructor; auto. +Qed. + +(* Lemmas about [bind]. *) + +Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) (observe t')), + untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). +Proof. + intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. + induction UNTAUS; intros; subst. + - rewrite !unfold_bind; simpobs; eauto. + - rewrite unfold_bind. simpobs. cbn. eauto. +Qed. + +Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) t'), + untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). +Proof. + intros; eapply untaus_bind; eauto. +Qed. + +Lemma finite_taus_bind_fst {E R S} + (t : itree E R) (f : R -> itree E S) : + finite_taus (ITree.bind t f) -> finite_taus t. +Proof. + intros [tf' [TAUS PROP]]. + genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. + induction TAUS; intros; subst. + - rewrite unfold_bind in PROP. + genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + rewrite unfold_bind in Heqobtf. simpobs. inv Heqobtf. unfold_bind. + eapply finite_taus_tau; eauto. +Qed. + +Lemma finite_taus_bind {E R S} + (t : itree E R) (f : R -> itree E S) + (FINt: finite_tausF (observe t)) + (FINk: forall v, finite_tausF (observe (f v))): + finite_tausF (observe (ITree.bind t f)). +Proof. + rewrite unfold_bind. + genobs t ot. clear Heqot t. + destruct FINt as [ot' [UNT NOTAU]]. + induction UNT; subst. + - destruct ot0; inv NOTAU; simpl; eauto 7. + - apply finite_taus_tau. eauto. +Qed. + +Inductive euttE_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := +| euttE_bind_clo_intro U (t1 t2: itree E U) k1 k2 + (EQV: euttE eq t1 t2) + (REL: forall v, r (k1 v) (k2 v)) + : euttE_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) +. +Hint Constructors euttE_bind_clo. + +Lemma bind_clo_finite_taus {E U R1 R2} t1 t2 k1 k2 + (FT: finite_taus (@ITree.bind E U R1 t1 k1)) + (FTk: forall v, finite_taus (k1 v) -> finite_taus (k2 v)) + (EQV: euttE eq t1 t2): + finite_taus (@ITree.bind E U R2 t2 k2). +Proof. + punfold EQV. destruct EQV as [[FTt _] EQV]. + assert (FT1 := FT). apply finite_taus_bind_fst in FT1. + assert (FT2 := FT1). apply FTt in FT2. + destruct FT1 as [a [FT1 NT1]], FT2 as [b [FT2 NT2]]. + rewrite @untaus_finite_taus in FT; [|eapply untaus_bindF, FT1]. + rewrite unfold_bind. genobs t2 ot2. clear Heqot2 t2. + induction FT2. + - destruct ot0; inv NT2; simpl; eauto 7. + hexploit EQV; eauto. intros EQV'. inv EQV'. + rewrite unfold_bind in FT. eauto. + - subst. eapply finite_taus_tau; eauto. + eapply IHFT2; eauto using unalltaus_tau'. +Qed. + +Lemma euttE_clo_bind {E R1 R2} RR : weak_respectful2 (@euttE_ E R1 R2 RR) euttE_bind_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. split. + - assert (EQV':=EQV). symmetry in EQV'. + split; intros; eapply bind_clo_finite_taus; eauto; intros. + + edestruct GF; eauto. apply FIN. eauto. + + edestruct GF; eauto. apply FIN. eauto. + - punfold EQV. destruct EQV. + intros. + hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS1|]. intros [a FT1]. + hexploit (@finite_taus_bind_fst E); [do 2 eexists; apply UNTAUS2|]. intros [b FT2]. + specialize (EQV _ _ FT1 FT2). + destruct FT1 as [FT1 Hnotau1]. destruct FT2 as [FT2 Hnotau2]. + hexploit @untaus_bindF; [ eapply FT1 | ]. intros UT1. + hexploit @untaus_bindF; [ eapply FT2 | ]. intros UT2. + hexploit @untaus_unalltaus_rev; [apply UT1| |]. eauto. intros UAT1. + hexploit @untaus_unalltaus_rev; [apply UT2| |]; eauto. intros UAT2. + inv EQV. + + rewrite unfold_bind in UAT1. rewrite unfold_bind in UAT2. cbn in *. + eapply GF in REL. destruct REL. + eapply monotone_eq_notauF; eauto using rclo2. + + rewrite unfold_bind in UAT1. rewrite unfold_bind in UAT2. cbn in *. + destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. + dependent destruction UAT1. dependent destruction UAT2. simpobs. + econstructor. intros. specialize (H x). pclearbot. fold_bind. eauto using rclo2. +Qed. + +Inductive euttE_trans_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| euttE_pre_clo_intro t1 t2 t3 t4 + (EQVl: euttE eq t1 t2) + (EQVr: euttE eq t4 t3) + (REL: r t2 t3) + : euttE_trans_clo r t1 t4 +. +Hint Constructors euttE_trans_clo. + +Lemma euttE_clo_trans {E R1 R2} RR : + weak_respectful2 (@euttE_ E R1 R2 RR) euttE_trans_clo. +Proof. + econstructor; [pmonauto|]. + intros. inv PR. + punfold EQVl. punfold EQVr. destruct EQVl, EQVr. split. + { rewrite FIN, FIN0. apply GF in REL. destruct REL. eauto. } + + intros. apply proj1 in FIN. edestruct FIN as [n'' [t2'' TAUS'']]; [eexists; eauto|]. + hexploit EQV; eauto. intros EUTT1. + apply proj1 in FIN0. edestruct FIN0 as [n''' [t2''' TAUS''']]; [eexists; eauto|]. + hexploit EQV0; eauto. intros EUTT2. + apply GF in REL. destruct REL. + hexploit EQV1; eauto. intros EUTT3. + destruct EUTT1; destruct EUTT2; + try (solve [subst; inversion EUTT3; auto]). + remember (VisF _ _) as o2 in EUTT3. + remember (VisF _ _) as o3 in EUTT3. + inversion EUTT3; subst; try discriminate. + inversion H2; clear H2; inversion H3; clear H3. + subst; auto_inj_pair2; subst. + econstructor. intros. + specialize (H x); specialize (H0 x); specialize (H1 x). + pclearbot. eauto using rclo2. +Qed. + +Arguments euttE_clo_trans : clear implicits. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index 94bf4945..b19506db 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -24,6 +24,7 @@ Section Facts. Context {D E : Type -> Type} (ctx : D ~> itree (D +' E)). (** Unfolding of [interp_mrec]. *) + Definition interp_mrecF R : itreeF (D +' E) R _ -> itree E R := handleF1 (interp_mrec ctx R) @@ -96,118 +97,65 @@ Proof. all: try (pfold; econstructor; eauto). Qed. -Let h_mrec : D ~> itree E := mrec ctx. - -Inductive mrec_invariant {U} : relation (itree _ U) := -| mrec_main (d1 d2 : _ U) (Ed : eq_itree eq d1 d2) : - mrec_invariant (interp_mrec ctx _ d1) - (interp1 (mrec ctx) _ d2) -| mrec_bind T (d : _ T) (k1 k2 : T -> itree _ U) - (Ek : forall x, eq_itree eq (k1 x) (k2 x)) : - mrec_invariant (interp_mrec ctx _ (d >>= k1)) - (interp_mrec ctx _ d >>= fun x => - interp1 h_mrec _ (k2 x)) -. - -Notation mi_holds r := - (forall c1 c2 d1 d2, - mrec_invariant d1 d2 -> - eq_itree eq c1 d1 -> eq_itree eq c2 d2 -> r c1 c2). - -Lemma mrec_invariant_init {U} (r : relation (itree _ U)) - (INV : mi_holds r) - (c1 c2 : itree _ U) - (Ec : eq_itree eq c1 c2) : - paco2 (compose (eq_itree_ eq) (gres2 (eq_itree_ eq))) r - (interp_mrec ctx _ c1) - (interp1 h_mrec _ c2). -Proof. - rewrite observe_interp_mrec, unfold_interp1. - punfold Ec. - inversion Ec; cbn; pclearbot; pupto2_final. - + subst; apply reflexivity. - + pfold; constructor. right; eapply INV. - 1: apply mrec_main; eassumption. - all: reflexivity. - + destruct e. - { pfold; constructor; cbn; right. eapply INV. - 1: apply mrec_bind; eassumption. - all: cbn; reflexivity. - } - { pfold; econstructor. - intros; right. eapply INV. - 1: apply mrec_main; eapply REL. - all: reflexivity. - } -Qed. - -Lemma mrec_invariant_eq {U} : mi_holds (@eq_itree _ U _ eq). -Proof. - intros d1 d2 c1 c2 Ec1 Ec2 H. - pupto2_init; revert d1 d2 c1 c2 Ec1 Ec2 H; pcofix self. - intros _d1 _d2 c1 c2 [d1 d2 Ed | T d k1 k2 Ek] Ec1 Ec2. - - rewrite Ec1, Ec2. - apply mrec_invariant_init; auto 10. - - rewrite Ec1, Ec2. cbn. - rewrite observe_interp_mrec. - rewrite (unfold_bind (interp_mrec _ _ d)). - unfold observe, _observe; cbn. - destruct (observe d); fold_observe; cbn. - + rewrite <- observe_interp_mrec. - apply mrec_invariant_init; auto. - + pupto2_final; pfold; constructor; right. - eapply self. - 1: apply mrec_bind; eassumption. - all: cbn; fold_bind; reflexivity. - + destruct e; cbn. - * fold_bind. rewrite <-bind_bind. - pupto2_final. pfold. econstructor. right. - eapply self. - 1: apply mrec_bind; eassumption. - all: cbn; reflexivity. - * pupto2_final; pfold; constructor; right. - eapply self. - 1: apply mrec_bind; eassumption. - all: cbn; fold_bind; reflexivity. -Qed. - Theorem unfold_interp_mrec {T} (c : itree _ T) : - interp_mrec ctx _ c ≅ interp1 h_mrec _ c. + interp_mrec ctx _ c ≈ interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) _ c. Proof. - eapply mrec_invariant_eq; - try eapply mrec_main; reflexivity. + revert_until ctx. + cut (forall T R (t: itree E R) k, + ITree.bind t (fun x => interp_mrec ctx T (k x)) ≈ + ITree.bind t (fun x => interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) T (k x))). + { intros. specialize (H _ _ (Ret ()) (fun _ => c)). + rewrite !ret_bind in H. auto. + } + + intros. pupto2_init. revert_until T. pcofix CIH. + intros. pfold. pupto2_init. revert_until CIH. pcofix CIH'. + intros. rewrite (itree_eta t). genobs_clear t ot. + destruct ot. + - rewrite !ret_bind. + generalize (k r1) as t. clear R k r1. + intros. rewrite (itree_eta t). genobs_clear t ot. + destruct ot. + + rewrite ret_mrec, ret_interp. simpl. eauto. + + rewrite tau_mrec, tau_interp. simpl. + pfold. econstructor. pupto2_final. right. + apply (CIH' _ (Ret tt) (fun _ => t)). + + destruct e. + * rewrite vis_mrec_left, vis_interp. simpl. + rewrite interp_mrec_bind. + pfold. econstructor. pupto2_final. eauto. + * rewrite vis_mrec_right, vis_interp. simpl. + setoid_rewrite vis_bind_. setoid_rewrite ret_bind_. + pfold. econstructor. econstructor. intros. + rewrite <- (ret_bind () (fun _ => interp_mrec _ _ _)). + rewrite <- (ret_bind () (fun _ => interp _ _ _)). + pupto2_final. eauto. + - rewrite !tau_bind. + pfold. econstructor. pupto2_final. eauto. + - rewrite !vis_bind. + pfold. econstructor. intros. pupto2_final. eauto. Qed. Theorem unfold_mrec {T} (d : D T) : - mrec ctx _ d ≅ interp1 (mrec ctx) _ (ctx _ d). + mrec ctx _ d ≈ interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) _ (ctx _ d). Proof. apply unfold_interp_mrec. Qed. End Facts. -Lemma rec_unfold' {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : - rec f x ≅ interp1 (fun _ e => calling' (rec f) _ e) _ (f x). +Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : + rec f x ≈ interp (Sum1.elim (C:=itree E) (calling' (rec f)) ITree.liftE) _ (f x). Proof. unfold rec. unfold mrec. rewrite unfold_interp_mrec. - unfold interp_match. - unfold mrec. eapply eq_itree_interp1_. - - intros ? []; reflexivity. + eapply eutt_interp. + - red. intro. red. destruct a; try reflexivity. + destruct c. + reflexivity. - reflexivity. Qed. -Lemma rec_unfold {E A B} (f : A -> itree (callE A B +' E) B) (x : A) : - rec f x ≈ interp (fun _ e => match e with - | inl1 e => calling' (rec f) _ e - | inr1 e => ITree.liftE e - end) _ (f x). -Proof. - rewrite rec_unfold'. - rewrite <- interp_is_interp1. - reflexivity. -Qed. - Notation loop_once_ f loop_ := (loop_once f (fun cb => Tau (loop_ f%function cb))). @@ -279,8 +227,8 @@ Proof. remember (inr a') as ca eqn:EQ; clear EQ a'. pupto2_init. revert ca; clear; pcofix self; intro ca. rewrite unfold_loop'; unfold loop_once. - pupto2 @eq_itree_clo_bind; constructor; try reflexivity. - intros [c | b]. + pupto2 @eq_itree_clo_bind; econstructor; try reflexivity. + intros [c | b]; intros; subst. - match goal with | [ |- _ _ (Tau (loop_ ?f _)) ] => rewrite (unfold_loop' f) end. @@ -304,8 +252,8 @@ Proof. pupto2_init. revert ca; clear; pcofix self; intro ca. rewrite !unfold_loop'; unfold loop_once. rewrite !bind_bind. - pupto2 @eq_itree_clo_bind; constructor; try reflexivity. - intros [c | b]. + pupto2 @eq_itree_clo_bind; econstructor; try reflexivity. + intros [c | b]; intros; subst. - rewrite ret_bind_, tau_bind_. pfold; constructor; auto. - autorewrite with itree. @@ -337,15 +285,15 @@ Proof. rewrite map_bind. rewrite (unfold_loop' _ (inl c)); unfold loop_once. autorewrite with itree. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - intros c'. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros c'; intros; subst. rewrite tau_bind. rewrite ret_bind_. rewrite unfold_loop'; unfold loop_once. rewrite bind_bind. pfold; constructor. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - auto. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros; subst. eauto. - rewrite ret_bind. pupto2_final; apply reflexivity. Qed. @@ -378,16 +326,16 @@ Proof. rewrite 2 unfold_loop'; unfold loop_once. autorewrite with itree. pfold; constructor. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - auto. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros; subst. auto. - (* c *) rewrite ret_bind. rewrite 2 unfold_loop'; unfold loop_once. rewrite unfold_loop'; unfold loop_once. autorewrite with itree. pfold; constructor. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - auto. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros; subst. auto. - (* b *) rewrite ret_bind. pupto2_final; apply reflexivity. @@ -418,14 +366,14 @@ Proof. rewrite bind_bind. destruct inra as [c | a]; subst. - rewrite bind_bind; setoid_rewrite ret_bind_. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - intros [c' | b]; simpl. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros [c' | b]; simpl; intros; subst. + rewrite tau_bind. pfold; constructor. pupto2_final. auto. + rewrite ret_bind. pupto2_final; apply reflexivity. - rewrite bind_bind; setoid_rewrite ret_bind_. - pupto2 eq_itree_clo_bind; constructor; try reflexivity. - intros [c' | b]; simpl. + pupto2 eq_itree_clo_bind; econstructor; try reflexivity. + intros [c' | b]; simpl; intros; subst. + rewrite tau_bind. pfold; constructor. pupto2_final. auto. + rewrite ret_bind_. pupto2_final; apply reflexivity. @@ -477,8 +425,8 @@ Proof. remember (inr _) as ca eqn:EQ; clear EQ y0. pupto2_init. revert ca; pcofix self; intros. rewrite 2 unfold_loop'; unfold loop_once. - pupto2 eq_itree_clo_bind; constructor; try auto. - intros [c | b]; pfold; constructor; auto. + pupto2 eq_itree_clo_bind; econstructor; try auto. + intros [c | b]; intros; subst; pfold; constructor; auto. Qed. Section eutt_loop. diff --git a/theories/Morphisms.v b/theories/Morphisms.v index bfc89e69..601c766c 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -150,11 +150,6 @@ Definition interp {E F : Type -> Type} (h : E ~> itree F) : (fun x => interp_ (k x)))) (observe t). - - - - - (* N.B.: the guardedness of this definition relies on implementation details of [bind]. *) @@ -165,6 +160,7 @@ Definition interp {E F : Type -> Type} (h : E ~> itree F) : allows a few equations to be bisimularities ([eq_itree]) instead of up-to-tau equivalences ([eutt]). *) + Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : itree (E +' F) ~> itree G := fun R => cofix interp1_ t := @@ -180,7 +176,6 @@ Definition interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) : (** Effects [E, F : Type -> Type] and itree [E ~> itree F] form a category. *) - (* Morphism Category -------------------------------------------------------- *) Definition eh_cmp {A B C} (g : B ~> itree C) (f : A ~> itree B) : @@ -281,7 +276,6 @@ CoFixpoint interp1_state {E F S} (h : E ~> stateT S (itree F)) : itree (E +' F) ~> stateT S (itree F) := fun R => interp1_state_match h (interp1_state h R). - Definition translate1_state {E F S} (h : E ~> state S) : itree (E +' F) ~> stateT S (itree F) := fun R => @@ -305,13 +299,9 @@ Definition interp_reader {E F R} (h : R -> E ~> itree F) : R -> itree E ~> itree F := fun r => interp (h r). -Definition interp1_reader {E F R} (h : R -> E ~> itree F) : - R -> itree (E +' F) ~> itree F := - fun r => interp1 (h r). - -Definition translate1_reader {E F R} (h : R -> E ~> identity) : - R -> itree (E +' F) ~> itree F := - fun r => interp1 (fun _ e => Ret (h r _ e)). +Definition translate_reader {E F R} (h : R -> E ~> identity) : + R -> itree E ~> itree F := + fun r => interp (fun _ e => Ret (h r _ e)). Import ExtLib.Structures.Monoid. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 16037552..4a8d3a61 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -61,26 +61,22 @@ Definition interp_u {E F} (f : E ~> itree F) R : (fun _ e k => Tau (ITree.bind (f _ e) (fun x => interp f _ (k x)))). -Lemma interp_unfold {E F R} {f : E ~> itree F} (t : itree E R) : - observe (interp f _ t) = observe (interp_u f _ (observe t)). -Proof. eauto. Qed. - Lemma unfold_interp {E F R} {f : E ~> itree F} (t : itree E R) : - interp f _ t ≅ interp_u f _ (observe t). -Proof. rewrite itree_eta_, interp_unfold, <-itree_eta_. reflexivity. Qed. + observing eq (interp f _ t) (interp_u f _ (observe t)). +Proof. econstructor. reflexivity. Qed. (** ** [interp] and constructors *) Lemma ret_interp {E F R} {f : E ~> itree F} (x: R): - interp f _ (Ret x) ≅ Ret x. + observing eq (interp f _ (Ret x)) (Ret x). Proof. rewrite unfold_interp. reflexivity. Qed. Lemma tau_interp {E F R} {f : E ~> itree F} (t: itree E R): - interp f _ (Tau t) ≅ Tau (interp f _ t). + observing eq (interp f _ (Tau t)) (Tau (interp f _ t)). Proof. rewrite unfold_interp. reflexivity. Qed. Lemma vis_interp {E F R} {f : E ~> itree F} U (e: E U) (k: U -> itree E R) : - interp f _ (Vis e k) ≅ Tau (ITree.bind (f _ e) (fun x => interp f _ (k x))). + observing eq (interp f _ (Vis e k)) (Tau (ITree.bind (f _ e) (fun x => interp f _ (k x)))). Proof. rewrite unfold_interp. reflexivity. Qed. (** ** [interp] properness *) @@ -95,15 +91,15 @@ Proof. pcofix CIH. rename r into rr. intros l r Hlr. - rewrite itree_eta, (itree_eta (interp g _ r)), !interp_unfold. + rewrite itree_eta, (itree_eta (interp g _ r)), !unfold_interp. punfold Hlr; red in Hlr. destruct Hlr; pclearbot. - pupto2_final. pfold. red. cbn. eauto. - pupto2_final. pfold. red. cbn. eauto. - - pfold. econstructor. pupto2 (eq_itree_clo_bind F R). - constructor. + - pfold. econstructor. pupto2 eq_itree_clo_bind. + econstructor. + eapply Hfg. - + eauto. intros; pupto2_final; right; eauto. + + intros; subst; pupto2_final; right; eauto. Qed. Global Instance Proper_interp_eq_itree {E F R f} @@ -118,8 +114,26 @@ Instance eutt_interp (E F : Type -> Type) (R : Type) : Proper (Rhom (fun _ => eutt eq) ==> eutt eq ==> eutt eq) (fun f => @interp E F f R). Proof. - (* this is going to be a terrible proof. *) -Admitted. + repeat intro. revert_until H. repeat red in H. + cut (forall T t1 t2 k1 k2 (EQt: t1 ≈ t2) (EQk: forall v:T, k1 v ≈ k2 v), + (v <- t1 ;; interp x R (k1 v)) ≈ (v <- t2 ;; interp y R (k2 v))). + { intros. + hexploit (H0 _ (Ret ()) (Ret ()) (fun _ => x0) (fun _ => y0)); try reflexivity; eauto. intros EQV. + rewrite !ret_bind in EQV. eauto. + } + + pcofix CIH. intros. + pfold. revert_until CIH. pcofix CIH'. intros. + do 2 punfold EQt. pfold. + rewrite !unfold_bind. genobs_clear t1 ot1. genobs_clear t2 ot2. + induction EQt; intros; subst; pclearbot; try (econstructor; eauto 7; fail). + simpl. rewrite !unfold_interp. unfold interp_u. unfold handleF. + specialize (EQk r2). do 2 punfold EQk. + genobs (k1 r2) kr1. genobs (k2 r2) kr2. clear Heqkr1 k1 Heqkr2 k2 r2. + induction EQk; intros; subst; pclearbot; try (econstructor; eauto 7; fail). + econstructor. right. + eapply (CIH' _ (Ret ()) (Ret ()) (fun _ => t1) (fun _ => t2)); try reflexivity; eauto. +Qed. Lemma interp_ret : forall {E F R} x (f : E ~> itree F), @@ -139,14 +153,14 @@ Proof. pcofix CIH. intros. rewrite (itree_eta t). destruct (observe t). (* TODO: [ret_bind] (0.8s) is much slower than [ret_bind_] (0.02s) *) - - rewrite ret_interp. rewrite !ret_bind_. pupto2_final. apply reflexivity. - - rewrite tau_interp, !tau_bind_, tau_interp. + - rewrite ret_interp. rewrite !ret_bind. pupto2_final. apply reflexivity. + - rewrite tau_interp, !tau_bind, tau_interp. pupto2_final. pfold. econstructor. eauto. - rewrite vis_interp, tau_bind. rewrite bind_bind. pfold. do 2 red; cbn. constructor. pupto2 (eq_itree_clo_bind F S). econstructor. + reflexivity. - + intros; specialize (CIH _ (k0 v) k); auto. + + intros; subst. specialize (CIH _ (k0 u2) k); auto. Qed. @@ -158,7 +172,7 @@ Proof. unfold ITree.liftE. rewrite vis_interp. apply itree_eq_tau. assert (pointwise_relation _ (@eq_itree _ _ _ (@eq R)) (fun x : R => interp f R (Ret x)) (fun x => Ret x)). - {red. intros. apply ret_interp. } + {red. intros. rewrite ret_interp. reflexivity. } rewrite H. rewrite bind_ret. reflexivity. Qed. @@ -174,19 +188,17 @@ Proof. pcofix CIH. intros t. rewrite unfold_interp. unfold interp_u. unfold handleF. - rewrite eutt_is_eutt'_gres. pfold. revert t. pcofix CIH'. intros t. - destruct (observe t); cbn. + destruct (observe t); cbn; eauto. - pfold. econstructor. - - pfold. econstructor. - right. rewrite interp_unfold. unfold interp_u. unfold handleF. + right. rewrite unfold_interp. unfold interp_u. unfold handleF. apply CIH'. - pfold. econstructor. cbn. econstructor. intros. assert (ITree.bind' (fun x0 : u => interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0)) (Ret x) = (x0 <- Ret x ;; interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0))). { intros; reflexivity. } rewrite H. - rewrite ret_bind_. (* TODO: Why does [ret_bind] not work at all. *) + rewrite ret_bind. pupto2_final. right. apply CIH. Qed. @@ -210,134 +222,13 @@ Proof. - pupto2_final. pfold. econstructor. right. apply CIH. - rewrite interp_bind. pfold. econstructor. - pupto2 eq_itree_clo_bind_h. + pupto2 eq_itree_clo_bind. apply pbc_intro_h with (RU := eq). + reflexivity. + intros. pupto2_final. right. subst. apply CIH. Qed. -(** * [interp1] *) - -(* SAZ: If we need to introduce these auxilliar definitions to prove - properties about functions like interp1, I think that we should - _define_ interp1 in terms of its unfolding. I have experimented - with porting interp_state and interp1_state to this form. -*) -(* Unfolding of [interp1]. *) -Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : - itreeF (E +' F) R _ -> itree G R := - handleF (interp1 h _) - (fun _ ef k => - match ef with - | inl1 e => Tau (ITree.bind (h _ e) - (fun x => interp1 h _ (k x))) - | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) - end). - -Lemma interp1_unfold {E F G} `{F -< G} {R} {f : E ~> itree G} (t : itree (E +' F) R) : - observe (interp1 f _ t) = observe (interp1_u f _ (observe t)). -Proof. eauto. Qed. - -Lemma unfold_interp1 {E F G} `{F -< G} {R} {f : E ~> itree G} (t : itree (E +' F) R) : - interp1 f _ t ≅ interp1_u f _ (observe t). -Proof. rewrite itree_eta, interp1_unfold, <-itree_eta. reflexivity. Qed. - -(** ** [interp1] is equivalent to [interp] *) - -Section interp1_is_interp. - -Context {E F G : Type -> Type} `{F -< G} (f : E ~> itree G). - -Definition interp_match : (E +' F) ~> itree G := - fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis (subeffect _ e) (fun r => Ret r) end. - -Inductive interp_inv {R} : relation (itree' G R) := -| _interp_inv_main t: - interp_inv - (observe (interp interp_match _ t)) (observe (interp1 f _ t)) -| _interp_inv_bind u t (k: u -> _): - interp_inv - (observe (ITree.bind t (fun x => interp interp_match _ (k x)))) - (observe (ITree.bind t (fun x => interp1 f _ (k x)))) -. -Hint Constructors interp_inv. - -Lemma interp_inv_main_step R (t: itree _ R) : - euttF' (fun x y => interp_inv (observe x) (observe y)) interp_inv - (observe (interp interp_match _ t)) (observe (interp1 f _ t)). -Proof. - rewrite interp_unfold, interp1_unfold. - genobs t ot. clear Heqot t. - destruct ot; simpl; eauto. - destruct e; simpl; eauto. - econstructor. rewrite unfold_bind. - econstructor. intros. - fold_bind. rewrite unfold_bind. simpl. eauto. -Qed. - -Lemma interp_is_interp1 R (t: itree _ R) : - interp interp_match _ t ≈ interp1 f _ t. -Proof. - revert t. - cut (forall (t1 t2: itree _ R) (REL: interp_inv (observe t1) (observe t2)), t1 ≈ t2). - { eauto. } - - intros. apply eutt_is_eutt'. - revert t1 t2 REL. pcofix CIH. intros. pfold. - revert t1 t2 REL. pcofix CIH'. intros. - destruct REL. - - pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. - eapply upaco2_mon; eauto. intros. - eapply (CIH' (go x2) (go x3)); eauto. - - rewrite !unfold_bind. fold_bind. - genobs t ot. clear Heqot t. - destruct ot; simpl; eauto 10. - pfold. eapply euttF'_mon; eauto using interp_inv_main_step; intros. - eapply upaco2_mon; eauto. intros. - eapply (CIH' (go x2) (go x3)); eauto. -Qed. - -End interp1_is_interp. - -Lemma eq_itree_interp1_ {E F R} (h1 h2 : E ~> itree F) : - (forall T (e : E T), h1 _ e ≅ h2 _ e) -> - forall t1 t2 : itree (E +' F) R, - t1 ≅ t2 -> interp1 h1 _ t1 ≅ interp1 h2 _ t2. -Proof. - intros Hh t1 t2 Ht. - pupto2_init. revert_until R. - pcofix CIH. intros. - rewrite !unfold_interp1. - punfold Ht; red in Ht. - destruct Ht; pclearbot. - - pupto2_final. pfold. red. cbn. eauto. - - pupto2_final. pfold. red. cbn. eauto. - - pfold. destruct e; cbn; econstructor. - + pupto2 (eq_itree_clo_bind F R). - constructor. - * auto. - * intros; pupto2_final; eauto. - + intros; pupto2_final; eauto. -Qed. - -Instance eq_itree_interp1 {E F G} `{F -< G} {R} (h : E ~> itree F) : - Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). -Proof. - repeat intro. - eapply eq_itree_interp1_; auto. - reflexivity. -Qed. - -Instance eutt_interp1 {E F G: Type -> Type} `{F -< G} (h: E ~> itree G) R: - Proper (eutt eq ==> eutt eq) (@interp1 E F G _ h R). -Proof. - repeat intro. - rewrite <- 2 interp_is_interp1. - eapply eutt_interp; auto. - red; reflexivity. -Qed. - (** * [interp_state] *) Lemma unfold_interp_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, @@ -362,9 +253,9 @@ Proof. - pupto2_final. pfold. red. cbn. subst. eauto. - pupto2_final. pfold. red. cbn. subst. eauto. - pfold. econstructor. pupto2 (eq_itree_clo_bind F (S * R)). - constructor. + econstructor. + subst. reflexivity. - + intros; pupto2_final; right; eauto. + + intros; subst. pupto2_final; right; eauto. Qed. @@ -391,9 +282,9 @@ Proof. - pfold. destruct e. * econstructor. pupto2 (eq_itree_clo_bind F (S * R)). - constructor. + econstructor. + subst. reflexivity. - + intros. pupto2_final. right. eauto. + + intros; subst. pupto2_final. right. eauto. * econstructor. intros. pupto2_final. right. eauto. Qed. @@ -514,15 +405,15 @@ Proof. rewrite (itree_eta t). destruct (observe t). (* TODO: performance issues with [ret|tau|vis_bind] here too. *) - - cbn. rewrite interp_state_ret. rewrite !ret_bind_. simpl. + - cbn. rewrite interp_state_ret. rewrite !ret_bind. simpl. pupto2_final. apply reflexivity. - - cbn. rewrite interp_state_tau, !tau_bind_, interp_state_tau. + - cbn. rewrite interp_state_tau, !tau_bind, interp_state_tau. pupto2_final. pfold. econstructor. right. apply CIH. - - cbn. rewrite interp_state_vis, tau_bind_, vis_bind_, bind_bind, interp_state_vis. + - cbn. rewrite interp_state_vis, tau_bind, vis_bind, bind_bind, interp_state_vis. pfold. red. constructor. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. - + intros. specialize (CIH _ (k0 (snd v)) k (fst v)). auto. + + intros. subst. specialize (CIH _ (k0 (snd u2)) k (fst u2)). auto. Qed. Lemma interp1_state_bind {E F : Type -> Type} {A B S : Type} @@ -539,17 +430,17 @@ Proof. intros A t k s. rewrite (itree_eta t). destruct (observe t). - - cbn. rewrite interp1_state_ret. rewrite !ret_bind_. simpl. + - cbn. rewrite interp1_state_ret. rewrite !ret_bind. simpl. pupto2_final. apply reflexivity. - - cbn. rewrite interp1_state_tau, !tau_bind_, interp1_state_tau. + - cbn. rewrite interp1_state_tau, !tau_bind, interp1_state_tau. pupto2_final. pfold. econstructor. right. apply CIH. - cbn. destruct e. - * rewrite interp1_state_vis1, tau_bind_, vis_bind_, bind_bind, interp1_state_vis1. + * rewrite interp1_state_vis1, tau_bind, vis_bind, bind_bind, interp1_state_vis1. pfold. red. constructor. pupto2 (eq_itree_clo_bind F (S * B)). econstructor. + reflexivity. - + intros. specialize (CIH _ (k0 (snd v)) k (fst v)). auto. - * rewrite interp1_state_vis2, !vis_bind_. rewrite itree_eta. rewrite unfold_interp1_state. + + intros. subst. specialize (CIH _ (k0 (snd u2)) k (fst u2)). auto. + * rewrite interp1_state_vis2, !vis_bind. rewrite itree_eta. rewrite unfold_interp1_state. cbn. pfold. constructor. intros. specialize (CIH _ (k0 v) k s). auto. Qed. @@ -581,7 +472,7 @@ Proof. pupto2 eq_itree_clo_bind. econstructor. + reflexivity. - + intros. pupto2_final. right. apply CIH. + + intros. subst. pupto2_final. right. apply CIH. Qed. Lemma translate_to_interp {E F R} (f : E ~> F) (t : itree E R) : @@ -596,14 +487,12 @@ Proof. rewrite unfold_translate. rewrite unfold_interp. unfold translateF, interp_u, handleF. - rewrite eutt_is_eutt'_gres. pfold. revert t. pcofix CIH'. intros t. - destruct (observe t). - - pfold. econstructor. + destruct (observe t); cbn; eauto. - pfold. econstructor. right. rewrite unfold_translate. unfold translateF. - rewrite interp_unfold. unfold interp_u. apply CIH'. + rewrite unfold_interp. unfold interp_u. apply CIH'. - pfold. econstructor. unfold ITree.liftE. rewrite vis_bind. econstructor. intros. rewrite (itree_eta (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))). @@ -631,18 +520,16 @@ Proof. pcofix CIH. intros t. rewrite unfold_interp. unfold interp_u. unfold handleF. - rewrite eutt_is_eutt'_gres. pfold. revert t. pcofix CIH'. intros t. - destruct (observe t); cbn. + destruct (observe t); cbn; eauto. - pfold. econstructor. - - pfold. econstructor. - right. rewrite interp_unfold. unfold interp_u. unfold handleF. + right. rewrite unfold_interp. unfold interp_u. unfold handleF. apply CIH'. - pfold. econstructor. cbn. econstructor. intros. assert (ITree.bind' (fun x0 : u => interp eh_id R (k x0)) (Ret x) = (x0 <- Ret x ;; interp eh_id R (k x0))). { intros; reflexivity. } - rewrite H. rewrite ret_bind_. (* TODO: [ret_bind] doesn't work *) + rewrite H. rewrite ret_bind. (* TODO: [ret_bind] doesn't work *) pupto2_final. right. apply CIH. Qed. @@ -737,21 +624,122 @@ Proof. simpl. unfold Sum1.idE. reflexivity. Qed. +(*** + lemmas about [interp1]. + We can remove [interp1] but keep it just in case it is useful. + ***) + +Definition interp1_u {E F G} `{F -< G} (h : E ~> itree G) R : + itreeF (E +' F) R _ -> itree G R := + handleF (interp1 h _) + (fun _ ef k => + match ef with + | inl1 e => Tau (ITree.bind (h _ e) + (fun x => interp1 h _ (k x))) + | inr1 f => Vis (subeffect _ f) (fun x => interp1 h _ (k x)) + end). + +Lemma unfold_interp1 {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) R (t : itree (E +' F) R) : + observing eq (interp1 h _ t) (interp1_u h _ (observe t)). +Proof. econstructor. auto. Qed. + +Lemma unfold_interp1_ {E F G : Type -> Type} `{F -< G} (h : E ~> itree G) R (t : itree (E +' F) R) : + interp1 h _ t ≅ interp1_u h _ (observe t). +Proof. rewrite itree_eta, unfold_interp1, <-itree_eta. reflexivity. Qed. + +(** ** [interp1] is equivalent to [interp] *) + +Definition interp_match {E F} (f: E ~> itree F) : (E +' F) ~> itree F := + fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis e (fun r => Ret r) end. + +Inductive interp_inv {E F R} (f: E ~> itree F) : relation (itree' F R) := +| _interp_inv_main t: + interp_inv f + (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)) +| _interp_inv_bind u t (k: u -> _): + interp_inv f + (observe (ITree.bind t (fun x => interp (interp_match f) _ (k x)))) + (observe (ITree.bind t (fun x => interp1 f _ (k x)))) +. +Hint Constructors interp_inv. + +Lemma interp_inv_main_step E F R (f: E ~> itree F) (t: itree _ R) : + euttF eq (fun x y => interp_inv f (observe x) (observe y)) (interp_inv f) + (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)). +Proof. + rewrite unfold_interp, unfold_interp1. + genobs_clear t ot. + destruct ot; simpl; eauto. + destruct e; simpl; eauto. + econstructor. rewrite unfold_bind. + econstructor. intros. + fold_bind. rewrite unfold_bind. simpl. eauto. +Qed. + +Lemma interp_is_interp1 E F R (f: E ~> itree F) (t: itree _ R) : + interp (interp_match f) _ t ≈ interp1 f _ t. +Proof. + revert t. + cut (forall (t1 t2: itree _ R) (REL: interp_inv f (observe t1) (observe t2)), t1 ≈ t2). + { eauto. } + + intros. revert_until f. pcofix CIH. intros. + pfold. revert_until CIH. pcofix CIH'. intros. + destruct REL. + - pfold. eapply euttF_mon; eauto using interp_inv_main_step; intros. + eapply upaco2_mon; eauto. intros. + eapply (CIH' (go x2) (go x3)); eauto. + - rewrite !unfold_bind. fold_bind. + genobs_clear t ot. + destruct ot; simpl; eauto 10. + pfold. eapply euttF_mon; eauto using interp_inv_main_step; intros. + eapply upaco2_mon; eauto. intros. + eapply (CIH' (go x2) (go x3)); eauto. +Qed. + +Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +Proof. + repeat intro. pupto2_init. revert_until R. + pcofix CIH. intros. + rewrite !unfold_interp1_. + punfold H0; red in H0. + destruct H0; pclearbot. + - pupto2_final. pfold. red. cbn. eauto. + - pupto2_final. pfold. red. cbn. eauto. + - pfold. destruct e; cbn; econstructor. + + pupto2 (eq_itree_clo_bind F R). + econstructor. + * reflexivity. + * intros; subst. pupto2_final; eauto. + + intros. pupto2_final. eauto. +Qed. + +Instance eutt_interp1 {E F: Type -> Type} (h: E ~> itree F) R: + Proper (eutt eq ==> eutt eq) (@interp1 E F F _ h R). +Proof. + repeat intro. + rewrite <- 2 interp_is_interp1. + eapply eutt_interp; auto. + red; reflexivity. +Qed. + Lemma interp1_bind {E F G} `{F -< G} {R S} (h : E ~> itree G) (t : _ R) (k : _ -> itree (E +' F) S) : interp1 h _ (t >>= k) ≅ interp1 h _ t >>= fun x => interp1 h _ (k x). Proof. pupto2_init. revert t; pcofix self; intros. - rewrite 2 unfold_interp1. rewrite unfold_bind. + rewrite !unfold_interp1_, unfold_bind, unfold_bind_. destruct (observe t); cbn. - - rewrite ret_bind_. rewrite <- unfold_interp1. - pupto2_final. apply RelationClasses.reflexivity. - - rewrite tau_bind_. pfold; constructor; auto. - - destruct e. - + rewrite tau_bind_. rewrite bind_bind. pfold; constructor. - pupto2 eq_itree_clo_bind. constructor. - reflexivity. auto. - + rewrite vis_bind_. pfold; constructor; auto. + - rewrite unfold_interp1_. + pupto2_final. apply reflexivity. + - pfold; constructor; auto. + - destruct e; cbn. + + rewrite bind_bind. pfold; constructor. + pupto2 eq_itree_clo_bind. econstructor. + * reflexivity. + * intros; subst. eauto. + + pfold; constructor; auto. Qed. Lemma translate_interp1 {E F R} (h : F ~> itree E) : @@ -760,7 +748,7 @@ Lemma translate_interp1 {E F R} (h : F ~> itree E) : Proof. pcofix self; intros. pfold; red. - rewrite interp1_unfold. + rewrite unfold_interp1. rewrite TranslateFacts.unfold_translate. destruct (observe t); cbn; auto. Qed. @@ -770,9 +758,9 @@ Lemma interp1_liftE {E F G: Type -> Type} `{F -< G}: @interp1 E F G _ h T (lift e) ≈ h T e. Proof. intros. unfold lift. - rewrite unfold_interp1; cbn. + rewrite unfold_interp1_; cbn. rewrite tau_eutt. - setoid_rewrite unfold_interp1; cbn. + setoid_rewrite unfold_interp1_; cbn. rewrite bind_ret. reflexivity. Qed. diff --git a/theories/Trace.v b/theories/Trace.v index bc59a611..aa8c1301 100644 --- a/theories/Trace.v +++ b/theories/Trace.v @@ -6,6 +6,7 @@ Import ListNotations. From ITree Require Import Core + Eq.Untaus Eq.UpToTaus Eq.SimUpToTaus. diff --git a/theories/TranslateFacts.v b/theories/TranslateFacts.v index fee8ab5b..5d2828c5 100644 --- a/theories/TranslateFacts.v +++ b/theories/TranslateFacts.v @@ -25,9 +25,9 @@ Section TranslateFacts. Context (h : E ~> F). Lemma unfold_translate : forall (t : itree E R), - observe (translate h t) = observe (translateF h (translate h) (observe t)). + observing eq (translate h t) (translateF h (translate h) (observe t)). Proof. - intros t. reflexivity. + intros t. econstructor. reflexivity. Qed. Lemma translate_ret : forall (r:R), translate h (Ret r) ≅ Ret r. @@ -52,7 +52,8 @@ Proof. rewrite unfold_translate. cbn. reflexivity. Qed. -Global Instance translate_Proper : Proper ( (eq_itree (@eq R)) ==> eq_itree eq) (translate h). +Global Instance translate_Proper : + Proper (eq_itree (@eq R) ==> eq_itree eq) (translate h). Proof. repeat red. intros x y H. @@ -80,6 +81,17 @@ Proof. right. apply CIH. eapply transitivity. pclearbot. apply REL0. reflexivity. Qed. + +Global Instance translateF_Proper : + Proper (going (eq_itree eq) ==> eq_itree (@eq R)) (translateF h (translate h)). +Proof. + repeat red. intros. + replace x with (observe (go x)) by auto. + replace y with (observe (go y)) by auto. + rewrite <- !unfold_translate. + rewrite H. apply reflexivity. +Qed. + End TranslateFacts. Lemma translate_bind : forall {E F R S} (h : E ~> F) (t : itree E S) (k : S -> itree E R), @@ -90,18 +102,12 @@ Proof. revert S t k. pcofix CIH. intros s t k. - rewrite itree_eta. - rewrite (itree_eta (x <- translate h t;; translate h (k x))). - rewrite unfold_translate. - rewrite !unfold_bind. - rewrite unfold_translate. - unfold translateF. - unfold ITree.bind_match. - destruct (observe t); cbn. - - rewrite unfold_translate. unfold translateF. + rewrite !unfold_translate, !unfold_bind. + genobs_clear t ot. destruct ot; cbn. + - rewrite unfold_translate. pupto2_final. apply Reflexive_eq_itree. - pfold. econstructor. pupto2_final. right. apply CIH. - - pfold. econstructor. intros. pupto2_final. right. apply CIH. + - pfold. econstructor. intros. pupto2_final. right. apply CIH. Qed. (* categorical properties --------------------------------------------------- *) @@ -133,12 +139,9 @@ Proof. revert t. pcofix CIH. intros t. - rewrite itree_eta. - rewrite (itree_eta (translate g (translate f t))). - repeat rewrite unfold_translate. - unfold translateF. - destruct (observe t); cbn. - - pupto2_final. apply Reflexive_eq_itree. + rewrite !unfold_translate. + genobs_clear t ot. destruct ot; cbn. + - pupto2_final. apply reflexivity. - pfold. econstructor. pupto2_final. right. apply CIH. - pfold. econstructor. intros. pupto2_final. right. apply CIH. Qed. From eebc50af10c69054e21f8b3ca710df217b81c969 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 28 Feb 2019 13:06:35 -0500 Subject: [PATCH 126/142] Change of notation for eqden --- examples/AsmCombinators.v | 18 ++++---- examples/Den.v | 85 ++++++++++++++++++----------------- examples/Imp.v | 14 +++--- examples/Imp2AsmCorrectness.v | 6 +-- 4 files changed, 62 insertions(+), 61 deletions(-) diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index 24b79df6..aabad673 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -186,7 +186,7 @@ Proof. Qed. Lemma raw_asm_block_correct_lifted {A} (b : block A) : - denote_asm (raw_asm_block b) ⩰ + denote_asm (raw_asm_block b) ⩯ (fun _ => denote_block b). Proof. unfold denote_asm. @@ -230,7 +230,7 @@ Defined. Lemma tensor_den_slide_right {A B C D}: forall (ac: @den E A C) (bd: den B D), - ac ⊗ bd ⩰ id_den ⊗ bd >=> ac ⊗ id_den. + ac ⊗ bd ⩯ id_den ⊗ bd >=> ac ⊗ id_den. Proof. intros. unfold tensor_den. @@ -242,7 +242,7 @@ Proof. Qed. Lemma local_rewrite1 {A B C: Type}: - id_den ⊗ sym_den >=> assoc_den_l >=> sym_den ⩰ + id_den ⊗ sym_den >=> assoc_den_l >=> sym_den ⩯ @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. Proof. unfold id_den, tensor_den,sym_den, assoc_den_l, ITree.cat, assoc_den_r, lift_den. @@ -251,7 +251,7 @@ Proof. Qed. Lemma local_rewrite2 {A B C: Type}: - sym_den >=> assoc_den_r >=> id_den ⊗ sym_den ⩰ + sym_den >=> assoc_den_r >=> id_den ⊗ sym_den ⩯ @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. Proof. unfold id_den, tensor_den,sym_den, assoc_den_l, ITree.cat, assoc_den_r, lift_den. @@ -261,7 +261,7 @@ Qed. Lemma loop_tensor_den {I A B C D} (ab : @den E A B) (cd : @den E (I + C) (I + D)) : - ab ⊗ loop_den cd ⩰ + ab ⊗ loop_den cd ⩯ loop_den (assoc_den_l >=> sym_den ⊗ id_den >=> assoc_den_r >=> ab ⊗ cd >=> assoc_den_l >=> sym_den ⊗ id_den >=> assoc_den_r). @@ -284,7 +284,7 @@ Lemma foo {A B C: Type}: denote_b (fun a => match a with | inl x => f x | inr x => g x - end) ⩰ + end) ⩯ fun a => match a with | inl x => denote_block (f x) | inr x => denote_block (g x) @@ -311,7 +311,7 @@ Qed. Lemma foo_assoc_l {A B C D D'} (f : den _ D') : @id_den E A ⊗ @assoc_den_l E B C D >=> (assoc_den_l >=> f) - ⩰ assoc_den_l >=> (assoc_den_l >=> (assoc_den_r ⊗ id_den >=> f)). + ⩯ assoc_den_l >=> (assoc_den_l >=> (assoc_den_r ⊗ id_den >=> f)). Proof. rewrite <- !compose_den_assoc. rewrite <- assoc_coherent_l. @@ -323,7 +323,7 @@ Qed. Lemma foo_assoc_r {A' A B C D} (f : den A' _) : f >=> assoc_den_r >=> @id_den E A ⊗ @assoc_den_r E B C D - ⩰ f >=> assoc_den_l ⊗ id_den >=> assoc_den_r >=> assoc_den_r. + ⩯ f >=> assoc_den_l ⊗ id_den >=> assoc_den_r >=> assoc_den_r. Proof. rewrite (compose_den_assoc _ _ assoc_den_r). rewrite <- assoc_coherent_r. @@ -345,7 +345,7 @@ Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : Proof. unfold denote_asm. - match goal with | |- ?x ⩰ _ => set (lhs := x) end. + match goal with | |- ?x ⩯ _ => set (lhs := x) end. rewrite tensor_den_loop. rewrite loop_tensor_den. rewrite <- compose_loop. diff --git a/examples/Den.v b/examples/Den.v index 1f81e924..5352d23f 100644 --- a/examples/Den.v +++ b/examples/Den.v @@ -46,7 +46,8 @@ Section Den. End Equivalence. - Infix "⩰" := eq_den (at level 70). + + Infix "⩯" := eq_den (at level 70). Section Structure. @@ -119,7 +120,7 @@ Section Den. (** *** [compose_den] is associative *) Lemma compose_den_assoc {A B C D} (ab : den A B) (bc : den B C) (cd : den C D) : - ((ab >=> bc) >=> cd) ⩰ (ab >=> (bc >=> cd)). + ((ab >=> bc) >=> cd) ⩯ (ab >=> (bc >=> cd)). Proof. intros a. unfold ITree.cat. @@ -129,14 +130,14 @@ Section Den. (** *** [id_den] respect identity laws *) Lemma id_den_left {A B}: forall (f: denE A B), - id_den >=> f ⩰ f. + id_den >=> f ⩯ f. Proof. intros f a; unfold ITree.cat, id_den. rewrite itree_eta; rewrite ret_bind. rewrite <- itree_eta; reflexivity. Qed. Lemma id_den_right {A B}: forall (f: denE A B), - f >=> id_den ⩰ f. + f >=> id_den ⩯ f. Proof. intros f a; unfold ITree.cat, id_den. rewrite <- (bind_ret (f a)) at 2. @@ -153,13 +154,13 @@ Section Den. erewrite (H a); reflexivity. Qed. - Lemma lift_den_id {A: Type}: @id_den A ⩰ lift_den id. + Lemma lift_den_id {A: Type}: @id_den A ⩯ lift_den id. Proof. unfold id_den, lift_den; reflexivity. Qed. Fact compose_lift_den {A B C} (ab : A -> B) (bc : B -> C) : - (lift_den ab >=> lift_den bc) ⩰ (lift_den (bc ∘ ab)). + (lift_den ab >=> lift_den bc) ⩯ (lift_den (bc ∘ ab)). Proof. intros a. unfold lift_den, ITree.cat. @@ -168,7 +169,7 @@ Section Den. Qed. Fact compose_lift_den_l {A B C D} (f: A -> B) (g: B -> C) (k: den C D) : - (lift_den f >=> (lift_den g >=> k)) ⩰ (lift_den (g ∘ f) >=> k). + (lift_den f >=> (lift_den g >=> k)) ⩯ (lift_den (g ∘ f) >=> k). Proof. rewrite <- compose_den_assoc. rewrite compose_lift_den. @@ -176,7 +177,7 @@ Section Den. Qed. Fact compose_lift_den_r {A B C D} (f: B -> C) (g: C -> D) (k: den A B) : - ((k >=> lift_den f) >=> lift_den g) ⩰ (k >=> lift_den (g ∘ f)). + ((k >=> lift_den f) >=> lift_den g) ⩯ (k >=> lift_den (g ∘ f)). Proof. rewrite compose_den_assoc. rewrite compose_lift_den. @@ -184,7 +185,7 @@ Section Den. Qed. Fact lift_compose_den {A B C}: forall (f:A -> B) (bc: den B C), - lift_den f >=> bc ⩰ fun a => bc (f a). + lift_den f >=> bc ⩯ fun a => bc (f a). Proof. intros; intro a. unfold lift_den, ITree.cat. @@ -204,7 +205,7 @@ Section Den. (** *** [associators] *) Lemma assoc_lr {A B C} : - @assoc_den_l A B C >=> assoc_den_r ⩰ id_den. + @assoc_den_l A B C >=> assoc_den_r ⩯ id_den. Proof. unfold assoc_den_l, assoc_den_r. rewrite compose_lift_den. @@ -212,7 +213,7 @@ Section Den. Qed. Lemma assoc_rl {A B C} : - @assoc_den_r A B C >=> assoc_den_l ⩰ id_den. + @assoc_den_r A B C >=> assoc_den_l ⩯ id_den. Proof. unfold assoc_den_l, assoc_den_r. rewrite compose_lift_den. @@ -222,14 +223,14 @@ Section Den. (** *** [sum_elim] lemmas *) Fact compose_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : - sum_elim ac bc >=> cd ⩰ sum_elim (ac >=> cd) (bc >=> cd). + sum_elim ac bc >=> cd ⩯ sum_elim (ac >=> cd) (bc >=> cd). Proof. intros; intros []; (unfold ITree.map; simpl; apply eutt_bind; reflexivity). Qed. Fact lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : - sum_elim (lift_den ac) (lift_den bc) ⩰ lift_den (sum_elim ac bc). + sum_elim (lift_den ac) (lift_den bc) ⩯ lift_den (sum_elim ac bc). Proof. intros []; reflexivity. Qed. @@ -237,14 +238,14 @@ Section Den. (** *** [Unitors] lemmas *) Lemma elim_λ_den {A B: Type}: - forall (ab: @den E A (I + B)), ab >=> λ_den ⩰ (fun a: A => ITree.map sum_empty_l (ab a)). + forall (ab: @den E A (I + B)), ab >=> λ_den ⩯ (fun a: A => ITree.map sum_empty_l (ab a)). Proof. intros; apply compose_den_lift. Qed. Lemma elim_λ_den' {A B: Type}: forall (f: @den E (I + A) (I + B)), - λ_den' >=> f ⩰ fun a => f (inr a). + λ_den' >=> f ⩯ fun a => f (inr a). Proof. repeat intro. unfold λ_den', ITree.cat, lift_den. @@ -253,7 +254,7 @@ Section Den. Lemma elim_ρ_den' {A B: Type}: forall (f: @den E (A + I) (B + I)), - ρ_den' >=> f ⩰ fun a => f (inl a). + ρ_den' >=> f ⩯ fun a => f (inl a). Proof. repeat intro. unfold ρ_den', ITree.cat, lift_den. @@ -261,7 +262,7 @@ Section Den. Qed. Lemma elim_ρ_den {A B: Type}: - forall (ab: @den E A (B + I)), ab >=> ρ_den ⩰ (fun a: A => ITree.map sum_empty_r (ab a)). + forall (ab: @den E A (B + I)), ab >=> ρ_den ⩯ (fun a: A => ITree.map sum_empty_r (ab a)). Proof. intros; apply compose_den_lift. Qed. @@ -277,7 +278,7 @@ Section Den. Qed. Fact tensor_id_lift {A B C} (f : B -> C) : - (@id_den A) ⊗ (lift_den f) ⩰ lift_den (sum_bimap id f). + (@id_den A) ⊗ (lift_den f) ⩯ lift_den (sum_bimap id f). Proof. unfold tensor_den. rewrite compose_lift_den, id_den_left. @@ -286,7 +287,7 @@ Section Den. Qed. Fact tensor_lift_id {A B C} (f : A -> B) : - (lift_den f) ⊗ (@id_den C) ⩰ lift_den (sum_bimap f id). + (lift_den f) ⊗ (@id_den C) ⩯ lift_den (sum_bimap f id). Proof. unfold tensor_den. rewrite compose_lift_den, id_den_left. @@ -295,14 +296,14 @@ Section Den. Qed. Lemma tensor_id {A B} : - id_den ⊗ id_den ⩰ @id_den (A + B). + id_den ⊗ id_den ⩯ @id_den (A + B). Proof. unfold tensor_den, ITree.cat, id_den. intros []; cbn; rewrite ret_bind_; reflexivity. Qed. Lemma assoc_I {A B}: - @assoc_den_r A I B >=> id_den ⊗ λ_den ⩰ ρ_den ⊗ id_den. + @assoc_den_r A I B >=> id_den ⊗ λ_den ⩯ ρ_den ⊗ id_den. Proof. unfold ρ_den,λ_den. rewrite tensor_lift_id, tensor_id_lift. @@ -316,7 +317,7 @@ Section Den. Lemma cat_tensor {A1 A2 A3 B1 B2 B3} (f1 : @den E A1 A2) (f2 : den A2 A3) (g1 : den B1 B2) (g2 : den B2 B3) : - (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩰ (f1 >=> f2) ⊗ (g1 >=> g2). + (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩯ (f1 >=> f2) ⊗ (g1 >=> g2). Proof. unfold tensor_den, ITree.cat, lift_den; simpl. intros []; simpl; @@ -325,7 +326,7 @@ Section Den. Lemma sum_elim_compose {A B C D F}: forall (ac: denE A (C + D)) (bc: denE B (C + D)) (cf: denE C F) (df: denE D F), - sum_elim ac bc >=> sum_elim cf df ⩰ + sum_elim ac bc >=> sum_elim cf df ⩯ sum_elim (ac >=> (sum_elim cf df)) (bc >=> (sum_elim cf df)). Proof. intros. @@ -335,7 +336,7 @@ Section Den. Lemma inl_sum_elim {A B C}: forall (ac: denE A C) (bc: denE B C), - lift_den inl >=> sum_elim ac bc ⩰ ac. + lift_den inl >=> sum_elim ac bc ⩯ ac. Proof. intros. unfold ITree.cat, lift_den. @@ -346,7 +347,7 @@ Section Den. Lemma inr_sum_elim {A B C}: forall (ac: denE A C) (bc: denE B C), - lift_den inr >=> sum_elim ac bc ⩰ bc. + lift_den inr >=> sum_elim ac bc ⩯ bc. Proof. intros. unfold ITree.cat, lift_den. @@ -357,7 +358,7 @@ Section Den. Lemma tensor_den_slide {A B C D}: forall (ac: @den E A C) (bd: den B D), - ac ⊗ bd ⩰ ac ⊗ id_den >=> id_den ⊗ bd. + ac ⊗ bd ⩯ ac ⊗ id_den >=> id_den ⊗ bd. Proof. intros. unfold tensor_den. @@ -369,7 +370,7 @@ Section Den. Qed. Lemma assoc_coherent_r {A B C D}: - @assoc_den_r A B C ⊗ @id_den D >=> assoc_den_r >=> id_den ⊗ assoc_den_r ⩰ + @assoc_den_r A B C ⊗ @id_den D >=> assoc_den_r >=> id_den ⊗ assoc_den_r ⩯ assoc_den_r >=> assoc_den_r. Proof. unfold tensor_den, assoc_den_r. @@ -384,7 +385,7 @@ Section Den. Qed. Lemma assoc_coherent_l {A B C D}: - @id_den A ⊗ @assoc_den_l B C D >=> assoc_den_l >=> assoc_den_l ⊗ id_den ⩰ + @id_den A ⊗ @assoc_den_l B C D >=> assoc_den_l >=> assoc_den_l ⊗ id_den ⩯ assoc_den_l >=> assoc_den_l. Proof. unfold tensor_den, assoc_den_l. @@ -401,7 +402,7 @@ Section Den. (** *** [sym] lemmas *) Lemma sym_unit_den {A} : - sym_den >=> λ_den ⩰ @ρ_den A. + sym_den >=> λ_den ⩯ @ρ_den A. Proof. unfold sym_den, ρ_den, λ_den. rewrite lift_compose_den. @@ -409,7 +410,7 @@ Section Den. Qed. Lemma sym_assoc_den {A B C}: - @assoc_den_r A B C >=> sym_den >=> assoc_den_r ⩰ + @assoc_den_r A B C >=> sym_den >=> assoc_den_r ⩯ (sym_den ⊗ id_den) >=> assoc_den_r >=> (id_den ⊗ sym_den). Proof. unfold assoc_den_r, sym_den. @@ -420,7 +421,7 @@ Section Den. Qed. Lemma sym_nilpotent {A B: Type}: - sym_den >=> sym_den ⩰ @id_den (A + B). + sym_den >=> sym_den ⩯ @id_den (A + B). Proof. unfold sym_den, id_den. rewrite compose_lift_den. @@ -430,7 +431,7 @@ Section Den. Qed. Lemma tensor_swap {A B C D} (ab : den A B) (cd : den C D) : - ab ⊗ cd ⩰ (sym_den >=> cd ⊗ ab >=> sym_den). + ab ⊗ cd ⩯ (sym_den >=> cd ⊗ ab >=> sym_den). Proof. unfold tensor_den. unfold sym_den. @@ -481,7 +482,7 @@ A----B----###----C Lemma compose_loop {I A B C}: forall (bc_: denE (I + B) (I + C)) (ab: denE A B), - loop_den ((id_den ⊗ ab) >=> bc_) ⩰ + loop_den ((id_den ⊗ ab) >=> bc_) ⩯ ab >=> loop_den bc_. Proof. intros bc_ ab a. @@ -516,7 +517,7 @@ A----###----B----C Lemma loop_compose {I A B B'}: forall (ab_: denE (I + A) (I + B)) (bc: denE B B'), - loop_den (ab_ >=> (id_den ⊗ bc)) ⩰ + loop_den (ab_ >=> (id_den ⊗ bc)) ⩯ loop_den ab_ >=> bc. intros bc_ ab a. rewrite (loop_natural_r ab bc_ a). @@ -535,7 +536,7 @@ A----###----B----C Lemma loop_rename_internal {I J A B}: forall (ab_: denE (I + A) (J + B)) (ji: denE J I), - loop_den (ab_ >=> (ji ⊗ id_den)) ⩰ + loop_den (ab_ >=> (ji ⊗ id_den)) ⩯ loop_den ((ji ⊗ id_den) >=> ab_). Proof. intros; unfold loop_den. @@ -578,7 +579,7 @@ A----###----B----C (* Loop over the empty set can be erased *) Lemma vanishing_den {A B: Type}: forall (f: denE (I + A) (I + B)), - loop_den f ⩰ λ_den' >=> f >=> λ_den. + loop_den f ⩯ λ_den' >=> f >=> λ_den. Proof. intros f a. unfold loop_den. @@ -620,7 +621,7 @@ These two loops: Lemma loop_loop {I J A B}: forall (ab__: denE (I + (J + A)) (I + (J + B))), - loop_den (loop_den ab__) ⩰ + loop_den (loop_den ab__) ⩯ loop_den (assoc_den_r >=> ab__ >=> assoc_den_l). Proof. intros ab_ a; unfold loop_den. @@ -641,7 +642,7 @@ These two loops: Lemma tensor_den_loop {I A B C D} (ab : denE (I + A) (I + B)) (cd : denE C D) : - (loop_den ab) ⊗ cd ⩰ + (loop_den ab) ⊗ cd ⩯ loop_den (assoc_den_l >=> (ab ⊗ cd) >=> assoc_den_r). Proof. unfold loop_den, tensor_den, ITree.cat, assoc_den_l, assoc_den_r, lift_den, sum_elim. @@ -659,7 +660,7 @@ These two loops: Qed. Lemma yanking_den {A: Type}: - loop_den sym_den ⩰ @id_den A. + loop_den sym_den ⩯ @id_den A. Proof. unfold loop_den, sym_den, lift_den. intros ?; rewrite yanking. @@ -668,8 +669,8 @@ These two loops: Lemma loop_rename_internal' {I J A B} (ij : den I J) (ji: den J I) (ab_: @den E (I + A) (I + B)) : - (ij >=> ji) ⩰ id_den -> - loop_den ((ji ⊗ id_den) >=> ab_ >=> (ij ⊗ id_den)) ⩰ + (ij >=> ji) ⩯ id_den -> + loop_den ((ji ⊗ id_den) >=> ab_ >=> (ij ⊗ id_den)) ⩯ loop_den ab_. Proof. intros Hij. @@ -687,7 +688,7 @@ These two loops: End Den. Bind Scope den_scope with den. -Infix "⩰" := eq_den (at level 70). +Infix "⩯" := eq_den (at level 70). Infix "⊗" := (tensor_den) (at level 30). Hint Rewrite @compose_den_assoc : lift_den. diff --git a/examples/Imp.v b/examples/Imp.v index 29a20c27..9a8932c0 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -95,13 +95,13 @@ Section Denote. end. Definition while {eff} (t : itree eff bool) : itree eff unit := - @loop eff unit unit unit - (fun l : unit + unit => - match l with - | inr _ => ret (inl tt) - | inl _ => continue <- t ;; - if continue : bool then ret (inl tt) else ret (inr tt) - end) tt. + loop + (fun l : unit + unit => + match l with + | inr _ => ret (inl tt) + | inl _ => continue <- t ;; + if continue : bool then ret (inl tt) else ret (inr tt) + end) tt. (* the meaning of a statement *) Fixpoint denoteStmt (s : stmt) : itree eff unit := diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 1b240d42..2a89d0d9 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -77,7 +77,7 @@ Section EUTT. End EUTT. Section GEN_TMP. - + Lemma to_string_inj: forall (n m: nat), n <> m -> to_string n <> to_string m. Admitted. @@ -504,13 +504,13 @@ Qed. Require Import Den. Lemma sym_den_unfold {E} {A B}: - lift_den sum_comm ⩰ @sym_den E A B. + lift_den sum_comm ⩯ @sym_den E A B. Proof. reflexivity. Qed. Lemma seq_linking_den {E} {A B C} (ab : @den E A B) (bc : den B C) : - loop_den (sym_den >=> ab ⊗ bc) ⩰ ab >=> bc. + loop_den (sym_den >=> ab ⊗ bc) ⩯ ab >=> bc. Proof. rewrite tensor_den_slide. rewrite <- compose_den_assoc. From bc2fa964dc9094e53d46b7ae55783e1e5c42bdef Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 28 Feb 2019 13:42:02 -0500 Subject: [PATCH 127/142] Regeneralize interp1 proofs --- examples/Imp2AsmCorrectness.v | 2 +- theories/MorphismsFacts.v | 60 ++++++++++++++++++++++------------- 2 files changed, 39 insertions(+), 23 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 1b240d42..6c1f3e1c 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -115,7 +115,7 @@ Section Real_correctness. repeat intro. unfold interp_locals. unfold run_env. - rewrite H0. rewrite H. + rewrite H0. eapply eutt_interp_state. rewrite H. reflexivity. Qed. diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 4a8d3a61..42975ebe 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -649,26 +649,30 @@ Proof. rewrite itree_eta, unfold_interp1, <-itree_eta. reflexivity. Qed. (** ** [interp1] is equivalent to [interp] *) -Definition interp_match {E F} (f: E ~> itree F) : (E +' F) ~> itree F := - fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis e (fun r => Ret r) end. +Section interp1_is_interp. -Inductive interp_inv {E F R} (f: E ~> itree F) : relation (itree' F R) := +Context {E F G : Type -> Type} `{F -< G} (f : E ~> itree G). + +Definition interp_match : (E +' F) ~> itree G := + fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis (subeffect _ e) (fun r => Ret r) end. + +Inductive interp_inv {R} : relation (itree' G R) := | _interp_inv_main t: - interp_inv f - (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)) + interp_inv + (observe (interp interp_match _ t)) (observe (interp1 f _ t)) | _interp_inv_bind u t (k: u -> _): - interp_inv f - (observe (ITree.bind t (fun x => interp (interp_match f) _ (k x)))) + interp_inv + (observe (ITree.bind t (fun x => interp interp_match _ (k x)))) (observe (ITree.bind t (fun x => interp1 f _ (k x)))) . Hint Constructors interp_inv. -Lemma interp_inv_main_step E F R (f: E ~> itree F) (t: itree _ R) : - euttF eq (fun x y => interp_inv f (observe x) (observe y)) (interp_inv f) - (observe (interp (interp_match f) _ t)) (observe (interp1 f _ t)). +Lemma interp_inv_main_step R (t: itree _ R) : + euttF eq (fun x y => interp_inv (observe x) (observe y)) interp_inv + (observe (interp interp_match _ t)) (observe (interp1 f _ t)). Proof. rewrite unfold_interp, unfold_interp1. - genobs_clear t ot. + genobs t ot. clear Heqot t. destruct ot; simpl; eauto. destruct e; simpl; eauto. econstructor. rewrite unfold_bind. @@ -676,14 +680,14 @@ Proof. fold_bind. rewrite unfold_bind. simpl. eauto. Qed. -Lemma interp_is_interp1 E F R (f: E ~> itree F) (t: itree _ R) : - interp (interp_match f) _ t ≈ interp1 f _ t. +Lemma interp_is_interp1 R (t : itree _ R) : + interp interp_match _ t ≈ interp1 f _ t. Proof. revert t. - cut (forall (t1 t2: itree _ R) (REL: interp_inv f (observe t1) (observe t2)), t1 ≈ t2). + cut (forall (t1 t2: itree _ R) (REL: interp_inv (observe t1) (observe t2)), t1 ≈ t2). { eauto. } - intros. revert_until f. pcofix CIH. intros. + intros. revert_until R. pcofix CIH. intros. pfold. revert_until CIH. pcofix CIH'. intros. destruct REL. - pfold. eapply euttF_mon; eauto using interp_inv_main_step; intros. @@ -697,26 +701,38 @@ Proof. eapply (CIH' (go x2) (go x3)); eauto. Qed. -Instance eq_itree_interp1 {E F R} (h : E ~> itree F) : - Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +End interp1_is_interp. + +Lemma eq_itree_interp1_ {E F R} (h1 h2 : E ~> itree F) : + (forall T (e : E T), h1 _ e ≅ h2 _ e) -> + forall t1 t2 : itree (E +' F) R, + t1 ≅ t2 -> interp1 h1 _ t1 ≅ interp1 h2 _ t2. Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. rewrite !unfold_interp1_. - punfold H0; red in H0. - destruct H0; pclearbot. + punfold H1; red in H1. + destruct H1; pclearbot. - pupto2_final. pfold. red. cbn. eauto. - pupto2_final. pfold. red. cbn. eauto. - pfold. destruct e; cbn; econstructor. + pupto2 (eq_itree_clo_bind F R). econstructor. - * reflexivity. + * eauto. * intros; subst. pupto2_final; eauto. + intros. pupto2_final. eauto. Qed. -Instance eutt_interp1 {E F: Type -> Type} (h: E ~> itree F) R: - Proper (eutt eq ==> eutt eq) (@interp1 E F F _ h R). +Instance eq_itree_interp1 {E F G} `{F -< G} {R} (h : E ~> itree F) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). +Proof. + repeat intro. + eapply eq_itree_interp1_; auto. + reflexivity. +Qed. + +Instance eutt_interp1 {E F G: Type -> Type} `{F -< G} (h: E ~> itree G) R: + Proper (eutt eq ==> eutt eq) (@interp1 E F G _ h R). Proof. repeat intro. rewrite <- 2 interp_is_interp1. From 189cab81cd1825ff000160da9fe47d834486ac69 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 28 Feb 2019 13:49:55 -0500 Subject: [PATCH 128/142] Fix eutt_bind_gen --- theories/Eq/SimUpToTaus.v | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index 003e776d..51cf9213 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -472,16 +472,17 @@ Qed. (** Generalized heterogeneous version of [eutt_bind] *) Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: forall t1 t2, - euttE RR t1 t2 -> - forall s1 s2, (forall r1 r2, RR r1 r2 -> euttE SS (s1 r1) (s2 r2)) -> + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). Proof. - intros. apply euttE_impl_eutt in H. setoid_rewrite <-eutt_is_euttE in H0. + intros. apply sutt_eutt; eapply sutt_bind_gen. - apply eutt_sutt. eassumption. - intros. apply eutt_sutt. apply H0; auto. - apply eutt_sutt. eapply Symmetric_eutt_; try eassumption; auto. intros ? ? HH; apply HH. - - simpl. intros. apply eutt_sutt. eapply Symmetric_eutt_; eauto; auto. + - simpl. intros. apply eutt_sutt. + eapply Symmetric_eutt_; try eapply H0; eauto. Qed. From 309640bb22bd671664e0ed992f610de46788beab Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 28 Feb 2019 13:50:22 -0500 Subject: [PATCH 129/142] Rename eutt_Ret -> eutt_ret in examples/Imp2AsmCorrectness --- examples/Imp2AsmCorrectness.v | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 6c1f3e1c..fbfa6e96 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -115,7 +115,7 @@ Section Real_correctness. repeat intro. unfold interp_locals. unfold run_env. - rewrite H0. eapply eutt_interp_state. rewrite H. + rewrite H0. eapply eutt_interp_state; auto. rewrite H. reflexivity. Qed. @@ -410,13 +410,13 @@ Qed. - repeat untau_left. repeat untau_right. force_left; force_right. - apply eutt_Ret. + apply eutt_ret. erewrite <- Renv_find; [| eassumption]. apply sim_rel_add; assumption. - repeat untau_left. force_left. force_right. - apply eutt_Ret. + apply eutt_ret. apply sim_rel_add; assumption. - do 2 setoid_rewrite denote_list_app. do 2 setoid_rewrite interp_locals_bind. @@ -430,7 +430,7 @@ Qed. repeat untau_left. force_left; force_right. simpl fst in *. - apply eutt_Ret. + apply eutt_ret. { generalize HSIM; intros LU; apply sim_rel_find_tmp_n in LU. unfold alist_In in LU; erewrite sim_rel_find_tmp_lt_n in LU; eauto; fold (alist_In (%n) g_asm'' v) in LU. @@ -493,7 +493,7 @@ Qed. repeat untau_left. force_left. repeat untau_right; force_right. - eapply eutt_Ret; simpl. + eapply eutt_ret; simpl. destruct r1, r2. erewrite sim_rel_find_tmp_n; eauto; simpl. destruct H0. @@ -658,7 +658,7 @@ Proof. intros [] [] []. simpl. repeat intro. rewrite itree_eta, (itree_eta (_ _ g2)); cbn. - apply eutt_Ret; auto. + apply eutt_ret; auto. - (* Seq *) rewrite fold_to_itree; simpl. @@ -696,7 +696,7 @@ Proof. intros [[]|[]]. 2:{ repeat intro. rewrite itree_eta, (itree_eta (_ _ g2)); cbn. - apply eutt_Ret; auto. } + apply eutt_ret; auto. } unfold ITree.map. rewrite bind_bind. repeat intro. @@ -715,20 +715,20 @@ Proof. apply sim_rel_Renv in H0. destruct v; simpl; auto. + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. - apply eutt_Ret. auto. + apply eutt_ret. auto. + rewrite 2 interp_locals_bind, bind_bind. eapply eutt_bind_gen. { eapply IHs; auto. } intros. rewrite itree_eta, (itree_eta (_ >>= _)); cbn. - apply eutt_Ret. destruct H1; auto. + apply eutt_ret. destruct H1; auto. - (* Skip *) repeat intro. rewrite (itree_eta (_ (denote_asm _ _) _)), (itree_eta (_ (denoteStmt _) _)); cbn. - apply eutt_Ret; auto. + apply eutt_ret; auto. Qed. From 161a967dfa72d59f37ef5beb96d9556e42eb671c Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 28 Feb 2019 17:04:19 -0500 Subject: [PATCH 130/142] Removed obsolete file --- examples/Linking.v | 42 ------------------------------------------ 1 file changed, 42 deletions(-) delete mode 100644 examples/Linking.v diff --git a/examples/Linking.v b/examples/Linking.v deleted file mode 100644 index 39678871..00000000 --- a/examples/Linking.v +++ /dev/null @@ -1,42 +0,0 @@ -From Coq Require Import - Program - Lia - Setoid - Morphisms - RelationClasses. - -From ITree Require Import - ITree - FixFacts - Basics_Functions. - -Require Import Program.Basics. (* ∘ *) - -Require Import Den. - -Section Linking. - - Variable E : Type -> Type. - - Definition link_seq_den {A B C} - (ab: @den E A B) - (bc: den B C): den A C := - loop_den (sym_den >=> ab ⊗ bc). - - Theorem seq_correct {A B C} (ab : den A B) (bc : den B C) : - (link_seq_den ab bc) ⩰ ab >=> bc. - Proof. - unfold link_seq_den. - rewrite tensor_den_slide. - rewrite <- compose_den_assoc. - rewrite loop_compose. - rewrite tensor_swap. - repeat rewrite <- compose_den_assoc. - rewrite sym_nilpotent, id_den_left. - rewrite compose_loop. - erewrite yanking_den. - rewrite id_den_right. - reflexivity. - Qed. - -End Linking. From f1f4cd51da9671b354998c3ccfb814b7b6521f65 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 28 Feb 2019 17:05:47 -0500 Subject: [PATCH 131/142] Nits --- examples/Imp.v | 17 ----------------- examples/Imp2AsmCorrectness.v | 4 +--- 2 files changed, 1 insertion(+), 20 deletions(-) diff --git a/examples/Imp.v b/examples/Imp.v index 9a8932c0..315a6262 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -124,18 +124,6 @@ Section Denote. End Denote. - (* some simple examples *) - Definition ex1: stmt := - "x" ← 1 ;;; - "y" ← "x". - Eval simpl in denoteStmt ex1. - - Definition ex2: stmt := - "x" ← 1 ;;; - WHILE "x" DO - "x" ← "x". - Eval simpl in denoteStmt ex2. - From ITree Require Import Effect.Env. @@ -144,11 +132,6 @@ From ExtLib Require Import Structures.Maps Data.Map.FMapAList. -(* - Note: this is the simple Imp semantics, compared to the C-like semantics: interpretations in term of total maps instead of partial ones. - Make it simpler to map to asm for now. - *) - Definition evalLocals {E: Type -> Type} `{envE var value -< E}: Locals ~> itree E := fun _ e => match e with diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 35f05e45..7b04333a 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -1,4 +1,4 @@ -Require Import Imp Asm AsmCombinators Imp2Asm. +Require Import Imp Asm AsmCombinators Den Imp2Asm. Require Import Psatz. @@ -501,8 +501,6 @@ Qed. eapply Renv_write_local; eauto. Qed. - Require Import Den. - Lemma sym_den_unfold {E} {A B}: lift_den sum_comm ⩯ @sym_den E A B. Proof. From d1ee49006223ab0e84a664c1c1c3ef40c334111a Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 28 Feb 2019 17:16:17 -0500 Subject: [PATCH 132/142] Unary representation of nats to remove the admit --- examples/Imp2Asm.v | 11 ++++++++++- examples/Imp2AsmCorrectness.v | 15 +++++++++++---- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 6acd514a..49847b4a 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -4,8 +4,11 @@ Require Import Psatz. From Coq Require Import Strings.String + Strings.OctalString Morphisms Setoid + Decimal + Numbers.DecimalString RelationClasses. From ITree Require Import @@ -25,8 +28,14 @@ Open Scope string_scope. Section compile_assign. + Fixpoint nat_to_string (n: nat): string := + match n with + | O => "" + | S n => String (ascii_of_nat 49) (nat_to_string n) + end. + Definition gen_tmp (n: nat): string := - "temp_" ++ to_string n. + "temp_" ++ nat_to_string n. Definition varOf (s : var) : var := "local_" ++ s. diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 7b04333a..4da22fee 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -77,14 +77,21 @@ Section EUTT. End EUTT. Section GEN_TMP. - - Lemma to_string_inj: forall (n m: nat), n <> m -> to_string n <> to_string m. - Admitted. + + Lemma nat_to_string_inj: + forall (n m: nat), n <> m -> nat_to_string n <> nat_to_string m. + Proof. + induction n as [| n IH]; simpl; intros m ineq. + - destruct m as [| m]; [lia | intros abs; inversion abs]. + - destruct m as [| m]; [intros abs; inversion abs |]. + simpl; intros abs; inversion abs; subst; clear abs. + apply (IH m); auto. + Qed. Lemma gen_tmp_inj: forall n m, m <> n -> gen_tmp m <> gen_tmp n. Proof. intros n m ineq; intros abs; apply ineq. - apply to_string_inj in ineq; inversion abs; easy. + apply nat_to_string_inj in ineq; inversion abs; easy. Qed. Lemma varOf_inj: forall n m, m <> n -> varOf m <> varOf n. From fc26ed7cd55ba2eff06a4be6ef13ba80633d9123 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 28 Feb 2019 17:33:24 -0500 Subject: [PATCH 133/142] Bit of claenup --- examples/Imp2AsmCorrectness.v | 715 +++++++++++++++------------------- 1 file changed, 308 insertions(+), 407 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 4da22fee..92e3300b 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -26,9 +26,7 @@ From ExtLib Require Import Import ListNotations. Open Scope string_scope. -Section Correctness. - - (* +(* Potential extensions for later: - Add some non-determinism at the source level, for instance order of evaluation in add, and have the compiler an order. The correctness would then be a refinement. @@ -36,32 +34,17 @@ Section Correctness. - Add a print effect? - Change languages to map two notions of state at the source down to a single one at the target? Make the keys of the second env monad as the sum of the two initial ones. - *) - - Variable E: Type -> Type. - Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. - - Variant Rvar : var -> var -> Prop := - | Rvar_var v : Rvar (varOf v) v. - - Arguments alist_find {_ _ _ _}. - - Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. - - Definition Renv (g_asm g_imp : alist var value) : Prop := - forall k_asm k_imp, Rvar k_asm k_imp -> - forall v, alist_In k_imp g_imp v <-> alist_In k_asm g_asm v. - - (* Let's not unfold this inside of the main proof *) - Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := - fun '(g_asm', _) '(g_imp',v) => - Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) - alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) - (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) - alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). - -End Correctness. + things to do? + * 1. change the compiler to not compress basic blocks. + * - ideally we would write a separate pass that does that + * - split out each of the structures as separate definitions and lemmas + * 2. need to prove `interp F (denote_block ...) = denote_block ...` + * 3. link_seq_ok should be a proof by co-induction. + * 4. clean up this file *a lot* + * bonus: block fusion + * bonus: break & continue + *) Section EUTT. @@ -104,133 +87,49 @@ End GEN_TMP. Opaque gen_tmp. Opaque varOf. -Section Real_correctness. +Ltac flatten_goal := + match goal with + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. - Context {E': Type -> Type}. - Context {HasMemory: Memory -< E'}. - Context {HasExit: Exit -< E'}. - Definition E := Locals +' E'. +Ltac flatten_hyp h := + match type of h with + | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. - Definition interp_locals {R: Type} (t: itree E R) (s: alist var value) - : itree E' (alist var value * R) := - run_env _ (interp1 evalLocals _ t) s. +Ltac flatten_all := + match goal with + | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq + | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq + end. - Instance eutt_interp_locals {R}: - Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) - interp_locals. - Proof. - repeat intro. - unfold interp_locals. - unfold run_env. - rewrite H0. eapply eutt_interp_state; auto. rewrite H. - reflexivity. - Qed. +Ltac inv h := inversion h; subst; clear h. - Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), - @eutt E' _ _ eq - (interp_locals (ITree.bind t k) s) - (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). - Proof. - intros. - unfold interp_locals. - unfold run_env. - rewrite interp1_bind. - rewrite interp_state_bind. - reflexivity. - Qed. +Section alistFacts. -Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) - (Renv_ : _ -> _ -> Prop) - t1 t2 := - forall g1 g2, - Renv_ g1 g2 -> - eutt (fun a (b : alist var value * R2) => Renv_ (fst a) (fst b) /\ RR (snd a) (snd b)) - (interp_locals t1 g1) - (interp_locals t2 g2). - -Instance eutt_eq_locals (Renv_ : _ -> _ -> Prop) {R} RR : - Proper (eutt eq ==> eutt eq ==> iff) (@eq_locals R R RR Renv_). -Proof. - repeat intro. - split; repeat intro. - - rewrite <- H, <- H0; auto. - - rewrite H, H0; auto. -Qed. - -Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) - {R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) - (RS : S1 -> S2 -> Prop) : - forall t1 t2, - eq_locals RR Renv_ t1 t2 -> - forall k1 k2, - (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> - eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). -Proof. - repeat intro. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { eapply H; auto. } - intros. eapply H0; destruct H2; auto. -Qed. - -Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : - (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> - eq_locals eq Renv (loop t1 x) (loop t2 x). -Proof. - unfold eq_locals, interp_locals, run_env. - intros. - rewrite 2 interp1_loop. - eapply interp_state_loop; auto. -Qed. - - Set Nested Proofs Allowed. - - Ltac force_left := - match goal with - | |- eutt _ ?x _ => rewrite (itree_eta x); cbn - end. - - Ltac force_right := - match goal with - | |- eutt _ _ ?x => rewrite (itree_eta x); cbn - end. + Arguments alist_find {_ _ _ _}. - Ltac untau_left := force_left; rewrite tau_eutt. - Ltac untau_right := force_right; rewrite tau_eutt. + Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. Arguments alist_add {_ _ _ _}. Arguments alist_find {_ _ _ _}. - - Ltac flatten_goal := - match goal with - | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq - end. - - Ltac flatten_hyp h := - match type of h with - | context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq - end. - - Ltac flatten_all := - match goal with - | h: context[match ?x with | _ => _ end] |- _ => let Heq := fresh "Heq" in destruct x eqn:Heq - | |- context[match ?x with | _ => _ end] => let Heq := fresh "Heq" in destruct x eqn:Heq - end. - - Ltac inv h := inversion h; subst; clear h. Arguments alist_remove {_ _ _ _}. - Lemma In_add_eq {K V: Type} {RR:RelDec eq} {RRC:@RelDec_Correct _ _ RR}: + Context {K V: Type}. + Context {RR : @RelDec K (@eq K)}. + Context {RRC : @RelDec_Correct K (@eq K) RR}. + + Lemma In_add_eq: forall k v (m: alist K V), alist_In k (alist_add k v m) v. Proof. + Set Printing Implicit. intros; unfold alist_add, alist_In; simpl; flatten_goal; [reflexivity | rewrite <- neg_rel_dec_correct in Heq; tauto]. Qed. (* A removed key is not contained in the resulting map *) Lemma not_In_remove: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v: V), + forall (m : alist K V) (k : K) (v: V), ~ alist_In k (alist_remove k m) v. Proof. induction m as [| [k1 v1] m IH]; intros. @@ -245,8 +144,7 @@ Qed. (* Removing a key does not alter other keys *) Lemma In_In_remove_ineq: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v : V) (k' : K), + forall (m : alist K V) (k : K) (v : V) (k' : K), k <> k' -> alist_In k m v -> alist_In k (alist_remove k' m) v. @@ -263,8 +161,7 @@ Qed. Qed. Lemma In_remove_In_ineq: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v : V) (k' : K), + forall (m : alist K V) (k : K) (v : V) (k' : K), alist_In k (alist_remove k' m) v -> alist_In k m v. Proof. @@ -281,8 +178,7 @@ Qed. Qed. Lemma In_remove_In_ineq_iff: - forall (K V : Type) {RR: RelDec eq} {RRC:@RelDec_Correct _ _ RR} - (m : alist K V) (k : K) (v : V) (k' : K), + forall (m : alist K V) (k : K) (v : V) (k' : K), k <> k' -> alist_In k (alist_remove k' m) v <-> alist_In k m v. @@ -291,7 +187,7 @@ Qed. Qed. (* Adding a value to a key does not alter other keys *) - Lemma In_In_add_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: + Lemma In_In_add_ineq: forall k v k' v' (m: alist K V), k <> k' -> alist_In k m v -> @@ -302,7 +198,7 @@ Qed. apply In_In_remove_ineq; auto. Qed. - Lemma In_add_In_ineq {K V: Type} {RR: RelDec eq} `{RRC:@RelDec_Correct _ _ RR}: + Lemma In_add_In_ineq: forall k v k' v' (m: alist K V), k <> k' -> alist_In k (alist_add k' v' m) v -> @@ -313,7 +209,7 @@ Qed. eapply In_remove_In_ineq; eauto. Qed. - Lemma In_add_ineq_iff {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + Lemma In_add_ineq_iff: forall m (v v' : V) (k k' : K), k <> k' -> alist_In k m v <-> alist_In k (alist_add k' v' m) v. @@ -322,7 +218,7 @@ Qed. Qed. (* alist_find fails iff no value is associated to the key in the map *) - Lemma alist_find_None {K V: Type} `{RR: RelDec _ (@eq K)} `{RRC:@RelDec_Correct _ _ RR}: + Lemma alist_find_None: forall k (m: alist K V), (forall v, ~ In (k,v) m) <-> alist_find k m = None. Proof. @@ -335,6 +231,31 @@ Qed. intros [EQ | abs]; [inv EQ; rewrite <- neg_rel_dec_correct in Heq; tauto | apply (H v); assumption]. Qed. +End alistFacts. +Arguments alist_find {_ _ _ _}. +Arguments alist_add {_ _ _ _}. +Arguments alist_find {_ _ _ _}. +Arguments alist_remove {_ _ _ _}. + +Section Simulation_Relation. + + Variable E: Type -> Type. + Context {HasLocals: Locals -< E} {HasMemory: Memory -< E}. + + Variant Rvar : var -> var -> Prop := + | Rvar_var v : Rvar (varOf v) v. + + Definition Renv (g_asm g_imp : alist var value) : Prop := + forall k_asm k_imp, Rvar k_asm k_imp -> + forall v, alist_In k_imp g_imp v <-> alist_In k_asm g_asm v. + + Definition sim_rel g_asm n: alist var value * unit -> alist var value * value -> Prop := + fun '(g_asm', _) '(g_imp',v) => + Renv g_asm' g_imp' /\ (* we don't corrupt any of the imp variables *) + alist_In (gen_tmp n) g_asm' v /\ (* we get the right value *) + (forall m, m < n -> forall v, (* we don't mess with anything on the "stack" *) + alist_In (gen_tmp m) g_asm v <-> alist_In (gen_tmp m) g_asm' v). + Lemma Renv_add: forall g_asm g_imp n v, Renv g_asm g_imp -> Renv (alist_add (gen_tmp n) v g_asm) g_imp. Proof. @@ -405,6 +326,122 @@ Qed. rewrite EQ' in EQ; easy. Qed. + Lemma Renv_write_local: + forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), + Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). + Proof. + intros k m m' v. + repeat intro. + red in H. + specialize (H k_asm k_imp H0 v0). + inv H0. + unfold alist_add, alist_In; simpl. + do 2 flatten_goal; + repeat match goal with + | h: _ = true |- _ => rewrite rel_dec_correct in h + | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h + end; try subst. + - tauto. + - tauto. + - apply varOf_inj in Heq; easy. + - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_string_Correct. + Qed. + +End Simulation_Relation. + +Section Correctness. + + Context {E': Type -> Type}. + Context {HasMemory: Memory -< E'}. + Context {HasExit: Exit -< E'}. + Notation E := (Locals +' E'). + + Definition interp_locals {R: Type} (t: itree E R) (s: alist var value) + : itree E' (alist var value * R) := + run_env _ (interp1 evalLocals _ t) s. + + Instance eutt_interp_locals {R}: + Proper (@eutt E R R eq ==> eq ==> @eutt E' (prod (alist var value) R) (prod _ R) eq) + interp_locals. + Proof. + repeat intro. + unfold interp_locals. + unfold run_env. + rewrite H0. eapply eutt_interp_state; auto. rewrite H. + reflexivity. + Qed. + + Lemma interp_locals_bind: forall {R S} (t: itree E R) (k: R -> itree _ S) (s: alist var value), + @eutt E' _ _ eq + (interp_locals (ITree.bind t k) s) + (ITree.bind (interp_locals t s) (fun s' => interp_locals (k (snd s')) (fst s'))). + Proof. + intros. + unfold interp_locals. + unfold run_env. + rewrite interp1_bind. + rewrite interp_state_bind. + reflexivity. + Qed. + + Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) + (Renv_ : _ -> _ -> Prop) + t1 t2 := + forall g1 g2, + Renv_ g1 g2 -> + eutt (fun a (b : alist var value * R2) => Renv_ (fst a) (fst b) /\ RR (snd a) (snd b)) + (interp_locals t1 g1) + (interp_locals t2 g2). + + Instance eutt_eq_locals (Renv_ : _ -> _ -> Prop) {R} RR : + Proper (eutt eq ==> eutt eq ==> iff) (@eq_locals R R RR Renv_). + Proof. + repeat intro. + split; repeat intro. + - rewrite <- H, <- H0; auto. + - rewrite H, H0; auto. + Qed. + + Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) + {R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) : + forall t1 t2, + eq_locals RR Renv_ t1 t2 -> + forall k1 k2, + (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> + eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). + Proof. + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { eapply H; auto. } + intros. eapply H0; destruct H2; auto. + Qed. + + Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : + (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> + eq_locals eq Renv (loop t1 x) (loop t2 x). + Proof. + unfold eq_locals, interp_locals, run_env. + intros. + rewrite 2 interp1_loop. + eapply interp_state_loop; auto. + Qed. + + Ltac force_left := + match goal with + | |- eutt _ ?x _ => rewrite (itree_eta x); cbn + end. + + Ltac force_right := + match goal with + | |- eutt _ _ ?x => rewrite (itree_eta x); cbn + end. + + Ltac untau_left := force_left; rewrite tau_eutt. + Ltac untau_right := force_right; rewrite tau_eutt. + + Notation "(% x )" := (gen_tmp x) (at level 1). Lemma compile_expr_correct : forall e g_imp g_asm n, @@ -462,33 +499,10 @@ Qed. } Qed. - Lemma Renv_write_local: - forall (x : Imp.var) (a a0 : alist var value) (v : Imp.value), - Renv a a0 -> Renv (alist_add (varOf x) v a) (alist_add x v a0). - Proof. - intros k m m' v. - repeat intro. - red in H. - specialize (H k_asm k_imp H0 v0). - inv H0. - unfold alist_add, alist_In; simpl. - do 2 flatten_goal; - repeat match goal with - | h: _ = true |- _ => rewrite rel_dec_correct in h - | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h - end; try subst. - - tauto. - - tauto. - - apply varOf_inj in Heq; easy. - - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_string_Correct. -Qed. - -(** Correctness of compilation *) - Lemma compile_assign_correct : forall e x, eq_locals eq Renv - (denote_list (compile_assign x e)) - (v <- denoteExpr e ;; lift (SetVar x v)). + (denote_list (compile_assign x e)) + (v <- denoteExpr e ;; lift (SetVar x v)). Proof. red; intros. unfold compile_assign. @@ -540,14 +554,13 @@ Qed. apply seq_linking_den. Qed. - (* YZ: Things get wonky once in the two subgoals. eq_den lemmas cannot be rewritten inside of terms anymore since it's specialized to a specific eutt *) Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : eq_den (denote_asm (if_asm e tp fp)) (fun _ => denote_list e ;; - v <- lift (GetVar tmp_if) ;; - if v : value then denote_asm fp tt else denote_asm tp tt). + v <- lift (GetVar tmp_if) ;; + if v : value then denote_asm fp tt else denote_asm tp tt). Proof. unfold if_asm. rewrite seq_asm_correct. @@ -585,16 +598,16 @@ Qed. eq_den (denote_asm (while_asm e p)) (loop_den (fun l => - match l with - | inl tt => - denote_list e ;; - v <- lift (GetVar tmp_if) ;; - if v : value then - Ret (inr tt) - else - denote_asm p tt;; Ret (inl tt) - | inr tt => Ret (inl tt) - end)). + match l with + | inl tt => + denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then + Ret (inr tt) + else + denote_asm p tt;; Ret (inl tt) + | inr tt => Ret (inl tt) + end)). Proof. unfold while_asm. rewrite link_asm_correct. @@ -621,231 +634,119 @@ Qed. repeat rewrite ret_bind_; reflexivity. - rewrite itree_eta; cbn; reflexivity. Qed. - -Definition env_lookupDefault_is_lift {K V : Type} {E: Type -> Type} `{envE K V -< E} (x: K) (v: V): - env_lookupDefault x v = lift (lookupDefaultE x v). -Proof. - reflexivity. -Qed. - -Lemma sim_rel_get_tmp0: - forall g_asm0 g_asm g_imp v, - sim_rel g_asm0 0 (g_asm,tt) (g_imp,v) -> - interp_locals (lift (GetVar (%0))) g_asm ≈ Ret (g_asm,v). -Proof. - intros. - destruct H as [_ [eq _]]. - unfold interp_locals. - rewrite interp1_liftE. - cbn. - unfold run_env. - rewrite env_lookupDefault_is_lift. - unfold lift; rewrite interp_state_liftE. - cbn. - rewrite eq. - apply tau_eutt. -Qed. - -Lemma compile_correct (s : stmt) : - eq_locals eq Renv - (denote_asm (compile s) tt) - (denoteStmt s). -Proof. - induction s. - - - (* Assign *) - simpl. - rewrite raw_asm_block_correct. - rewrite after_correct. - rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). - eapply eq_locals_bind_gen. - { eapply compile_assign_correct; auto. } - intros [] [] []. simpl. - repeat intro. - rewrite itree_eta, (itree_eta (_ _ g2)); cbn. - apply eutt_ret; auto. - - - (* Seq *) - rewrite fold_to_itree; simpl. - rewrite seq_asm_correct. unfold to_itree. - unfold ITree.cat. - eapply eq_locals_bind_gen. - { eauto. } - intros [] [] []; auto. - - - (* If *) - repeat intro. - rewrite fold_to_itree. simpl. - rewrite if_asm_correct. - unfold to_itree. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { apply compile_expr_correct; auto. } - intros. - destruct r2 as [g_imp' v]; simpl. - rewrite interp_locals_bind. - destruct r1 as [g_asm' []]. - generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. - setoid_rewrite EQ; clear EQ. - rewrite ret_bind_. - simpl. - apply sim_rel_Renv in H0. - destruct v; simpl; auto. - - - (* While *) - simpl; rewrite fold_to_itree. - rewrite while_asm_correct. - rewrite while_is_loop. - unfold to_itree, loop_den. - apply eq_locals_loop. - intros [[]|[]]. - 2:{ repeat intro. - rewrite itree_eta, (itree_eta (_ _ g2)); cbn. - apply eutt_ret; auto. } - unfold ITree.map. rewrite bind_bind. + + Definition env_lookupDefault_is_lift {K V : Type} {E: Type -> Type} `{envE K V -< E} (x: K) (v: V): + env_lookupDefault x v = lift (lookupDefaultE x v). + Proof. + reflexivity. + Qed. - repeat intro. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { apply compile_expr_correct; auto. } + Lemma sim_rel_get_tmp0: + forall g_asm0 g_asm g_imp v, + sim_rel g_asm0 0 (g_asm,tt) (g_imp,v) -> + interp_locals (lift (GetVar (%0))) g_asm ≈ Ret (g_asm,v). + Proof. intros. - destruct r2 as [g_imp' v]; simpl. - rewrite interp_locals_bind. - destruct r1 as [g_asm' []]. - generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. - rewrite interp_locals_bind. - setoid_rewrite EQ; clear EQ. - rewrite ret_bind_. - simpl. - apply sim_rel_Renv in H0. - destruct v; simpl; auto. - + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. - apply eutt_ret. auto. - + rewrite 2 interp_locals_bind, bind_bind. + destruct H as [_ [eq _]]. + unfold interp_locals. + rewrite interp1_liftE. + cbn. + unfold run_env. + rewrite env_lookupDefault_is_lift. + unfold lift; rewrite interp_state_liftE. + cbn. + rewrite eq. + apply tau_eutt. + Qed. + + Lemma compile_correct (s : stmt) : + eq_locals eq Renv + (denote_asm (compile s) tt) + (denoteStmt s). + Proof. + induction s. + + - (* Assign *) + simpl. + rewrite raw_asm_block_correct. + rewrite after_correct. + rewrite <- (bind_ret (ITree.bind (denoteExpr e) _)). + eapply eq_locals_bind_gen. + { eapply compile_assign_correct; auto. } + intros [] [] []. simpl. + repeat intro. + rewrite itree_eta, (itree_eta (_ _ g2)); cbn. + apply eutt_ret; auto. + + - (* Seq *) + rewrite fold_to_itree; simpl. + rewrite seq_asm_correct. unfold to_itree. + unfold ITree.cat. + eapply eq_locals_bind_gen. + { eauto. } + intros [] [] []; auto. + + - (* If *) + repeat intro. + rewrite fold_to_itree. simpl. + rewrite if_asm_correct. + unfold to_itree. + rewrite 2 interp_locals_bind. eapply eutt_bind_gen. - { eapply IHs; auto. } + { apply compile_expr_correct; auto. } intros. - rewrite itree_eta, (itree_eta (_ >>= _)); cbn. - apply eutt_ret. destruct H1; auto. - - - (* Skip *) - repeat intro. - rewrite (itree_eta (_ (denote_asm _ _) _)), - (itree_eta (_ (denoteStmt _) _)); - cbn. - apply eutt_ret; auto. -Qed. - - -(* -Seq a b -a :: itree _ Empty_set -[[Skip]] = Vis Halt ... -[[Seq Skip b]] = Vis Halt ... - - -[[s]] :: itree _ unit -[[a]] :: itree _ L (* if closed *) -*) - - - (* - -OBSOLETE? - -Lemma interp_match_option : forall {T U} (x : option T) {E F} (h : E ~> itree F) (Z : itree _ U) Y, - interp h match x with - | None => Z - | Some y => Y y - end = -match x with -| None => interp h Z -| Some y => interp h (Y y) -end. -Proof. destruct x; reflexivity. Qed. -Lemma interp_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> itree F) (Z : _ -> itree _ U) Y, - interp h match x with - | inl x => Z x - | inr x => Y x - end = -match x with -| inl x => interp h (Z x) -| inr x => interp h (Y x) -end. -Proof. destruct x; reflexivity. Qed. - -Lemma translate_match_sum : forall {A B U} (x : A + B) {E F} (h : E ~> F) (Z : _ -> itree _ U) Y, - translate h match x with - | inl x => Z x - | inr x => Y x - end = -match x with -| inl x => translate h (Z x) -| inr x => translate h (Y x) -end. -Proof. destruct x; reflexivity. Qed. -Lemma translate_match_option : forall {B U} (x : option B) {E F} (h : E ~> F) (Z : itree _ U) Y, - translate h _ match x with - | None => Z - | Some x => Y x - end = -match x with -| None => translate h Z -| Some x => translate h (Y x) -end. -Proof. destruct x; reflexivity. Qed. -*) - - - -(* things to do? - * 1. change the compiler to not compress basic blocks. - * - ideally we would write a separate pass that does that - * - split out each of the structures as separate definitions and lemmas - * 2. need to prove `interp F (denote_block ...) = denote_block ...` - * 3. link_seq_ok should be a proof by co-induction. - * 4. clean up this file *a lot* - * bonus: block fusion - * bonus: break & continue - *) - -Lemma Proper_match : forall {T U V : Type} R (f f' : T -> V) (g g' : U -> V) x, - ((pointwise_relation _ R) f f') -> - ((pointwise_relation _ R) g g') -> - R - match x with - | inl x => f x - | inr x => g x - end - match x with - | inl x => f' x - | inr x => g' x - end. -Proof. destruct x; compute; eauto. Qed. - - -End Real_correctness. - -(* -Section tests. - - Import ImpNotations. - - Definition ex1: stmt := - "x" ← 1. - - (* The result is a bit annoying to read in that it keeps around absurd branches *) - Compute (compile ex1). - - Definition ex_cond: stmt := - "x" ← 1;;; - IF "x" - THEN "res" ← 2 - ELSE "res" ← 3. - - Compute (compile ex_cond). - -End tests. - + destruct r2 as [g_imp' v]; simpl. + rewrite interp_locals_bind. + destruct r1 as [g_asm' []]. + generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. + setoid_rewrite EQ; clear EQ. + rewrite ret_bind_. + simpl. + apply sim_rel_Renv in H0. + destruct v; simpl; auto. + + - (* While *) + simpl; rewrite fold_to_itree. + rewrite while_asm_correct. + rewrite while_is_loop. + unfold to_itree, loop_den. + apply eq_locals_loop. + intros [[]|[]]. + 2:{ repeat intro. + rewrite itree_eta, (itree_eta (_ _ g2)); cbn. + apply eutt_ret; auto. } + unfold ITree.map. rewrite bind_bind. + + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { apply compile_expr_correct; auto. } + intros. + destruct r2 as [g_imp' v]; simpl. + rewrite interp_locals_bind. + destruct r1 as [g_asm' []]. + generalize H0; intros EQ. apply sim_rel_get_tmp0 in EQ. + rewrite interp_locals_bind. + setoid_rewrite EQ; clear EQ. + rewrite ret_bind_. + simpl. + apply sim_rel_Renv in H0. + destruct v; simpl; auto. + + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. + apply eutt_ret. auto. + + rewrite 2 interp_locals_bind, bind_bind. + eapply eutt_bind_gen. + { eapply IHs; auto. } + intros. + rewrite itree_eta, (itree_eta (_ >>= _)); cbn. + apply eutt_ret. destruct H1; auto. + + - (* Skip *) + repeat intro. + rewrite (itree_eta (_ (denote_asm _ _) _)), + (itree_eta (_ (denoteStmt _) _)); + cbn. + apply eutt_ret; auto. + Qed. -*) +End Correctness. From 66c891d458ec07ca415e8d93f81c37e856fc06f1 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 28 Feb 2019 17:34:50 -0500 Subject: [PATCH 134/142] Removed obsolete import --- examples/Imp2Asm.v | 1 - 1 file changed, 1 deletion(-) diff --git a/examples/Imp2Asm.v b/examples/Imp2Asm.v index 49847b4a..14c3496d 100644 --- a/examples/Imp2Asm.v +++ b/examples/Imp2Asm.v @@ -4,7 +4,6 @@ Require Import Psatz. From Coq Require Import Strings.String - Strings.OctalString Morphisms Setoid Decimal From 39ea8639d1e460717ac6106919beb58d6c77531d Mon Sep 17 00:00:00 2001 From: Lysxia Date: Thu, 28 Feb 2019 17:14:29 -0500 Subject: [PATCH 135/142] Move Den to ITree.KTree --- _CoqConfig | 2 + examples/Asm.v | 9 +- examples/AsmCombinators.v | 137 +++--- examples/Den.v | 710 ------------------------------- examples/Imp2AsmCorrectness.v | 79 ++-- examples/_CoqProject | 2 - theories/Eq/Eq.v | 17 + theories/KTree.v | 756 ++++++++++++++++++++++++++++++++++ 8 files changed, 876 insertions(+), 836 deletions(-) delete mode 100644 examples/Den.v create mode 100644 theories/KTree.v diff --git a/_CoqConfig b/_CoqConfig index 3446dcec..76004698 100644 --- a/_CoqConfig +++ b/_CoqConfig @@ -26,6 +26,8 @@ theories/TranslateFacts.v theories/Morphisms.v theories/MorphismsFacts.v +theories/KTree.v + theories/UpTo.v theories/Trace.v theories/MFixITree.v diff --git a/examples/Asm.v b/examples/Asm.v index 4a8e1932..c3d1fceb 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -63,8 +63,7 @@ Arguments internal {A B}. Arguments code {A B}. From ITree Require Import - ITree OpenSum Fix. -Require Import Den. + ITree OpenSum KTree. Section Semantics. @@ -138,7 +137,7 @@ Section Semantics. denote_branch b end. - Definition denote_b : bks A B -> @den E A B := + Definition denote_b : bks A B -> ktree E A B := fun bs a => denote_block (bs a). End with_labels. @@ -149,8 +148,8 @@ Section Semantics. It is therefore denoted as a [den] term *) (* Denotation of [asm] *) - Definition denote_asm {A B} : asm A B -> @den E A B := - fun s => loop_den (denote_b (code s)). + Definition denote_asm {A B} : asm A B -> ktree E A B := + fun s => loop (denote_b (code s)). End with_effect. End Semantics. diff --git a/examples/AsmCombinators.v b/examples/AsmCombinators.v index aabad673..c4626502 100644 --- a/examples/AsmCombinators.v +++ b/examples/AsmCombinators.v @@ -117,8 +117,8 @@ From ExtLib Require Import Structures.Monad. Import MonadNotation. From ITree Require Import - ITree OpenSum Fix. -Require Import Imp Den. + ITree KTree. +Require Import Imp. Section Correctness. @@ -190,8 +190,8 @@ Lemma raw_asm_block_correct_lifted {A} (b : block A) : (fun _ => denote_block b). Proof. unfold denote_asm. - rewrite vanishing_den. - rewrite elim_λ_den', elim_λ_den. + rewrite vanishing_ktree. + rewrite elim_l_ktree', elim_l_ktree. unfold denote_b; simpl. intros []. rewrite fmap_block_map, map_map. @@ -210,12 +210,12 @@ Qed. (** *** [asm] combinators *) Theorem pure_asm_correct {A B} (f : A -> B) : - eq_den (denote_asm (pure_asm f)) - (@lift_den E _ _ f). + denote_asm (pure_asm f) + ⩯ @lift_ktree E _ _ f. Proof. unfold denote_asm . - rewrite vanishing_den. - rewrite elim_λ_den', elim_λ_den. + rewrite vanishing_ktree. + rewrite elim_l_ktree', elim_l_ktree. unfold denote_b; simpl. intros ?. rewrite map_ret. @@ -223,59 +223,60 @@ Proof. Qed. Definition id_asm_correct {A} : - eq_den (denote_asm (pure_asm id)) (@id_den E A). + denote_asm (pure_asm id) + ⩯ @id_ktree E A. Proof. rewrite pure_asm_correct; reflexivity. Defined. -Lemma tensor_den_slide_right {A B C D}: - forall (ac: @den E A C) (bd: den B D), - ac ⊗ bd ⩯ id_den ⊗ bd >=> ac ⊗ id_den. +Lemma tensor_ktree_slide_right {A B C D}: + forall (ac: ktree E A C) (bd: ktree E B D), + ac ⊗ bd ⩯ id_ktree ⊗ bd >=> ac ⊗ id_ktree. Proof. intros. - unfold tensor_den. - repeat rewrite id_den_left. + unfold tensor_ktree. + repeat rewrite id_ktree_left. rewrite sum_elim_compose. - rewrite compose_den_assoc. + rewrite compose_ktree_assoc. rewrite inl_sum_elim, inr_sum_elim. reflexivity. Qed. Lemma local_rewrite1 {A B C: Type}: - id_den ⊗ sym_den >=> assoc_den_l >=> sym_den ⩯ - @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. + id_ktree ⊗ sym_ktree >=> assoc_ktree_l >=> sym_ktree ⩯ + @assoc_ktree_l E A B C >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r. Proof. - unfold id_den, tensor_den,sym_den, assoc_den_l, ITree.cat, assoc_den_r, lift_den. + unfold id_ktree, tensor_ktree,sym_ktree, assoc_ktree_l, ITree.cat, assoc_ktree_r, lift_ktree. intros [| []]; simpl; repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. Qed. Lemma local_rewrite2 {A B C: Type}: - sym_den >=> assoc_den_r >=> id_den ⊗ sym_den ⩯ - @assoc_den_l E A B C >=> sym_den ⊗ id_den >=> assoc_den_r. + sym_ktree >=> assoc_ktree_r >=> id_ktree ⊗ sym_ktree ⩯ + @assoc_ktree_l E A B C >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r. Proof. - unfold id_den, tensor_den,sym_den, assoc_den_l, ITree.cat, assoc_den_r, lift_den. + unfold id_ktree, tensor_ktree,sym_ktree, assoc_ktree_l, ITree.cat, assoc_ktree_r, lift_ktree. intros [| []]; simpl; repeat (rewrite bind_bind; simpl) || (rewrite ret_bind_; simpl); reflexivity. Qed. -Lemma loop_tensor_den {I A B C D} - (ab : @den E A B) (cd : @den E (I + C) (I + D)) : - ab ⊗ loop_den cd ⩯ - loop_den (assoc_den_l >=> sym_den ⊗ id_den >=> assoc_den_r +Lemma loop_tensor_ktree {I A B C D} + (ab : ktree E A B) (cd : ktree E (I + C) (I + D)) : + ab ⊗ loop cd ⩯ + loop (assoc_ktree_l >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r >=> ab ⊗ cd - >=> assoc_den_l >=> sym_den ⊗ id_den >=> assoc_den_r). + >=> assoc_ktree_l >=> sym_ktree ⊗ id_ktree >=> assoc_ktree_r). Proof. - rewrite tensor_swap, tensor_den_loop. + rewrite tensor_swap, tensor_ktree_loop. rewrite <- compose_loop. rewrite <- loop_compose. rewrite (tensor_swap cd ab). - repeat rewrite <- compose_den_assoc. + repeat rewrite <- compose_ktree_assoc. rewrite local_rewrite1. - do 2 rewrite compose_den_assoc. - rewrite <- (compose_den_assoc sym_den assoc_den_r _). + do 2 rewrite compose_ktree_assoc. + rewrite <- (compose_ktree_assoc sym_ktree assoc_ktree_r _). rewrite local_rewrite2. - repeat rewrite <- compose_den_assoc. + repeat rewrite <- compose_ktree_assoc. reflexivity. Qed. @@ -309,57 +310,55 @@ Proof. destruct a; reflexivity. Qed. -Lemma foo_assoc_l {A B C D D'} (f : den _ D') : - @id_den E A ⊗ @assoc_den_l E B C D >=> (assoc_den_l >=> f) - ⩯ assoc_den_l >=> (assoc_den_l >=> (assoc_den_r ⊗ id_den >=> f)). +Lemma foo_assoc_l {A B C D D'} (f : ktree E _ D') : + @id_ktree E A ⊗ @assoc_ktree_l E B C D >=> (assoc_ktree_l >=> f) + ⩯ assoc_ktree_l >=> (assoc_ktree_l >=> (assoc_ktree_r ⊗ id_ktree >=> f)). Proof. - rewrite <- !compose_den_assoc. + rewrite <- !compose_ktree_assoc. rewrite <- assoc_coherent_l. - rewrite (compose_den_assoc _ _ (_ ⊗ id_den)). - rewrite cat_tensor, id_den_left, assoc_lr, tensor_id. - rewrite id_den_right. + rewrite (compose_ktree_assoc _ _ (_ ⊗ id_ktree)). + rewrite cat_tensor, id_ktree_left, assoc_lr, tensor_id. + rewrite id_ktree_right. reflexivity. Qed. -Lemma foo_assoc_r {A' A B C D} (f : den A' _) : - f >=> assoc_den_r >=> @id_den E A ⊗ @assoc_den_r E B C D - ⩯ f >=> assoc_den_l ⊗ id_den >=> assoc_den_r >=> assoc_den_r. +Lemma foo_assoc_r {A' A B C D} (f : ktree E A' _) : + f >=> assoc_ktree_r >=> @id_ktree E A ⊗ @assoc_ktree_r E B C D + ⩯ f >=> assoc_ktree_l ⊗ id_ktree >=> assoc_ktree_r >=> assoc_ktree_r. Proof. - rewrite (compose_den_assoc _ _ assoc_den_r). + rewrite (compose_ktree_assoc _ _ assoc_ktree_r). rewrite <- assoc_coherent_r. - rewrite (compose_den_assoc (tensor_den _ _)). - rewrite (compose_den_assoc _ (tensor_den _ _)). - rewrite <- (compose_den_assoc (tensor_den _ _)). - rewrite cat_tensor, id_den_left, assoc_lr, tensor_id. - rewrite id_den_left. - rewrite compose_den_assoc. + rewrite (compose_ktree_assoc (tensor_ktree _ _)). + rewrite (compose_ktree_assoc _ (tensor_ktree _ _)). + rewrite <- (compose_ktree_assoc (tensor_ktree _ _)). + rewrite cat_tensor, id_ktree_left, assoc_lr, tensor_id. + rewrite id_ktree_left. + rewrite compose_ktree_assoc. reflexivity. Qed. -Set Nested Proofs Allowed. - Definition app_asm_correct {A B C D} (ab : asm A B) (cd : asm C D) : - @eq_den E _ _ + @eq_ktree E _ _ (denote_asm (app_asm ab cd)) - (tensor_den (denote_asm ab) (denote_asm cd)). + (tensor_ktree (denote_asm ab) (denote_asm cd)). Proof. unfold denote_asm. match goal with | |- ?x ⩯ _ => set (lhs := x) end. - rewrite tensor_den_loop. - rewrite loop_tensor_den. + rewrite tensor_ktree_loop. + rewrite loop_tensor_ktree. rewrite <- compose_loop. rewrite <- loop_compose. rewrite loop_loop. subst lhs. - rewrite <- (loop_rename_internal' sym_den sym_den) + rewrite <- (loop_rename_internal' sym_ktree sym_ktree) by apply sym_nilpotent. - apply eq_den_loop. - rewrite ! compose_den_assoc. - unfold tensor_den, sym_den, ITree.cat, assoc_den_l, assoc_den_r, id_den, lift_den. + apply eq_ktree_loop. + rewrite ! compose_ktree_assoc. + unfold tensor_ktree, sym_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, id_ktree, lift_ktree. intros [[|]|[|]]; cbn. (* ... *) - all: repeat (rewrite ret_bind_; simpl). + all: repeat (rewrite ret_bind; simpl). all: rewrite bind_bind. all: unfold _app_B, _app_D. all: rewrite fmap_block_map. @@ -370,12 +369,12 @@ Qed. Definition relabel_bks_correct {A B C D} (f : A -> B) (g : C -> D) (bc : bks B C) : - @eq_den E _ _ + @eq_ktree E _ _ (denote_b (relabel_bks f g bc)) - (lift_den f >=> denote_b bc >=> lift_den g). + (lift_ktree f >=> denote_b bc >=> lift_ktree g). Proof. - rewrite lift_compose_den. - rewrite compose_den_lift. + rewrite lift_compose_ktree. + rewrite compose_ktree_lift. intro a. unfold denote_b, relabel_bks. rewrite fmap_block_map. @@ -384,28 +383,28 @@ Qed. Definition relabel_asm_correct {A B C D} (f : A -> B) (g : C -> D) (bc : asm B C) : - @eq_den E _ _ + @eq_ktree E _ _ (denote_asm (relabel_asm f g bc)) - (lift_den f >=> denote_asm bc >=> lift_den g). + (lift_ktree f >=> denote_asm bc >=> lift_ktree g). Proof. unfold denote_asm. simpl. rewrite relabel_bks_correct. rewrite <- compose_loop. rewrite <- loop_compose. - apply eq_den_loop. + apply eq_ktree_loop. rewrite !tensor_id_lift. reflexivity. Qed. Definition link_asm_correct {I A B} (ab : asm (I + A) (I + B)) : - @eq_den E _ _ + @eq_ktree E _ _ (denote_asm (link_asm ab)) - (loop_den (denote_asm ab)). + (loop (denote_asm ab)). Proof. unfold denote_asm. rewrite loop_loop. - apply eq_den_loop. + apply eq_ktree_loop. simpl. rewrite relabel_bks_correct. reflexivity. diff --git a/examples/Den.v b/examples/Den.v deleted file mode 100644 index 5352d23f..00000000 --- a/examples/Den.v +++ /dev/null @@ -1,710 +0,0 @@ -From ITree Require Import - ITree - OpenSum - Fix - FixFacts - Basics_Functions. - -From Coq Require Import - Program - Morphisms. - -Set Nested Proofs Allowed. -(** * Category of denotations *) - -Definition den {E: Type -> Type} A B : Type := A -> itree E B. -(* den can represent both blocks (A -> block B) and asm (asm A B). *) - -Section Den. - - (* (@den E) forms a traced monoidal category, i.e. a symmetric monoidal one with a loop operator *) - (* Obj ≅ Type *) - (* Arrow: A -> B ≅ terms of type (den A B) *) - - Context {E: Type -> Type}. - Notation denE := (@den E). - - Section Equivalence. - - (* We work up to pointwise eutt *) - Definition eq_den {A B} (d1 d2 : A -> itree E B) := - (forall a, eutt eq (d1 a) (d2 a)). - - Global Instance Equivalence_eq_den {A B} : Equivalence (@eq_den A B). - Proof. - split. - - intros ab a; reflexivity. - - intros ab ab' eqAB a; symmetry; auto. - - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. - Qed. - - Global Instance eq_den_elim {A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@sum_elim A B (itree E C)). - Proof. - repeat intro. destruct a; unfold sum_elim; auto. - Qed. - - End Equivalence. - - - Infix "⩯" := eq_den (at level 70). - - Section Structure. - - (* Composition *) - Notation compose_den := ITree.cat. - - (* Identities *) - Definition I: Type := Empty_set. - Definition id_den {A} : denE A A := fun a => Ret a. - - (* Utility function to lift a pure computation into den *) - Definition lift_den {A B} (f : A -> B) : denE A B := fun a => Ret (f a). - - (* Tensor product *) - (* Tensoring on objects is simply the sum type constructor *) - Definition tensor_den {A B C D} - (ab : denE A B) (cd : denE C D) : den (A + C) (B + D) := - sum_elim (compose_den ab (lift_den inl)) (compose_den cd (lift_den inr)). - - (* Left and right unitors *) - Definition λ_den {A: Type}: denE (I + A) A := lift_den sum_empty_l. - Definition λ_den' {A: Type}: denE A (I + A) := lift_den inr. - Definition ρ_den {A: Type}: denE (A + I) A := lift_den sum_empty_r. - Definition ρ_den' {A: Type}: denE A (A + I) := lift_den inl. - - (* Associator *) - Definition assoc_den_l {A B C: Type}: denE (A + (B + C)) ((A + B) + C) := lift_den sum_assoc_l. - Definition assoc_den_r {A B C: Type}: denE ((A + B) + C) (A + (B + C)) := lift_den sum_assoc_r. - - (* Symmetry *) - Definition sym_den {A B: Type}: denE (A + B) (B + A) := lift_den sum_comm. - - (* - A [box : den (I + A) (I + B)] is a circuit, drawn below as ###, - with two input wires labeled by I and A, and two output wires - labeled by I and B. - - The [loop_den : den (I + A) (I + B) -> den A B] combinator closes - the circuit, linking the box with itself by plugging the I output - back into the input. - - +-----+ - | ### | - +-###-+I - A----###----B - ### - - *) - Definition loop_den {I A B} : - (I + A -> itree E (I + B)) -> A -> itree E B := loop. - - End Structure. - - Infix "⊗" := (tensor_den) (at level 30). - - Section Laws. - - (** *** [compose_den] respect eq_den *) - Global Instance eq_den_compose {A B C} : - Proper (eq_den ==> eq_den ==> eq_den) (@ITree.cat _ A B C). - Proof. - intros ab ab' eqAB bc bc' eqBC. - intro a. - unfold ITree.cat. - rewrite (eqAB a). - apply eutt_bind; try reflexivity. - intro b; rewrite (eqBC b); reflexivity. - Qed. - - (** *** [compose_den] is associative *) - Lemma compose_den_assoc {A B C D} - (ab : den A B) (bc : den B C) (cd : den C D) : - ((ab >=> bc) >=> cd) ⩯ (ab >=> (bc >=> cd)). - Proof. - intros a. - unfold ITree.cat. - rewrite bind_bind. - apply eutt_bind; try reflexivity. - Qed. - - (** *** [id_den] respect identity laws *) - Lemma id_den_left {A B}: forall (f: denE A B), - id_den >=> f ⩯ f. - Proof. - intros f a; unfold ITree.cat, id_den. - rewrite itree_eta; rewrite ret_bind. rewrite <- itree_eta; reflexivity. - Qed. - - Lemma id_den_right {A B}: forall (f: denE A B), - f >=> id_den ⩯ f. - Proof. - intros f a; unfold ITree.cat, id_den. - rewrite <- (bind_ret (f a)) at 2. - reflexivity. - Qed. - - (** *** [lift_den] is well-behaved *) - - Global Instance eq_lift_den {A B} : - Proper (eeq ==> eq_den) (@lift_den A B). - Proof. - repeat intro. - unfold lift_den. - erewrite (H a); reflexivity. - Qed. - - Lemma lift_den_id {A: Type}: @id_den A ⩯ lift_den id. - Proof. - unfold id_den, lift_den; reflexivity. - Qed. - - Fact compose_lift_den {A B C} (ab : A -> B) (bc : B -> C) : - (lift_den ab >=> lift_den bc) ⩯ (lift_den (bc ∘ ab)). - Proof. - intros a. - unfold lift_den, ITree.cat. - rewrite ret_bind_. - reflexivity. - Qed. - - Fact compose_lift_den_l {A B C D} (f: A -> B) (g: B -> C) (k: den C D) : - (lift_den f >=> (lift_den g >=> k)) ⩯ (lift_den (g ∘ f) >=> k). - Proof. - rewrite <- compose_den_assoc. - rewrite compose_lift_den. - reflexivity. - Qed. - - Fact compose_lift_den_r {A B C D} (f: B -> C) (g: C -> D) (k: den A B) : - ((k >=> lift_den f) >=> lift_den g) ⩯ (k >=> lift_den (g ∘ f)). - Proof. - rewrite compose_den_assoc. - rewrite compose_lift_den. - reflexivity. - Qed. - - Fact lift_compose_den {A B C}: forall (f:A -> B) (bc: den B C), - lift_den f >=> bc ⩯ fun a => bc (f a). - Proof. - intros; intro a. - unfold lift_den, ITree.cat. - rewrite ret_bind_. reflexivity. - Qed. - - Fact compose_den_lift {A B C}: forall (ab: den A B) (g:B -> C), - eq_den (ab >=> lift_den g) - (fun a => ITree.map g (ab a)). - Proof. - intros; intro a. - unfold ITree.map. - apply eutt_bind. - reflexivity. - intro; reflexivity. - Qed. - - (** *** [associators] *) - Lemma assoc_lr {A B C} : - @assoc_den_l A B C >=> assoc_den_r ⩯ id_den. - Proof. - unfold assoc_den_l, assoc_den_r. - rewrite compose_lift_den. - intros [| []]; reflexivity. - Qed. - - Lemma assoc_rl {A B C} : - @assoc_den_r A B C >=> assoc_den_l ⩯ id_den. - Proof. - unfold assoc_den_l, assoc_den_r. - rewrite compose_lift_den. - intros [[]|]; reflexivity. - Qed. - - (** *** [sum_elim] lemmas *) - - Fact compose_sum_elim {A B C D} (ac : den A C) (bc : den B C) (cd : den C D) : - sum_elim ac bc >=> cd ⩯ sum_elim (ac >=> cd) (bc >=> cd). - Proof. - intros; intros []; - (unfold ITree.map; simpl; apply eutt_bind; reflexivity). - Qed. - - Fact lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : - sum_elim (lift_den ac) (lift_den bc) ⩯ lift_den (sum_elim ac bc). - Proof. - intros []; reflexivity. - Qed. - - (** *** [Unitors] lemmas *) - - Lemma elim_λ_den {A B: Type}: - forall (ab: @den E A (I + B)), ab >=> λ_den ⩯ (fun a: A => ITree.map sum_empty_l (ab a)). - Proof. - intros; apply compose_den_lift. - Qed. - - Lemma elim_λ_den' {A B: Type}: - forall (f: @den E (I + A) (I + B)), - λ_den' >=> f ⩯ fun a => f (inr a). - Proof. - repeat intro. - unfold λ_den', ITree.cat, lift_den. - rewrite ret_bind_; reflexivity. - Qed. - - Lemma elim_ρ_den' {A B: Type}: - forall (f: @den E (A + I) (B + I)), - ρ_den' >=> f ⩯ fun a => f (inl a). - Proof. - repeat intro. - unfold ρ_den', ITree.cat, lift_den. - rewrite ret_bind_; reflexivity. - Qed. - - Lemma elim_ρ_den {A B: Type}: - forall (ab: @den E A (B + I)), ab >=> ρ_den ⩯ (fun a: A => ITree.map sum_empty_r (ab a)). - Proof. - intros; apply compose_den_lift. - Qed. - - (** *** [tensor] lemmas *) - - Global Instance eq_den_tensor {A B C D}: - Proper (eq_den ==> eq_den ==> eq_den) (@tensor_den A B C D). - Proof. - intros ac ac' eqac bd bd' eqbd. - unfold tensor_den. - rewrite eqac, eqbd; reflexivity. - Qed. - - Fact tensor_id_lift {A B C} (f : B -> C) : - (@id_den A) ⊗ (lift_den f) ⩯ lift_den (sum_bimap id f). - Proof. - unfold tensor_den. - rewrite compose_lift_den, id_den_left. - rewrite lift_sum_elim. - reflexivity. - Qed. - - Fact tensor_lift_id {A B C} (f : A -> B) : - (lift_den f) ⊗ (@id_den C) ⩯ lift_den (sum_bimap f id). - Proof. - unfold tensor_den. - rewrite compose_lift_den, id_den_left. - rewrite lift_sum_elim. - reflexivity. - Qed. - - Lemma tensor_id {A B} : - id_den ⊗ id_den ⩯ @id_den (A + B). - Proof. - unfold tensor_den, ITree.cat, id_den. - intros []; cbn; rewrite ret_bind_; reflexivity. - Qed. - - Lemma assoc_I {A B}: - @assoc_den_r A I B >=> id_den ⊗ λ_den ⩯ ρ_den ⊗ id_den. - Proof. - unfold ρ_den,λ_den. - rewrite tensor_lift_id, tensor_id_lift. - unfold assoc_den_r. - rewrite compose_lift_den. - apply eq_lift_den. - intros [[|]|]; compute; try reflexivity. - destruct i. - Qed. - - Lemma cat_tensor {A1 A2 A3 B1 B2 B3} - (f1 : @den E A1 A2) (f2 : den A2 A3) - (g1 : den B1 B2) (g2 : den B2 B3) : - (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩯ (f1 >=> f2) ⊗ (g1 >=> g2). - Proof. - unfold tensor_den, ITree.cat, lift_den; simpl. - intros []; simpl; - rewrite !bind_bind; setoid_rewrite ret_bind_; reflexivity. - Qed. - - Lemma sum_elim_compose {A B C D F}: - forall (ac: denE A (C + D)) (bc: denE B (C + D)) (cf: denE C F) (df: denE D F), - sum_elim ac bc >=> sum_elim cf df ⩯ - sum_elim (ac >=> (sum_elim cf df)) (bc >=> (sum_elim cf df)). - Proof. - intros. - unfold ITree.map. - intros []; reflexivity. - Qed. - - Lemma inl_sum_elim {A B C}: - forall (ac: denE A C) (bc: denE B C), - lift_den inl >=> sum_elim ac bc ⩯ ac. - Proof. - intros. - unfold ITree.cat, lift_den. - intros ?. - rewrite ret_bind_. - reflexivity. - Qed. - - Lemma inr_sum_elim {A B C}: - forall (ac: denE A C) (bc: denE B C), - lift_den inr >=> sum_elim ac bc ⩯ bc. - Proof. - intros. - unfold ITree.cat, lift_den. - intros ?. - rewrite ret_bind_. - reflexivity. - Qed. - - Lemma tensor_den_slide {A B C D}: - forall (ac: @den E A C) (bd: den B D), - ac ⊗ bd ⩯ ac ⊗ id_den >=> id_den ⊗ bd. - Proof. - intros. - unfold tensor_den. - repeat rewrite id_den_left. - rewrite sum_elim_compose. - rewrite compose_den_assoc. - rewrite inl_sum_elim, inr_sum_elim. - reflexivity. - Qed. - - Lemma assoc_coherent_r {A B C D}: - @assoc_den_r A B C ⊗ @id_den D >=> assoc_den_r >=> id_den ⊗ assoc_den_r ⩯ - assoc_den_r >=> assoc_den_r. - Proof. - unfold tensor_den, assoc_den_r. - repeat rewrite id_den_left. - repeat rewrite compose_sum_elim. - repeat rewrite compose_lift_den. - rewrite lift_sum_elim. - repeat rewrite compose_lift_den. - rewrite lift_sum_elim. - apply eq_lift_den. - intros [[[|]|]|]; reflexivity. - Qed. - - Lemma assoc_coherent_l {A B C D}: - @id_den A ⊗ @assoc_den_l B C D >=> assoc_den_l >=> assoc_den_l ⊗ id_den ⩯ - assoc_den_l >=> assoc_den_l. - Proof. - unfold tensor_den, assoc_den_l. - repeat rewrite id_den_left. - repeat rewrite compose_sum_elim. - repeat rewrite compose_lift_den. - rewrite lift_sum_elim. - repeat rewrite compose_lift_den. - rewrite lift_sum_elim. - apply eq_lift_den. - intros [|[|[|]]]; reflexivity. - Qed. - - (** *** [sym] lemmas *) - - Lemma sym_unit_den {A} : - sym_den >=> λ_den ⩯ @ρ_den A. - Proof. - unfold sym_den, ρ_den, λ_den. - rewrite lift_compose_den. - intros []; simpl; reflexivity. - Qed. - - Lemma sym_assoc_den {A B C}: - @assoc_den_r A B C >=> sym_den >=> assoc_den_r ⩯ - (sym_den ⊗ id_den) >=> assoc_den_r >=> (id_den ⊗ sym_den). - Proof. - unfold assoc_den_r, sym_den. - rewrite tensor_lift_id, tensor_id_lift. - repeat rewrite compose_lift_den. - apply eq_lift_den. - intros [[|]|]; compute; reflexivity. - Qed. - - Lemma sym_nilpotent {A B: Type}: - sym_den >=> sym_den ⩯ @id_den (A + B). - Proof. - unfold sym_den, id_den. - rewrite compose_lift_den. - unfold compose. - unfold lift_den; intros a. - setoid_rewrite iso_ff'; reflexivity. - Qed. - - Lemma tensor_swap {A B C D} (ab : den A B) (cd : den C D) : - ab ⊗ cd ⩯ (sym_den >=> cd ⊗ ab >=> sym_den). - Proof. - unfold tensor_den. - unfold sym_den. - rewrite !(compose_den_lift cd), !(compose_den_lift ab), !lift_compose_den, !compose_den_lift. - intros []; cbn; rewrite map_map; cbn; - apply eutt_map; try intros []; reflexivity. - Qed. - - (** *** [loop] lemmas *) - - Global Instance eq_den_loop {I A B} : - Proper (eq_den ==> eq_den) (@loop_den I A B). - Proof. - repeat intro. - unfold loop_den. - apply eutt_loop; [| reflexivity]. - auto. - Qed. - - Lemma bind_map: forall {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z), - eq_itree eq (ITree.map f (x <- t;; k x)) (x <- t;; ITree.map f (k x)). - Proof. - intros. - unfold ITree.map. - rewrite bind_bind. - reflexivity. - Qed. - - (* Naturality of (loop_den I A B) in A *) - (* Or more diagrammatically: -[[ - +-----+ - | ### | - +-###-+I -A----B----###----C - ### - -is equivalent to: - - +----------+ - | ### | - +------###-+I -A----B----###----C - ### - -]] - *) - - Lemma compose_loop {I A B C}: - forall (bc_: denE (I + B) (I + C)) (ab: denE A B), - loop_den ((id_den ⊗ ab) >=> bc_) ⩯ - ab >=> loop_den bc_. - Proof. - intros bc_ ab a. - rewrite (loop_natural_l ab bc_ a). - unfold loop_den. - apply eutt_loop; [intros [] | reflexivity]. - all: unfold tensor_den, sym_den, ITree.cat, assoc_den_l, assoc_den_r, id_den, lift_den; simpl. - - rewrite bind_bind, ret_bind_; reflexivity. - - rewrite bind_bind, map_bind. - setoid_rewrite ret_bind_; reflexivity. - Qed. - - (* Naturality of (loop_den I A B) in B *) - (* Or more diagrammatically: -[[ - +-----+ - | ### | - +-###-+I -A----###----B----C - ### - -is equivalent to: - - +----------+ - | ### | - +-###------+I -A----###----B----C - ### - -]] - *) - - Lemma loop_compose {I A B B'}: - forall (ab_: denE (I + A) (I + B)) (bc: denE B B'), - loop_den (ab_ >=> (id_den ⊗ bc)) ⩯ - loop_den ab_ >=> bc. - intros bc_ ab a. - rewrite (loop_natural_r ab bc_ a). - unfold loop_den. - apply eutt_loop; [intros [] | reflexivity]. - all: unfold tensor_den, sym_den, ITree.cat, assoc_den_l, assoc_den_r, id_den, lift_den; simpl. - - apply eutt_bind; [reflexivity | intros []; simpl]. - rewrite ret_bind_; reflexivity. - reflexivity. - - apply eutt_bind; [reflexivity | intros []; simpl]. - rewrite ret_bind_; reflexivity. - reflexivity. - Qed. - - (* Dinaturality of (loop_den I A B) in I *) - - Lemma loop_rename_internal {I J A B}: - forall (ab_: denE (I + A) (J + B)) (ji: denE J I), - loop_den (ab_ >=> (ji ⊗ id_den)) ⩯ - loop_den ((ji ⊗ id_den) >=> ab_). - Proof. - intros; unfold loop_den. - unfold tensor_den, ITree.cat, lift_den, sum_elim. - - assert (EQ:forall (x: J + B), - match x with - | inl a => a0 <- ji a;; Ret (inl a0) - | inr b => a <- id_den b;; Ret (inr a) - end ≈ - match x with - | inl a => Tau (ITree.map (@inl I B) (ji a)) - | inr b => Ret (inr b) - end). - { - intros []. - symmetry; apply tau_eutt. - unfold id_den. - rewrite ret_bind_; reflexivity. - } - intros ?. - setoid_rewrite EQ. - rewrite loop_dinatural. - apply eutt_loop; [intros [] | reflexivity]. - all: unfold id_den. - all: repeat rewrite bind_bind. - 2: repeat rewrite ret_bind_; reflexivity. - apply eutt_bind; [reflexivity | intros ?]. - apply eutt_bind; [| intros ?; reflexivity]. - apply tau_eutt. - Qed. - - Lemma map_is_cat {R S: Type}: - forall (f: R -> S) (t: itree E R), - ITree.map f t ≈ ITree.cat (fun _:unit => t) (fun x => Ret (f x)) tt. - Proof. - intros; reflexivity. - Qed. - - (* Loop over the empty set can be erased *) - Lemma vanishing_den {A B: Type}: - forall (f: denE (I + A) (I + B)), - loop_den f ⩯ λ_den' >=> f >=> λ_den. - Proof. - intros f a. - unfold loop_den. - rewrite vanishing1. - unfold λ_den,λ_den'. - unfold ITree.cat, ITree.map, lift_den. - rewrite bind_bind. - rewrite ret_bind_. - reflexivity. - Qed. - - (* [loop_loop]: - -These two loops: - -[[ - +----------+ - | +-----+ | - | | ### | | - | +-###-+I | - +---###----+J - A-----###-------B - ### -]] - -... can be rewired as a single one: - - -[[ - +-------+ - | ### | - +--###--+(I+J) - +--###--+ - A-----###-----B - ### -]] - - *) - - Lemma loop_loop {I J A B}: - forall (ab__: denE (I + (J + A)) (I + (J + B))), - loop_den (loop_den ab__) ⩯ - loop_den (assoc_den_r >=> ab__ >=> assoc_den_l). - Proof. - intros ab_ a; unfold loop_den. - rewrite vanishing2. - apply eutt_loop; [intros [[]|] | reflexivity]. - all: unfold ITree.map, ITree.cat, assoc_den_r, assoc_den_l, lift_den; cbn. - all: rewrite bind_bind. - all: rewrite ret_bind_. - all: reflexivity. - Qed. - - Lemma fold_map {R S}: - forall (f: R -> S) (t: itree E R), - (x <- t;; Ret (f x)) ≅ (ITree.map f t). - Proof. - intros; reflexivity. - Qed. - - Lemma tensor_den_loop {I A B C D} - (ab : denE (I + A) (I + B)) (cd : denE C D) : - (loop_den ab) ⊗ cd ⩯ - loop_den (assoc_den_l >=> (ab ⊗ cd) >=> assoc_den_r). - Proof. - unfold loop_den, tensor_den, ITree.cat, assoc_den_l, assoc_den_r, lift_den, sum_elim. - intros []; simpl. - all:setoid_rewrite bind_bind. - all:setoid_rewrite ret_bind_. - all:rewrite fold_map. - 1:rewrite (@superposing1 E A B I C D). - 2:rewrite (@superposing2 E A B I C D). - all:unfold sum_bimap, ITree.map, sum_assoc_r,sum_elim; cbn. - all:apply eutt_loop; [intros [| []]; cbn | reflexivity]. - all: setoid_rewrite bind_bind. - all:setoid_rewrite ret_bind_. - all:reflexivity. - Qed. - - Lemma yanking_den {A: Type}: - loop_den sym_den ⩯ @id_den A. - Proof. - unfold loop_den, sym_den, lift_den. - intros ?; rewrite yanking. - apply tau_eutt. - Qed. - - Lemma loop_rename_internal' {I J A B} (ij : den I J) (ji: den J I) - (ab_: @den E (I + A) (I + B)) : - (ij >=> ji) ⩯ id_den -> - loop_den ((ji ⊗ id_den) >=> ab_ >=> (ij ⊗ id_den)) ⩯ - loop_den ab_. - Proof. - intros Hij. - rewrite loop_rename_internal. - rewrite <- compose_den_assoc. - rewrite cat_tensor. - rewrite Hij. - rewrite id_den_left. - rewrite tensor_id. - rewrite id_den_left. - reflexivity. - Qed. - - End Laws. -End Den. - -Bind Scope den_scope with den. -Infix "⩯" := eq_den (at level 70). -Infix "⊗" := (tensor_den) (at level 30). - -Hint Rewrite @compose_den_assoc : lift_den. -Hint Rewrite @tensor_id_lift : lift_den. -Hint Rewrite @tensor_lift_id : lift_den. -Hint Rewrite @lift_sum_elim : lift_den. - -(* A trick to allow rewriting with eq_den in pointful contexts. *) -Definition to_itree {E} (f : @den E unit unit) : itree E unit := f tt. - -Global Instance Proper_to_itree {E} : - Proper (eq_den ==> eutt eq) (@to_itree E). -Proof. - repeat intro. - apply H. -Qed. - -Lemma fold_to_itree {E} (f : @den E unit unit) : f tt = to_itree f. -Proof. reflexivity. Qed. diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 92e3300b..de5a2d74 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -1,4 +1,4 @@ -Require Import Imp Asm AsmCombinators Den Imp2Asm. +Require Import Imp Asm AsmCombinators Imp2Asm. Require Import Psatz. @@ -10,11 +10,11 @@ From Coq Require Import From ITree Require Import Basics_Functions - Core + ITree Effect.Env MorphismsFacts FixFacts - ITree. + KTree. From ExtLib Require Import Core.RelDec @@ -522,40 +522,19 @@ Section Correctness. eapply Renv_write_local; eauto. Qed. - Lemma sym_den_unfold {E} {A B}: - lift_den sum_comm ⩯ @sym_den E A B. - Proof. - reflexivity. - Qed. - - Lemma seq_linking_den {E} {A B C} (ab : @den E A B) (bc : den B C) : - loop_den (sym_den >=> ab ⊗ bc) ⩯ ab >=> bc. - Proof. - rewrite tensor_den_slide. - rewrite <- compose_den_assoc. - rewrite loop_compose. - rewrite tensor_swap. - repeat rewrite <- compose_den_assoc. - rewrite sym_nilpotent, id_den_left. - rewrite compose_loop. - erewrite yanking_den. - rewrite id_den_right. - reflexivity. - Qed. - Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) : - eq_den (denote_asm (seq_asm ab bc)) + eq_ktree (denote_asm (seq_asm ab bc)) (denote_asm ab >=> denote_asm bc). Proof. unfold seq_asm. rewrite link_asm_correct, relabel_asm_correct, app_asm_correct. - rewrite id_den_right. - rewrite sym_den_unfold. - apply seq_linking_den. + rewrite id_ktree_right. + rewrite sym_ktree_unfold. + apply cat_from_loop. Qed. Lemma if_asm_correct {A} (e : list instr) (tp fp : asm unit A) : - eq_den + eq_ktree (denote_asm (if_asm e tp fp)) (fun _ => denote_list e ;; @@ -576,43 +555,43 @@ Section Correctness. rewrite (relabel_asm_correct _ _ _ (inr tt)). unfold ITree.cat; simpl. rewrite bind_bind. - unfold lift_den; rewrite ret_bind_. + unfold lift_ktree; rewrite ret_bind_. setoid_rewrite (app_asm_correct tp fp (inr tt)). setoid_rewrite bind_bind. rewrite <- (bind_ret (denote_asm fp tt)) at 2. eapply eutt_bind; [ reflexivity | intros ? ]. - unfold lift_den; rewrite ret_bind_; reflexivity. + unfold lift_ktree; rewrite ret_bind_; reflexivity. - rewrite ret_bind_. rewrite (relabel_asm_correct _ _ _ (inl tt)). unfold ITree.cat; simpl. rewrite bind_bind. - unfold lift_den; rewrite ret_bind_. + unfold lift_ktree; rewrite ret_bind_. setoid_rewrite (app_asm_correct tp fp (inl tt)). setoid_rewrite bind_bind. rewrite <- (bind_ret (denote_asm tp tt)) at 2. eapply eutt_bind; [reflexivity | intros ?]. - unfold lift_den; rewrite ret_bind_; reflexivity. + unfold lift_ktree; rewrite ret_bind_; reflexivity. Qed. Lemma while_asm_correct (e : list instr) (p : asm unit unit) : - eq_den + eq_ktree (denote_asm (while_asm e p)) - (loop_den (fun l => - match l with - | inl tt => - denote_list e ;; - v <- lift (GetVar tmp_if) ;; - if v : value then - Ret (inr tt) - else - denote_asm p tt;; Ret (inl tt) - | inr tt => Ret (inl tt) - end)). + (loop (fun l => + match l with + | inl tt => + denote_list e ;; + v <- lift (GetVar tmp_if) ;; + if v : value then + Ret (inr tt) + else + denote_asm p tt;; Ret (inl tt) + | inr tt => Ret (inl tt) + end)). Proof. unfold while_asm. rewrite link_asm_correct. - apply eq_den_loop. - rewrite relabel_asm_correct, id_den_left. + apply eq_ktree_loop. + rewrite relabel_asm_correct, id_ktree_left. rewrite app_asm_correct. rewrite if_asm_correct. intros [[] |[]]. @@ -623,13 +602,13 @@ Section Correctness. rewrite bind_bind. apply eutt_bind; [reflexivity | intros []]. + rewrite (pure_asm_correct _ tt). - unfold lift_den. + unfold lift_ktree. repeat rewrite ret_bind_. reflexivity. + rewrite (relabel_asm_correct _ _ _ tt). unfold ITree.cat. simpl; repeat setoid_rewrite bind_bind. - unfold lift_den; rewrite ret_bind_. + unfold lift_ktree; rewrite ret_bind_. apply eutt_bind; [reflexivity | intros []]. repeat rewrite ret_bind_; reflexivity. - rewrite itree_eta; cbn; reflexivity. @@ -709,7 +688,7 @@ Section Correctness. simpl; rewrite fold_to_itree. rewrite while_asm_correct. rewrite while_is_loop. - unfold to_itree, loop_den. + unfold to_itree. apply eq_locals_loop. intros [[]|[]]. 2:{ repeat intro. diff --git a/examples/_CoqProject b/examples/_CoqProject index dd9e7cf0..1e4b83c0 100644 --- a/examples/_CoqProject +++ b/examples/_CoqProject @@ -5,11 +5,9 @@ IO.v MultiThreadedPrinting.v ExtractThreadsExample.v -Den.v Imp.v Asm.v AsmCombinators.v -Linking.v Imp2Asm.v Imp2AsmCorrectness.v diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 0d0ae001..21dacae1 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -435,6 +435,23 @@ Proof. rewrite bind_bind. setoid_rewrite ret_bind. reflexivity. Qed. +Lemma bind_map {E X Y Z} (t: itree E X) (k: X -> itree E Y) (f: Y -> Z) : + (ITree.map f (x <- t;; k x)) ≅ (x <- t;; ITree.map f (k x)). +Proof. + intros. + unfold ITree.map. + rewrite bind_bind. + reflexivity. +Qed. + +(* Used in KTree *) +Lemma map_is_cat {E} {R S: Type} (f: R -> S) (t: itree E R) : + ITree.map f t + ≅ ITree.cat (fun _:unit => t) (fun x => Ret (f x)) tt. +Proof. + intros; reflexivity. +Qed. + (* Import Hom. diff --git a/theories/KTree.v b/theories/KTree.v new file mode 100644 index 00000000..3ec0f0d7 --- /dev/null +++ b/theories/KTree.v @@ -0,0 +1,756 @@ +(** * The Category of Continuation Trees *) + +(** The Kleisli category of ITrees. *) + +(* begin hide *) +From ITree Require Import + ITree + OpenSum + Fix + FixFacts + Basics_Functions. + +From Coq Require Import + Program + Morphisms. +(* end hide *) + +Definition ktree (E: Type -> Type) (A B : Type) : Type + := A -> itree E B. +(* ktree can represent both blocks (A -> block B) and asm (asm A B). *) + +Bind Scope ktree_scope with ktree. + +(* (@ktree E) forms a traced monoidal category, i.e. a symmetric monoidal one with a loop operator *) +(* Obj ≅ Type *) +(* Arrow: A -> B ≅ terms of type (ktree A B) *) + +(** ** KTree equivalence *) +Section Equivalence. + +Context {E : Type -> Type}. + +(* We work up to pointwise eutt *) +Definition eq_ktree {A B} (d1 d2 : ktree E A B) := + (forall a, eutt eq (d1 a) (d2 a)). + +Global Instance Equivalence_eq_ktree {A B} : Equivalence (@eq_ktree A B). +Proof. + split. + - intros ab a; reflexivity. + - intros ab ab' eqAB a; symmetry; auto. + - intros ab ab' ab'' eqAB eqAB' a; etransitivity; eauto. +Qed. + +Global Instance eq_ktree_elim {A B C} : + Proper (eq_ktree ==> eq_ktree ==> eq_ktree) (@sum_elim A B (itree E C)). +Proof. + repeat intro. destruct a; unfold sum_elim; auto. +Qed. + +End Equivalence. + +Infix "⩯" := eq_ktree (at level 70). + +(** *** Conversion to [itree] *) +(** A trick to allow rewriting with eq_ktree in pointful contexts. *) + +Definition to_itree {E} (f : @ktree E unit unit) : itree E unit := f tt. + +Global Instance Proper_to_itree {E} : + Proper (eq_ktree ==> eutt eq) (@to_itree E). +Proof. + repeat intro. + apply H. +Qed. + +Lemma fold_to_itree {E} (f : @ktree E unit unit) : f tt = to_itree f. +Proof. reflexivity. Qed. + + +(** ** Categorical operations *) + +Section Operations. + +Context {E : Type -> Type}. + +(* Utility function to lift a pure computation into ktree *) +Definition lift_ktree {A B} (f : A -> B) : ktree E A B := fun a => Ret (f a). + +(** *** Category *) + +(** Identity morphism *) +Definition id_ktree {A} : ktree E A A := fun a => Ret a. + +(** Composition is [ITree.cat], denoted as [>=>]. *) + +(** *** Symmetric monoidal category *) + +(** Monoidal unit *) +Definition I: Type := Empty_set. + +(** Tensor product *) +(* Tensoring on objects is given by the coproduct *) +Definition tensor_ktree {A B C D} + (ab : ktree E A B) (cd : ktree E C D) + : ktree E (A + C) (B + D) + := sum_elim (ab >=> lift_ktree inl) (cd >=> lift_ktree inr). + +(* Left and right unitors *) +Definition λ_ktree {A: Type}: ktree E (I + A) A := lift_ktree sum_empty_l. +Definition λ_ktree' {A: Type}: ktree E A (I + A) := lift_ktree inr. +Definition ρ_ktree {A: Type}: ktree E (A + I) A := lift_ktree sum_empty_r. +Definition ρ_ktree' {A: Type}: ktree E A (A + I) := lift_ktree inl. + +(* Associators *) +Definition assoc_ktree_l {A B C: Type}: ktree E (A + (B + C)) ((A + B) + C) := lift_ktree sum_assoc_l. +Definition assoc_ktree_r {A B C: Type}: ktree E ((A + B) + C) (A + (B + C)) := lift_ktree sum_assoc_r. + +(* Symmetry *) +Definition sym_ktree {A B: Type}: ktree E (A + B) (B + A) := lift_ktree sum_comm. + +(** Traced monoidal category *) + +(* The trace is [Fix.loop]. + + A [box : ktree (I + A) (I + B)] is a circuit, drawn below as ###, + with two input wires labeled by I and A, and two output wires + labeled by I and B. + + The [loop_ktree : ktree (I + A) (I + B) -> ktree A B] combinator closes + the circuit, linking the box with itself by plugging the I output + back into the input. + + +-----+ + | ### | + +-###-+I + A----###----B + ### + + *) + +End Operations. + +Infix "⊗" := (tensor_ktree) (at level 30). + +(** ** Equations *) + +Section CategoryLaws. + +Context {E : Type -> Type}. + +(** *** [compose_ktree] respect eq_ktree *) +Global Instance eq_ktree_compose {A B C} : + Proper (eq_ktree ==> eq_ktree ==> eq_ktree) (@ITree.cat E A B C). +Proof. + intros ab ab' eqAB bc bc' eqBC. + intro a. + unfold ITree.cat. + rewrite (eqAB a). + apply eutt_bind; try reflexivity. + intro b; rewrite (eqBC b); reflexivity. +Qed. + +(** *** [compose_ktree] is associative *) +Lemma compose_ktree_assoc {A B C D} + (ab : ktree E A B) (bc : ktree E B C) (cd : ktree E C D) : + ((ab >=> bc) >=> cd) ⩯ (ab >=> (bc >=> cd)). +Proof. + intros a. + unfold ITree.cat. + rewrite bind_bind. + apply eutt_bind; try reflexivity. +Qed. + +(** *** [id_ktree] respect identity laws *) +Lemma id_ktree_left {A B}: forall (f: ktree E A B), + id_ktree >=> f ⩯ f. +Proof. + intros f a; unfold ITree.cat, id_ktree. + rewrite itree_eta; rewrite ret_bind. rewrite <- itree_eta; reflexivity. +Qed. + +Lemma id_ktree_right {A B}: forall (f: ktree E A B), + f >=> id_ktree ⩯ f. +Proof. + intros f a; unfold ITree.cat, id_ktree. + rewrite <- (bind_ret (f a)) at 2. + reflexivity. +Qed. + +End CategoryLaws. + +(** *** [lift] properties *) + +Section LiftLaws. + +Context {E : Type -> Type}. + +(** *** [lift_ktree] is well-behaved *) + +Global Instance eq_lift_ktree {A B} : + Proper (eeq ==> eq_ktree) (@lift_ktree E A B). +Proof. + repeat intro. + unfold lift_ktree. + erewrite (H a); reflexivity. +Qed. + +Lemma lift_ktree_id {A: Type}: @id_ktree E A ⩯ lift_ktree id. +Proof. + unfold id_ktree, lift_ktree; reflexivity. +Qed. + +Fact compose_lift_ktree {A B C} (ab : A -> B) (bc : B -> C) : + (@lift_ktree E _ _ ab >=> lift_ktree bc) ⩯ (lift_ktree (bc ∘ ab)). +Proof. + intros a. + unfold lift_ktree, ITree.cat. + rewrite ret_bind_. + reflexivity. +Qed. + +Fact compose_lift_ktree_l {A B C D} (f: A -> B) (g: B -> C) (k: ktree E C D) : + (lift_ktree f >=> (lift_ktree g >=> k)) ⩯ (lift_ktree (g ∘ f) >=> k). +Proof. + rewrite <- compose_ktree_assoc. + rewrite compose_lift_ktree. + reflexivity. +Qed. + +Fact compose_lift_ktree_r {A B C D} (f: B -> C) (g: C -> D) (k: ktree E A B) : + ((k >=> lift_ktree f) >=> lift_ktree g) ⩯ (k >=> lift_ktree (g ∘ f)). +Proof. + rewrite compose_ktree_assoc. + rewrite compose_lift_ktree. + reflexivity. +Qed. + +Fact lift_compose_ktree {A B C}: forall (f:A -> B) (bc: ktree E B C), + lift_ktree f >=> bc ⩯ fun a => bc (f a). +Proof. + intros; intro a. + unfold lift_ktree, ITree.cat. + rewrite ret_bind_. reflexivity. +Qed. + +Fact compose_ktree_lift {A B C}: forall (ab: ktree E A B) (g:B -> C), + eq_ktree (ab >=> lift_ktree g) + (fun a => ITree.map g (ab a)). +Proof. + intros; intro a. + unfold ITree.map. + apply eutt_bind. + reflexivity. + intro; reflexivity. +Qed. + +Lemma sym_ktree_unfold {A B}: + lift_ktree sum_comm ⩯ @sym_ktree E A B. +Proof. + reflexivity. +Qed. + +End LiftLaws. + +Section MonoidalCategoryLaws. + +Context {E : Type -> Type}. + +(** *** [associators] *) +Lemma assoc_lr {A B C} : + @assoc_ktree_l E A B C >=> assoc_ktree_r ⩯ id_ktree. +Proof. + unfold assoc_ktree_l, assoc_ktree_r. + rewrite compose_lift_ktree. + intros [| []]; reflexivity. +Qed. + +Lemma assoc_rl {A B C} : + @assoc_ktree_r E A B C >=> assoc_ktree_l ⩯ id_ktree. +Proof. + unfold assoc_ktree_l, assoc_ktree_r. + rewrite compose_lift_ktree. + intros [[]|]; reflexivity. +Qed. + +(** *** [sum_elim] lemmas *) + +Fact compose_sum_elim {A B C D} (ac : ktree E A C) (bc : ktree E B C) (cd : ktree E C D) : + sum_elim ac bc >=> cd ⩯ sum_elim (ac >=> cd) (bc >=> cd). +Proof. + intros; intros []; + (unfold ITree.map; simpl; apply eutt_bind; reflexivity). +Qed. + +Fact lift_sum_elim {A B C} (ac : A -> C) (bc : B -> C) : + sum_elim (@lift_ktree E _ _ ac) (lift_ktree bc) + ⩯ lift_ktree (sum_elim ac bc). +Proof. + intros []; reflexivity. +Qed. + +(** *** [Unitors] lemmas *) + +(* TODO: replacing l by λ breaks PG (retracts like crazy, or if you go too far it can't retract at all from the second lemma) (ρ is fine, interestingly) *) +Lemma elim_l_ktree {A B: Type} (ab: @ktree E A (I + B)) : + ab >=> λ_ktree ⩯ (fun a: A => ITree.map sum_empty_l (ab a)). +Proof. + intros; apply compose_ktree_lift. +Qed. + +Lemma elim_l_ktree' {A B: Type} (f: @ktree E (I + A) (I + B)) : + λ_ktree' >=> f ⩯ fun a => f (inr a). +Proof. + repeat intro. + unfold λ_ktree', ITree.cat, lift_ktree. + rewrite ret_bind_; reflexivity. +Qed. + +Lemma elim_ρ_ktree' {A B: Type} (f: @ktree E (A + I) (B + I)) : + ρ_ktree' >=> f ⩯ fun a => f (inl a). +Proof. + repeat intro. + unfold ρ_ktree', ITree.cat, lift_ktree. + rewrite ret_bind_; reflexivity. +Qed. + +Lemma elim_ρ_ktree {A B: Type} (ab: @ktree E A (B + I)) : + ab >=> ρ_ktree ⩯ (fun a: A => ITree.map sum_empty_r (ab a)). +Proof. + intros; apply compose_ktree_lift. +Qed. + +(** *** [tensor] lemmas *) + +Global Instance eq_ktree_tensor {A B C D}: + Proper (eq_ktree ==> eq_ktree ==> eq_ktree) (@tensor_ktree E A B C D). +Proof. + intros ac ac' eqac bd bd' eqbd. + unfold tensor_ktree. + rewrite eqac, eqbd; reflexivity. +Qed. + +Fact tensor_id_lift {A B C} (f : B -> C) : + (@id_ktree E A) ⊗ (lift_ktree f) ⩯ lift_ktree (sum_bimap id f). +Proof. + unfold tensor_ktree. + rewrite compose_lift_ktree, id_ktree_left. + rewrite lift_sum_elim. + reflexivity. +Qed. + +Fact tensor_lift_id {A B C} (f : A -> B) : + (lift_ktree f) ⊗ (@id_ktree E C) ⩯ lift_ktree (sum_bimap f id). +Proof. + unfold tensor_ktree. + rewrite compose_lift_ktree, id_ktree_left. + rewrite lift_sum_elim. + reflexivity. +Qed. + +Lemma tensor_id {A B} : + id_ktree ⊗ id_ktree ⩯ @id_ktree E (A + B). +Proof. + unfold tensor_ktree, ITree.cat, id_ktree. + intros []; cbn; rewrite ret_bind_; reflexivity. +Qed. + +Lemma assoc_I {A B}: + @assoc_ktree_r E A I B >=> id_ktree ⊗ λ_ktree ⩯ ρ_ktree ⊗ id_ktree. +Proof. + unfold ρ_ktree,λ_ktree. + rewrite tensor_lift_id, tensor_id_lift. + unfold assoc_ktree_r. + rewrite compose_lift_ktree. + apply eq_lift_ktree. + intros [[|]|]; compute; try reflexivity. + destruct i. +Qed. + +Lemma cat_tensor {A1 A2 A3 B1 B2 B3} + (f1 : ktree E A1 A2) (f2 : ktree E A2 A3) + (g1 : ktree E B1 B2) (g2 : ktree E B2 B3) : + (f1 ⊗ g1) >=> (f2 ⊗ g2) ⩯ (f1 >=> f2) ⊗ (g1 >=> g2). +Proof. + unfold tensor_ktree, ITree.cat, lift_ktree; simpl. + intros []; simpl; + rewrite !bind_bind; setoid_rewrite ret_bind_; reflexivity. +Qed. + +Lemma sum_elim_compose {A B C D F} + (ac: ktree E A (C + D)) (bc: ktree E B (C + D)) + (cf: ktree E C F) (df: ktree E D F) : + sum_elim ac bc >=> sum_elim cf df + ⩯ sum_elim (ac >=> (sum_elim cf df)) (bc >=> (sum_elim cf df)). +Proof. + intros. + unfold ITree.map. + intros []; reflexivity. +Qed. + +Lemma inl_sum_elim {A B C} (ac: ktree E A C) (bc: ktree E B C) : + lift_ktree inl >=> sum_elim ac bc ⩯ ac. +Proof. + intros. + unfold ITree.cat, lift_ktree. + intros ?. + rewrite ret_bind_. + reflexivity. +Qed. + +Lemma inr_sum_elim {A B C} (ac: ktree E A C) (bc: ktree E B C) : + lift_ktree inr >=> sum_elim ac bc ⩯ bc. +Proof. + intros. + unfold ITree.cat, lift_ktree. + intros ?. + rewrite ret_bind_. + reflexivity. +Qed. + +Lemma tensor_ktree_slide {A B C D} (ac: ktree E A C) (bd: ktree E B D) : + ac ⊗ bd ⩯ ac ⊗ id_ktree >=> id_ktree ⊗ bd. +Proof. + intros. + unfold tensor_ktree. + repeat rewrite id_ktree_left. + rewrite sum_elim_compose. + rewrite compose_ktree_assoc. + rewrite inl_sum_elim, inr_sum_elim. + reflexivity. +Qed. + +Lemma assoc_coherent_r {A B C D}: + @assoc_ktree_r E A B C ⊗ @id_ktree E D + >=> assoc_ktree_r + >=> id_ktree ⊗ assoc_ktree_r + ⩯ assoc_ktree_r >=> assoc_ktree_r. +Proof. + unfold tensor_ktree, assoc_ktree_r. + repeat rewrite id_ktree_left. + repeat rewrite compose_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + apply eq_lift_ktree. + intros [[[|]|]|]; reflexivity. +Qed. + +Lemma assoc_coherent_l {A B C D}: + @id_ktree E A ⊗ @assoc_ktree_l E B C D + >=> assoc_ktree_l + >=> assoc_ktree_l ⊗ id_ktree + ⩯ assoc_ktree_l >=> assoc_ktree_l. +Proof. + unfold tensor_ktree, assoc_ktree_l. + repeat rewrite id_ktree_left. + repeat rewrite compose_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + repeat rewrite compose_lift_ktree. + rewrite lift_sum_elim. + apply eq_lift_ktree. + intros [|[|[|]]]; reflexivity. +Qed. + +(** *** [sym] lemmas *) + +Lemma sym_unit_ktree {A} : + sym_ktree >=> λ_ktree ⩯ @ρ_ktree E A. +Proof. + unfold sym_ktree, ρ_ktree, λ_ktree. + rewrite lift_compose_ktree. + intros []; simpl; reflexivity. +Qed. + +Lemma sym_assoc_ktree {A B C}: + @assoc_ktree_r E A B C >=> sym_ktree >=> assoc_ktree_r + ⩯ (sym_ktree ⊗ id_ktree) >=> assoc_ktree_r >=> (id_ktree ⊗ sym_ktree). +Proof. + unfold assoc_ktree_r, sym_ktree. + rewrite tensor_lift_id, tensor_id_lift. + repeat rewrite compose_lift_ktree. + apply eq_lift_ktree. + intros [[|]|]; compute; reflexivity. +Qed. + +Lemma sym_nilpotent {A B: Type}: + sym_ktree >=> sym_ktree ⩯ @id_ktree E (A + B). +Proof. + unfold sym_ktree, id_ktree. + rewrite compose_lift_ktree. + unfold compose. + unfold lift_ktree; intros a. + setoid_rewrite iso_ff'; reflexivity. +Qed. + +Lemma tensor_swap {A B C D} (ab : ktree E A B) (cd : ktree E C D) : + ab ⊗ cd ⩯ (sym_ktree >=> cd ⊗ ab >=> sym_ktree). +Proof. + unfold tensor_ktree. + unfold sym_ktree. + rewrite !(compose_ktree_lift cd), !(compose_ktree_lift ab), !lift_compose_ktree, !compose_ktree_lift. + intros []; cbn; rewrite map_map; cbn; + apply eutt_map; try intros []; reflexivity. +Qed. + +End MonoidalCategoryLaws. + +(** *** Traced monoidal categories *) + +Section TraceLaws. + +Context {E : Type -> Type}. + +(** *** [loop] lemmas *) + +Global Instance eq_ktree_loop {I A B} : + Proper (eq_ktree ==> eq_ktree) (@loop E I A B). +Proof. + repeat intro; apply eutt_loop; auto. +Qed. + +(* Naturality of (loop_ktree I A B) in A *) +(* Or more diagrammatically: +[[ + +-----+ + | ### | + +-###-+I +A----B----###----C + ### + +is equivalent to: + + +----------+ + | ### | + +------###-+I +A----B----###----C + ### + +]] + *) + +Lemma compose_loop {I A B C} + (bc_: ktree E (I + B) (I + C)) (ab: ktree E A B) : + loop ((id_ktree ⊗ ab) >=> bc_) + ⩯ ab >=> loop bc_. +Proof. + intros a. + rewrite (loop_natural_l ab bc_ a). + apply eutt_loop; [intros [] | reflexivity]. + all: unfold tensor_ktree, sym_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, id_ktree, lift_ktree; simpl. + - rewrite bind_bind, ret_bind_; reflexivity. + - rewrite bind_bind, map_bind. + setoid_rewrite ret_bind_; reflexivity. +Qed. + +(* Naturality of (loop I A B) in B *) +(* Or more diagrammatically: +[[ + +-----+ + | ### | + +-###-+I +A----###----B----C + ### + +is equivalent to: + + +----------+ + | ### | + +-###------+I +A----###----B----C + ### + +]] + *) + +Lemma loop_compose {I A B B'} + (ab_: ktree E (I + A) (I + B)) (bc: ktree E B B') : + loop (ab_ >=> (id_ktree ⊗ bc)) + ⩯ loop ab_ >=> bc. +Proof. + intros a. + rewrite (loop_natural_r bc ab_ a). + apply eutt_loop; [intros [] | reflexivity]. + all: unfold tensor_ktree, sym_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, id_ktree, lift_ktree; simpl. + - apply eutt_bind; [reflexivity | intros []; simpl]. + rewrite ret_bind_; reflexivity. + reflexivity. + - apply eutt_bind; [reflexivity | intros []; simpl]. + rewrite ret_bind_; reflexivity. + reflexivity. +Qed. + +(* Dinaturality of (loop I A B) in I *) + +Lemma loop_rename_internal {I J A B} + (ab_: ktree E (I + A) (J + B)) (ji: ktree E J I) : + loop (ab_ >=> (ji ⊗ id_ktree)) + ⩯ loop ((ji ⊗ id_ktree) >=> ab_). +Proof. + unfold tensor_ktree, ITree.cat, lift_ktree, sum_elim. + + assert (EQ:forall (x: J + B), + match x with + | inl a => a0 <- ji a;; Ret (inl a0) + | inr b => a <- id_ktree b;; Ret (inr a) + end ≈ + match x with + | inl a => Tau (ITree.map (@inl I B) (ji a)) + | inr b => Ret (inr b) + end). + { + intros []. + symmetry; apply tau_eutt. + unfold id_ktree. + rewrite ret_bind_; reflexivity. + } + intros ?. + setoid_rewrite EQ. + rewrite loop_dinatural. + apply eutt_loop; [intros [] | reflexivity]. + all: unfold id_ktree. + all: repeat rewrite bind_bind. + 2: repeat rewrite ret_bind_; reflexivity. + apply eutt_bind; [reflexivity | intros ?]. + apply eutt_bind; [| intros ?; reflexivity]. + apply tau_eutt. +Qed. + +(* Loop over the empty set can be erased *) +Lemma vanishing_ktree {A B: Type} (f: ktree E (I + A) (I + B)) : + loop f ⩯ λ_ktree' >=> f >=> λ_ktree. +Proof. + intros a. + rewrite vanishing1. + unfold λ_ktree,λ_ktree'. + unfold ITree.cat, ITree.map, lift_ktree. + rewrite bind_bind. + rewrite ret_bind_. + reflexivity. +Qed. + +(* [loop_loop]: + +These two loops: + +[[ + +----------+ + | +-----+ | + | | ### | | + | +-###-+I | + +---###----+J + A-----###-------B + ### +]] + +... can be rewired as a single one: + + +[[ + +-------+ + | ### | + +--###--+(I+J) + +--###--+ + A-----###-----B + ### +]] + + *) + +Lemma loop_loop {I J A B} (ab__: ktree E (I + (J + A)) (I + (J + B))) : + loop (loop ab__) + ⩯ loop (assoc_ktree_r >=> ab__ >=> assoc_ktree_l). +Proof. + intros a. + rewrite vanishing2. + apply eutt_loop; [intros [[]|] | reflexivity]. + all: unfold ITree.map, ITree.cat, assoc_ktree_r, assoc_ktree_l, lift_ktree; cbn. + all: rewrite bind_bind. + all: rewrite ret_bind_. + all: reflexivity. +Qed. + +Lemma fold_map {R S}: + forall (f: R -> S) (t: itree E R), + (x <- t;; Ret (f x)) ≅ (ITree.map f t). +Proof. + intros; reflexivity. +Qed. + +Lemma tensor_ktree_loop {I A B C D} + (ab : ktree E (I + A) (I + B)) (cd : ktree E C D) : + (loop ab) ⊗ cd + ⩯ loop (assoc_ktree_l >=> (ab ⊗ cd) >=> assoc_ktree_r). +Proof. + unfold tensor_ktree, ITree.cat, assoc_ktree_l, assoc_ktree_r, lift_ktree, sum_elim. + intros []; simpl. + all:setoid_rewrite bind_bind. + all:setoid_rewrite ret_bind_. + all:rewrite fold_map. + 1:rewrite (@superposing1 E A B I C D). + 2:rewrite (@superposing2 E A B I C D). + all:unfold sum_bimap, ITree.map, sum_assoc_r,sum_elim; cbn. + all:apply eutt_loop; [intros [| []]; cbn | reflexivity]. + all: setoid_rewrite bind_bind. + all:setoid_rewrite ret_bind_. + all:reflexivity. +Qed. + +Lemma yanking_ktree {A: Type}: + loop sym_ktree ⩯ @id_ktree E A. +Proof. + unfold sym_ktree, lift_ktree. + intros ?; rewrite yanking. + apply tau_eutt. +Qed. + +Lemma loop_rename_internal' {I J A B} (ij : ktree E I J) (ji: ktree E J I) + (ab_: @ktree E (I + A) (I + B)) : + (ij >=> ji) ⩯ id_ktree -> + loop ((ji ⊗ id_ktree) >=> ab_ >=> (ij ⊗ id_ktree)) + ⩯ loop ab_. +Proof. + intros Hij. + rewrite loop_rename_internal. + rewrite <- compose_ktree_assoc. + rewrite cat_tensor. + rewrite Hij. + rewrite id_ktree_left. + rewrite tensor_id. + rewrite id_ktree_left. + reflexivity. +Qed. + +End TraceLaws. + +Hint Rewrite @compose_ktree_assoc : lift_ktree. +Hint Rewrite @tensor_id_lift : lift_ktree. +Hint Rewrite @tensor_lift_id : lift_ktree. +Hint Rewrite @lift_sum_elim : lift_ktree. + +(* Here we show that we can implement [ITree.cat] using + [tensor_ktree], [loop], and composition with the monoidal + natural isomorphisms. *) +Section CatFromLoop. + +Variable E : Type -> Type. + +Theorem cat_from_loop {A B C} (ab : ktree E A B) (bc : ktree E B C) : + loop (sym_ktree >=> ab ⊗ bc) ⩯ ab >=> bc. +Proof. + rewrite tensor_ktree_slide. + rewrite <- compose_ktree_assoc. + rewrite loop_compose. + rewrite tensor_swap. + repeat rewrite <- compose_ktree_assoc. + rewrite sym_nilpotent, id_ktree_left. + rewrite compose_loop. + erewrite yanking_ktree. + rewrite id_ktree_right. + reflexivity. +Qed. + +End CatFromLoop. From 99149c191ff54605df8ab93d44209b65e0d3ad90 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 1 Mar 2019 04:08:54 -0500 Subject: [PATCH 136/142] Removed trailing Set Implicit Argument --- examples/Imp2AsmCorrectness.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index de5a2d74..69581883 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -107,6 +107,8 @@ Ltac inv h := inversion h; subst; clear h. Section alistFacts. + (* Generic facts about alists. To eventually move to ExtLib. *) + Arguments alist_find {_ _ _ _}. Definition alist_In {K R RD V} k m v := @alist_find K R RD V k m = Some v. @@ -123,7 +125,6 @@ Section alistFacts. forall k v (m: alist K V), alist_In k (alist_add k v m) v. Proof. - Set Printing Implicit. intros; unfold alist_add, alist_In; simpl; flatten_goal; [reflexivity | rewrite <- neg_rel_dec_correct in Heq; tauto]. Qed. From cf1dadff2bcf6e096d7226177d0ded589d65fd6e Mon Sep 17 00:00:00 2001 From: Lysxia Date: Fri, 1 Mar 2019 16:41:44 -0500 Subject: [PATCH 137/142] Move eq_notauF to Untaus --- theories/Eq/Untaus.v | 214 ++++++++++++++++++++++++++++++ theories/Eq/UpToTausExplicit.v | 235 +-------------------------------- 2 files changed, 215 insertions(+), 234 deletions(-) diff --git a/theories/Eq/Untaus.v b/theories/Eq/Untaus.v index fb67db2d..8e925501 100644 --- a/theories/Eq/Untaus.v +++ b/theories/Eq/Untaus.v @@ -317,3 +317,217 @@ Ltac auto_untaus := assert_fails (unify Y Z); replace Z with Y in * by apply (unalltaus_injective _ _ _ H1 H2) end; auto. + +Section NOTAU. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + + +(* Equivalence between visible steps of computation (i.e., [Vis] or + [Ret], parameterized by a relation [euttE] between continuations + in the [Vis] case. *) +Variant eq_notauF {I J} (euttE : I -> J -> Prop) +: itreeF E R1 I -> itreeF E R2 J -> Prop := +| Eutt_ret : forall r1 r2, + RR r1 r2 -> + eq_notauF euttE (RetF r1) (RetF r2) +| Eutt_vis : forall u (e : E u) k1 k2, + (forall x, euttE (k1 x) (k2 x)) -> + eq_notauF euttE (VisF e k1) (VisF e k2). +Hint Constructors eq_notauF. + +(* Paco takes the greatest fixpoints of monotone relations. *) + +Lemma monotone_eq_notauF : forall I J (r r' : I -> J -> Prop) x1 x2 + (IN: eq_notauF r x1 x2) + (LE: r <2= r'), + eq_notauF r' x1 x2. +Proof. pmonauto. Qed. +Hint Resolve monotone_eq_notauF. + +Lemma eq_notauF_vis_inv1 {I J} {euttE : I -> J -> Prop} {U} + ot (e : E U) k : + eq_notauF euttE ot (VisF e k) -> + exists k', + ot = VisF e k' /\ (forall x, euttE (k' x) (k x)). +Proof. + intros. remember (VisF e k) as t. + inversion H; subst; try discriminate. + inversion H2; subst; auto_inj_pair2; subst; eauto. +Qed. + + +Lemma eq_unalltaus (t1 : itree E R1) (t2 : itree E R2) ot1' + (FT: unalltausF (observe t1) ot1') + (EQV: eq_itree RR t1 t2) : + exists ot2', unalltausF (observe t2) ot2'. +Proof. + genobs t1 ot1. revert t1 Heqot1 t2 EQV. + destruct FT as [Huntaus Hnotau]. + induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. + - eexists. constructor; eauto. inv EQV; simpl; eauto. + - inv EQV; simpobs; try inv Heqot1. + pclearbot. edestruct IHHuntaus as [? []]; eauto. +Qed. + +Lemma eq_unalltaus_eqF (t : itree E R1) (s : itree E R2) ot' + (UNTAUS : unalltausF (observe t) ot') + (EQV: eq_itree RR t s) : + exists os', unalltausF (observe s) os' /\ eq_itreeF RR (eq_itree RR) ot' os'. +Proof. + destruct UNTAUS as [Huntaus Hnotau]. + remember (observe t) as ot. revert s t Heqot EQV. + induction Huntaus; intros; punfold EQV; unfold_eq_itree. + - eexists (observe s). split. + inv EQV; simpobs; eauto. + subst; eauto. + eapply eq_itreeF_mono; eauto. + intros ? ? [| []]; eauto. + - inv EQV; simpobs; inversion Heqot; subst. + destruct REL as [| []]. + edestruct IHHuntaus as [? [[]]]; eauto 10. +Qed. + +Lemma eq_unalltaus_eq (t : itree E R1) (s : itree E R2) t' + (UNTAUS : unalltausF (observe t) (observe t')) + (EQV: eq_itree RR t s) : + exists s', unalltausF (observe s) (observe s') /\ eq_itree RR t' s'. +Proof. + eapply eq_unalltaus_eqF in UNTAUS; try eassumption. + destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. + pfold. eapply eq_itreeF_mono; eauto. +Qed. + +End NOTAU. + +Hint Resolve monotone_eq_notauF. +Hint Constructors eq_notauF. + +(** *** [eq_notauF] lemmas *) + +Lemma eq_notauF_and {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (euttE1 euttE2 euttE : I -> J -> Prop) : + (forall t1 t2, euttE1 t1 t2 -> euttE2 t1 t2 -> euttE t1 t2) -> + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF RR euttE1 ot1 ot2 -> eq_notauF RR euttE2 ot1 ot2 -> + eq_notauF RR euttE ot1 ot2. +Proof. + intros ? ? ? [] Hen2; inversion Hen2; auto. + auto_inj_pair2; subst; auto. +Qed. + +Lemma eq_notauF_flip {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} + (euttE : I -> J -> Prop) : + forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), + eq_notauF (flip RR) (flip euttE) ot2 ot1 -> + eq_notauF RR euttE ot1 ot2. +Proof. + intros ? ? []; auto. +Qed. + +Delimit Scope euttE_scope with euttE. + +(** ** Generalized symmetry and transitivity *) + +Lemma Symmetric_eq_notauF_ {E R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + {I J} (r1 : I -> J -> Prop) (r2 : J -> I -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J) : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot1. +Proof. intros []; auto. Qed. + +Lemma Transitive_eq_notauF_ {E R1 R2 R3} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) + (RR3 : R1 -> R3 -> Prop) + {I J K} (r1 : I -> J -> Prop) (r2 : J -> K -> Prop) + (r3 : I -> K -> Prop) + (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) + (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) + (ot1 : itreeF E R1 I) ot2 ot3 : + eq_notauF RR1 r1 ot1 ot2 -> + eq_notauF RR2 r2 ot2 ot3 -> + eq_notauF RR3 r3 ot1 ot3. +Proof. + intros [] I2; inversion I2; eauto. + auto_inj_pair2; subst; eauto. +Qed. + +Section NOTAU_rel. + +Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). + +(* Reflexivity of [eq_notauF], modulo a few assumptions. *) +Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) : + Reflexive eq_ -> + forall (ot : itreeF E R I), notauF ot -> eq_notauF RR eq_ ot ot. +Proof. + intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. +Qed. + +Global Instance Symmetric_eq_notauF `{Symmetric _ RR} I (eq_ : I -> I -> Prop) : + Symmetric eq_ -> Symmetric (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Symmetric_eq_notauF_; eauto. +Qed. + +Global Instance Transitive_eq_notauF `{Transitive _ RR} I (eq_ : I -> I -> Prop) : + Transitive eq_ -> Transitive (@eq_notauF E _ _ RR _ _ eq_). +Proof. + repeat intro. eapply Transitive_eq_notauF_; eauto. +Qed. + +End NOTAU_rel. + +Global Instance eq_itree_notauF {E R} : + Proper (going (@eq_itree E R _ eq) ==> flip impl) notauF. +Proof. + intros ? ? [] ?; punfold H. inv H; simpl in *; subst; eauto. +Qed. + +Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) (observe t')), + untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). +Proof. + intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. + induction UNTAUS; intros; subst. + - rewrite !unfold_bind; simpobs; eauto. + - rewrite unfold_bind. simpobs. cbn. eauto. +Qed. + +Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) + (UNTAUS: untausF (observe t) t'), + untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). +Proof. + intros; eapply untaus_bind; eauto. +Qed. + +Lemma finite_taus_bind_fst {E R S} + (t : itree E R) (f : R -> itree E S) : + finite_taus (ITree.bind t f) -> finite_taus t. +Proof. + intros [tf' [TAUS PROP]]. + genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. + induction TAUS; intros; subst. + - rewrite unfold_bind in PROP. + genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. + rewrite unfold_bind in Heqobtf. simpobs. inv Heqobtf. unfold_bind. + eapply finite_taus_tau; eauto. +Qed. + +Lemma finite_taus_bind {E R S} + (t : itree E R) (f : R -> itree E S) + (FINt: finite_tausF (observe t)) + (FINk: forall v, finite_tausF (observe (f v))): + finite_tausF (observe (ITree.bind t f)). +Proof. + rewrite unfold_bind. + genobs t ot. clear Heqot t. + destruct FINt as [ot' [UNT NOTAU]]. + induction UNT; subst. + - destruct ot0; inv NOTAU; simpl; eauto 7. + - apply finite_taus_tau. eauto. +Qed. diff --git a/theories/Eq/UpToTausExplicit.v b/theories/Eq/UpToTausExplicit.v index 2c1ea19d..1474689d 100644 --- a/theories/Eq/UpToTausExplicit.v +++ b/theories/Eq/UpToTausExplicit.v @@ -39,50 +39,6 @@ Section EUTT. Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -(* Equivalence between visible steps of computation (i.e., [Vis] or - [Ret], parameterized by a relation [euttE] between continuations - in the [Vis] case. *) -Variant eq_notauF {I J} (euttE : I -> J -> Prop) -: itreeF E R1 I -> itreeF E R2 J -> Prop := -| Eutt_ret : forall r1 r2, - RR r1 r2 -> - eq_notauF euttE (RetF r1) (RetF r2) -| Eutt_vis : forall u (e : E u) k1 k2, - (forall x, euttE (k1 x) (k2 x)) -> - eq_notauF euttE (VisF e k1) (VisF e k2). -Hint Constructors eq_notauF. - -Lemma eq_notauF_vis_inv1 {I J} {euttE : I -> J -> Prop} {U} - ot (e : E U) k : - eq_notauF euttE ot (VisF e k) -> - exists k', - ot = VisF e k' /\ (forall x, euttE (k' x) (k x)). -Proof. - intros. remember (VisF e k) as t. - inversion H; subst; try discriminate. - inversion H2; subst; auto_inj_pair2; subst; eauto. -Qed. - -(* -Variant eq_notauF' {I} (euttE : relation I) -: relation (itreeF E R I) := -| Eutt_ret' : forall r, eq_notauF' euttE (RetF r) (RetF r) -| Eutt_vis' : forall {u1 u2} (e1 : E u1) (e2 : E u2) k1 k2, - eq_dep _ E _ e1 _ e2 -> - (forall x1 x2, JMeq x1 x2 -> euttE (k1 x1) (k2 x2)) -> - eq_notauF' euttE (VisF e1 k1) (VisF e2 k2). -Hint Constructors eq_notauF'. - -Lemma eq_notauF_eq_eq_notauF': forall I (euttE : relation I) t s, - eq_notauF euttE t s <-> eq_notauF' euttE t s. -Proof. - split; intros EUTT; destruct EUTT; eauto. - - econstructor; intros; subst; eauto. - - assert (u1 = u2) by (inv H; eauto). - subst. apply eq_dep_eq in H. subst. eauto. -Qed. -*) - (* [euttE_ euttE t1 t2] means that, if [t1] or [t2] ever takes a visible step ([Vis] or [Ret]), then the other takes the same step, and the subsequent continuations (in the [Vis] case) are @@ -98,7 +54,7 @@ Inductive euttEF (euttE : itree E R1 -> itree E R2 -> Prop) (EQV: forall ot1' ot2' (UNTAUS1: unalltausF ot1 ot1') (UNTAUS2: unalltausF ot2 ot2'), - eq_notauF euttE ot1' ot2') + eq_notauF RR euttE ot1' ot2') . Hint Constructors euttEF. @@ -107,15 +63,6 @@ Definition euttE_ (euttE : itree E R1 -> itree E R2 -> Prop) euttEF euttE (observe t1) (observe t2). Hint Unfold euttE_. -(* Paco takes the greatest fixpoints of monotone relations. *) - -Lemma monotone_eq_notauF : forall I J (r r' : I -> J -> Prop) x1 x2 - (IN: eq_notauF r x1 x2) - (LE: r <2= r'), - eq_notauF r' x1 x2. -Proof. pmonauto. Qed. -Hint Resolve monotone_eq_notauF. - (* [euttE_] is monotone. *) Lemma monotone_euttE_ : monotone2 euttE_. Proof. pmonauto. Qed. @@ -206,47 +153,6 @@ Qed. (**) -Lemma eq_unalltaus (t1 : itree E R1) (t2 : itree E R2) ot1' - (FT: unalltausF (observe t1) ot1') - (EQV: eq_itree RR t1 t2) : - exists ot2', unalltausF (observe t2) ot2'. -Proof. - genobs t1 ot1. revert t1 Heqot1 t2 EQV. - destruct FT as [Huntaus Hnotau]. - induction Huntaus; intros; punfold EQV; unfold_eq_itree; subst. - - eexists. constructor; eauto. inv EQV; simpl; eauto. - - inv EQV; simpobs; try inv Heqot1. - pclearbot. edestruct IHHuntaus as [? []]; eauto. -Qed. - -Lemma eq_unalltaus_eqF (t : itree E R1) (s : itree E R2) ot' - (UNTAUS : unalltausF (observe t) ot') - (EQV: eq_itree RR t s) : - exists os', unalltausF (observe s) os' /\ eq_itreeF RR (eq_itree RR) ot' os'. -Proof. - destruct UNTAUS as [Huntaus Hnotau]. - remember (observe t) as ot. revert s t Heqot EQV. - induction Huntaus; intros; punfold EQV; unfold_eq_itree. - - eexists (observe s). split. - inv EQV; simpobs; eauto. - subst; eauto. - eapply eq_itreeF_mono; eauto. - intros ? ? [| []]; eauto. - - inv EQV; simpobs; inversion Heqot; subst. - destruct REL as [| []]. - edestruct IHHuntaus as [? [[]]]; eauto 10. -Qed. - -Lemma eq_unalltaus_eq (t : itree E R1) (s : itree E R2) t' - (UNTAUS : unalltausF (observe t) (observe t')) - (EQV: eq_itree RR t s) : - exists s', unalltausF (observe s) (observe s') /\ eq_itree RR t' s'. -Proof. - eapply eq_unalltaus_eqF in UNTAUS; try eassumption. - destruct UNTAUS as [os' []]. eexists (go os'); split; eauto. - pfold. eapply eq_itreeF_mono; eauto. -Qed. - Lemma euttE_Ret x y : RR x y -> euttE (Ret x) (Ret y). Proof. @@ -279,63 +185,9 @@ End EUTT. Hint Unfold euttE_. Hint Unfold euttE. -Hint Resolve monotone_eq_notauF. -Hint Constructors eq_notauF. Hint Constructors euttEF. Hint Resolve monotone_euttE_ : paco. -(** *** [eq_notauF] lemmas *) - -Lemma eq_notauF_and {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} - (euttE1 euttE2 euttE : I -> J -> Prop) : - (forall t1 t2, euttE1 t1 t2 -> euttE2 t1 t2 -> euttE t1 t2) -> - forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), - eq_notauF RR euttE1 ot1 ot2 -> eq_notauF RR euttE2 ot1 ot2 -> - eq_notauF RR euttE ot1 ot2. -Proof. - intros ? ? ? [] Hen2; inversion Hen2; auto. - auto_inj_pair2; subst; auto. -Qed. - -Lemma eq_notauF_flip {E R1 R2} (RR : R1 -> R2 -> Prop) {I J} - (euttE : I -> J -> Prop) : - forall (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J), - eq_notauF (flip RR) (flip euttE) ot2 ot1 -> - eq_notauF RR euttE ot1 ot2. -Proof. - intros ? ? []; auto. -Qed. - -Delimit Scope euttE_scope with euttE. - -(** ** Generalized symmetry and transitivity *) - -Lemma Symmetric_eq_notauF_ {E R1 R2} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) - {I J} (r1 : I -> J -> Prop) (r2 : J -> I -> Prop) - (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) - (SYM_r : forall i j, r1 i j -> r2 j i) - (ot1 : itreeF E R1 I) (ot2 : itreeF E R2 J) : - eq_notauF RR1 r1 ot1 ot2 -> - eq_notauF RR2 r2 ot2 ot1. -Proof. intros []; auto. Qed. - -Lemma Transitive_eq_notauF_ {E R1 R2 R3} - (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop) - (RR3 : R1 -> R3 -> Prop) - {I J K} (r1 : I -> J -> Prop) (r2 : J -> K -> Prop) - (r3 : I -> K -> Prop) - (TRANS_RR : forall r1 r2 r3, RR1 r1 r2 -> RR2 r2 r3 -> RR3 r1 r3) - (TRANS_r : forall i j k, r1 i j -> r2 j k -> r3 i k) - (ot1 : itreeF E R1 I) ot2 ot3 : - eq_notauF RR1 r1 ot1 ot2 -> - eq_notauF RR2 r2 ot2 ot3 -> - eq_notauF RR3 r3 ot1 ot3. -Proof. - intros [] I2; inversion I2; eauto. - auto_inj_pair2; subst; eauto. -Qed. - Lemma Symmetric_euttEF_ {E R1 R2} (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) @@ -407,26 +259,6 @@ Section EUTT_rel. Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop). -(* Reflexivity of [eq_notauF], modulo a few assumptions. *) -Lemma Reflexive_eq_notauF `{Reflexive _ RR} I (eq_ : I -> I -> Prop) : - Reflexive eq_ -> - forall (ot : itreeF E R I), notauF ot -> eq_notauF RR eq_ ot ot. -Proof. - intros. destruct ot; try contradiction; econstructor; intros; subst; eauto. -Qed. - -Global Instance Symmetric_eq_notauF `{Symmetric _ RR} I (eq_ : I -> I -> Prop) : - Symmetric eq_ -> Symmetric (@eq_notauF E _ _ RR _ _ eq_). -Proof. - repeat intro. eapply Symmetric_eq_notauF_; eauto. -Qed. - -Global Instance Transitive_eq_notauF `{Transitive _ RR} I (eq_ : I -> I -> Prop) : - Transitive eq_ -> Transitive (@eq_notauF E _ _ RR _ _ eq_). -Proof. - repeat intro. eapply Transitive_eq_notauF_; eauto. -Qed. - Global Instance subrelation_eq_euttE : @subrelation (itree E R) (eq_itree RR) (euttE RR). Proof. @@ -562,12 +394,6 @@ Proof. econstructor; intros; left; apply H. Qed. -Global Instance eq_itree_notauF : - Proper (going (@eq_itree E R _ eq) ==> flip impl) notauF. -Proof. - intros ? ? [] ?; punfold H. inv H; simpl in *; subst; eauto. -Qed. - (* If [t1] and [t2] are equivalent, then either both start with finitely many taus, or both [spin]. *) Global Instance euttE_finite_taus : @@ -588,67 +414,8 @@ Proof. pfold. eapply euttEF_tau. reflexivity. reflexivity. punfold H. Qed. -Lemma eq_itree_vis {E R1 R2} (RR : R1 -> R2 -> Prop) - {U} (e : E U) (k1 : U -> itree E R1) (k2 : U -> itree E R2) : - (forall u, eq_itree RR (k1 u) (k2 u)) -> - eq_itree RR (Vis e k1) (Vis e k2). -Proof. - intros; pfold; constructor; left. apply H. -Qed. - -Lemma eq_itree_ret {E R1 R2} (RR : R1 -> R2 -> Prop) r1 r2 : - RR r1 r2 -> @eq_itree E _ _ RR (Ret r1) (Ret r2). -Proof. - intros; pfold; eauto; constructor; auto. -Qed. - (* Lemmas about [bind]. *) -Lemma untaus_bind {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) (observe t')), - untausF (observe (ITree.bind t k)) (observe (ITree.bind t' k)). -Proof. - intros. genobs t ot; genobs t' ot'. revert t Heqot t' Heqot'. - induction UNTAUS; intros; subst. - - rewrite !unfold_bind; simpobs; eauto. - - rewrite unfold_bind. simpobs. cbn. eauto. -Qed. - -Lemma untaus_bindF {E S R} : forall t t' (k: S -> itree E R) - (UNTAUS: untausF (observe t) t'), - untausF (observe (ITree.bind t k)) (observe (ITree.bind (go t') k)). -Proof. - intros; eapply untaus_bind; eauto. -Qed. - -Lemma finite_taus_bind_fst {E R S} - (t : itree E R) (f : R -> itree E S) : - finite_taus (ITree.bind t f) -> finite_taus t. -Proof. - intros [tf' [TAUS PROP]]. - genobs (ITree.bind t f) obtf. move TAUS at top. revert_until TAUS. - induction TAUS; intros; subst. - - rewrite unfold_bind in PROP. - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - - genobs t ot; destruct ot; eauto using finite_taus_ret, finite_taus_vis. - rewrite unfold_bind in Heqobtf. simpobs. inv Heqobtf. unfold_bind. - eapply finite_taus_tau; eauto. -Qed. - -Lemma finite_taus_bind {E R S} - (t : itree E R) (f : R -> itree E S) - (FINt: finite_tausF (observe t)) - (FINk: forall v, finite_tausF (observe (f v))): - finite_tausF (observe (ITree.bind t f)). -Proof. - rewrite unfold_bind. - genobs t ot. clear Heqot t. - destruct FINt as [ot' [UNT NOTAU]]. - induction UNT; subst. - - destruct ot0; inv NOTAU; simpl; eauto 7. - - apply finite_taus_tau. eauto. -Qed. - Inductive euttE_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := | euttE_bind_clo_intro U (t1 t2: itree E U) k1 k2 (EQV: euttE eq t1 t2) From a118dd7c6c61999af7841a9d55f7dbf4ed44cf95 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 1 Mar 2019 19:37:30 -0500 Subject: [PATCH 138/142] Bit of cleaning in the files --- examples/Asm.v | 93 +---------------------------------- examples/Imp.v | 19 ------- examples/Imp2AsmCorrectness.v | 38 +++++++------- 3 files changed, 18 insertions(+), 132 deletions(-) diff --git a/examples/Asm.v b/examples/Asm.v index c3d1fceb..87c6a62c 100644 --- a/examples/Asm.v +++ b/examples/Asm.v @@ -11,7 +11,7 @@ Typeclasses eauto := 5. Section Syntax. Definition var : Set := string. - Definition value : Set := nat. (* this should change *) + Definition value : Set := nat. (** ** Syntax *) @@ -153,12 +153,6 @@ Section Semantics. End with_effect. End Semantics. -(* SAZ: Everything from here down can probably be polished. - - In particular, I'm still not completely happy with how all the different parts - fit together in run. - - *) (* Interpretation ----------------------------------------------------------- *) @@ -198,88 +192,3 @@ Instance RelDec_string : RelDec (@eq string) := Instance RelDec_value : RelDec (@eq value) := { rel_dec := Nat.eqb }. -(* -TODO: FIX - -Definition run (p: asm unit done) : itree emptyE (env * (memory * unit)) := - let eval := Sum1.elim interpret_Locals interpret_Memory in - run_env _ (run_env _ (interp eval _ (denote_asm p tt)) empty) empty. - -*) - -(* SAZ: Note: we should be able to prove that run produces trees that are equivalent - to run' where run' interprets memory and locals in a different order *) - - - -(* -Definition dummy_blk {label: Type}: block label := bbb Bhalt. -Definition arg: string := "arg". -Definition res: string := "res". - -Definition local: string := "R0". - -Section Odd_Even. - - - (* Need to work over Z *) - - Definition even_entry {label: Type}: block label := - bbi (Iload local (Ovar arg)) - (bbb (Bbrz local Eend Ebody)). - Definition even_body {label: Type}: block label := - bbi (Iload local (Ovar arg)) - (bbb (Bbrz local Eend Ebody)). - - - - -End Odd_Even. - -Section Fact. - Definition Fentry := 1. - Definition Fbody := 2. - Definition Fend := 3. - - (* Need to work over Z *) - Definition fact_entry {label: Type} (Fend Fbody: label): block label := - bbi (Iload local (Ovar arg)) - (bbi (Iadd arg arg (Oimm -1) - (bbi (Istore res (Oimm 0)) - (bbb (Bbrz local Fend Fbody))). - - Definition fact_body {label: Type} (Fbody: label): block label := - bbi (Iload local (Ovar arg)) - (bbb (Bbrz local Fend Fbody)). - - - - Definition fact (n: nat): program := - {| - label:= nat; - blocks := fun n => match n with - | 0 => bbi (Istore arg (Oimm n)) (bbb (Bjmp 1)) - | 1 => dummy_blk - | _ => dummy_blk - end; - main := 0 - |}. - -End Fact. -*) -(* -Module AsmNotations. - - (* TODO *) - Notation "▿ i0 ; .. ; i ; br △" := - (bbi i0 .. (bbi i (bbb br)) ..) - (right associativity). - - Open Scope string_scope. - Definition bar := Imov "x" (Ovar "x"). - Definition foo {label: Type}: @block label := - ▿ bar ; bar ; bar ; Bhalt △. - -End AsmNotations. - -*) diff --git a/examples/Imp.v b/examples/Imp.v index 315a6262..9a63768f 100644 --- a/examples/Imp.v +++ b/examples/Imp.v @@ -157,22 +157,3 @@ Qed. Definition ImpEval (s: stmt): itree emptyE (env * unit) := let p := interp evalLocals _ (denoteStmt s) in run_env _ p empty. - -From ITree Require Import FixFacts MorphismsFacts. - -Lemma while_is_loop {E} (body : itree E bool) : - while body - ≈ loop (fun l : unit + unit => - match l with - | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) - body - | inr _ => Ret (inl tt) (* Enter loop *) - end) tt. -Proof. - unfold while. - apply eutt_loop; [intros [[]|[]]; simpl | reflexivity]. - 2: reflexivity. - unfold ITree.map. - apply eutt_bind; [reflexivity | intros []; reflexivity]. -Qed. - diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 69581883..f59e43bb 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -26,26 +26,6 @@ From ExtLib Require Import Import ListNotations. Open Scope string_scope. -(* - Potential extensions for later: - - Add some non-determinism at the source level, for instance order of evaluation in add, and have the compiler an order. - The correctness would then be a refinement. - How to define it? Likely with respect to an oracle. - - Add a print effect? - - Change languages to map two notions of state at the source down to a single one at the target? - Make the keys of the second env monad as the sum of the two initial ones. - - things to do? - * 1. change the compiler to not compress basic blocks. - * - ideally we would write a separate pass that does that - * - split out each of the structures as separate definitions and lemmas - * 2. need to prove `interp F (denote_block ...) = denote_block ...` - * 3. link_seq_ok should be a proof by co-induction. - * 4. clean up this file *a lot* - * bonus: block fusion - * bonus: break & continue - *) - Section EUTT. Context {E: Type -> Type}. @@ -614,7 +594,23 @@ Section Correctness. repeat rewrite ret_bind_; reflexivity. - rewrite itree_eta; cbn; reflexivity. Qed. - + + Lemma while_is_loop {E} (body : itree E bool) : + while body + ≈ loop (fun l : unit + unit => + match l with + | inl _ => ITree.map (fun b => if b : bool then inl tt else inr tt) + body + | inr _ => Ret (inl tt) (* Enter loop *) + end) tt. + Proof. + unfold while. + apply eutt_loop; [intros [[]|[]]; simpl | reflexivity]. + 2: reflexivity. + unfold ITree.map. + apply eutt_bind; [reflexivity | intros []; reflexivity]. + Qed. + Definition env_lookupDefault_is_lift {K V : Type} {E: Type -> Type} `{envE K V -< E} (x: K) (v: V): env_lookupDefault x v = lift (lookupDefaultE x v). Proof. From a61e3bfcdb0e93e4b2b3d7e4cc67db4355339717 Mon Sep 17 00:00:00 2001 From: Gil Hur Date: Sat, 2 Mar 2019 12:08:43 +0900 Subject: [PATCH 139/142] Change the def of "eutt" so that it provides very strong reasoning principles. --- examples/Imp2AsmCorrectness.v | 75 +++++- theories/Basics_Functions.v | 8 +- theories/Core.v | 2 +- theories/Eq/Eq.v | 51 ++++ theories/Eq/Shallow.v | 2 +- theories/Eq/SimUpToTaus.v | 76 +----- theories/Eq/Untaus.v | 35 --- theories/Eq/UpToTaus.v | 474 +++++++++++++++++++++------------ theories/Eq/UpToTausExplicit.v | 120 ++++++++- theories/FixFacts.v | 100 +++---- theories/Morphisms.v | 12 +- theories/MorphismsFacts.v | 145 ++++------ 12 files changed, 659 insertions(+), 441 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index f59e43bb..50e36c34 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -87,7 +87,56 @@ Ltac inv h := inversion h; subst; clear h. Section alistFacts. + (* Generic facts about alists. To eventually move to ExtLib. *) +(* STASHED + +Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) + (Renv_ : _ -> _ -> Prop) + t1 t2 := + forall g1 g2, + Renv_ g1 g2 -> + eutt (fun a (b : alist var value * R2) => Renv_ (fst a) (fst b) /\ RR (snd a) (snd b)) + (interp_locals t1 g1) + (interp_locals t2 g2). + +Instance eutt_eq_locals (Renv_ : _ -> _ -> Prop) {R} RR : + Proper (eutt eq ==> eutt eq ==> iff) (@eq_locals R R RR Renv_). +Proof. + repeat intro. + split; repeat intro. + - rewrite <- H, <- H0; auto. + - rewrite H, H0; auto. +Qed. + +Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) + {R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) + (RS : S1 -> S2 -> Prop) : + forall t1 t2, + eq_locals RR Renv_ t1 t2 -> + forall k1 k2, + (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> + eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). +Proof. + repeat intro. + rewrite 2 interp_locals_bind. + eapply eutt_bind_gen. + { eapply H; auto. } + intros. eapply H0; destruct H2; auto. +Qed. + +Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : + (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> + eq_locals eq Renv (loop t1 x) (loop t2 x). +Proof. + unfold eq_locals, interp_locals, run_env. + intros. unfold loop. + rewrite 2 interp1_loop. + eapply interp_state_loop; auto. +Qed. + + Set Nested Proofs Allowed. +*) Arguments alist_find {_ _ _ _}. @@ -404,7 +453,7 @@ Section Correctness. eq_locals eq Renv (loop t1 x) (loop t2 x). Proof. unfold eq_locals, interp_locals, run_env. - intros. + intros. unfold loop. rewrite 2 interp1_loop. eapply interp_state_loop; auto. Qed. @@ -503,6 +552,30 @@ Section Correctness. eapply Renv_write_local; eauto. Qed. +(* STASHED + + Lemma sym_den_unfold {E} {A B}: + lift_den sum_comm ⩰ @sym_den E A B. + Proof. + reflexivity. + Qed. + + Lemma seq_linking_den {E} {A B C} (ab : @den E A B) (bc : den B C) : + loop_den (sym_den >=> ab ⊗ bc) ⩰ ab >=> bc. + Proof. + rewrite tensor_den_slide. + rewrite <- compose_den_assoc. + rewrite loop_compose. + rewrite tensor_swap. + repeat rewrite <- compose_den_assoc. + rewrite sym_nilpotent, id_den_left. + rewrite compose_loop. + erewrite yanking_den. + rewrite id_den_right. + reflexivity. + Qed. +*) + Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_ktree (denote_asm (seq_asm ab bc)) (denote_asm ab >=> denote_asm bc). diff --git a/theories/Basics_Functions.v b/theories/Basics_Functions.v index 1a5954e3..7b33dc1a 100644 --- a/theories/Basics_Functions.v +++ b/theories/Basics_Functions.v @@ -166,14 +166,14 @@ Proof. all: auto. Qed. Instance Iso_sum_assoc_l {A B C} : Iso (@sum_assoc_l A B C) sum_assoc_r := {}. Proof. - - destruct 0 as [| []]; auto. - - destruct 0 as [[] |]; auto. + - intros. destruct a as [| []]; auto. + - intros. destruct b as [[] |]; auto. Qed. Instance Iso_sum_assoc_r {A B C} : Iso (@sum_assoc_r A B C) sum_assoc_l := {}. Proof. - - destruct 0 as [[] |]; auto. - - destruct 0 as [| []]; auto. + - intros. destruct a as [[] |]; auto. + - intros. destruct b as [| []]; auto. Qed. Instance Iso_compose {A B C} (f : A -> B) (g : B -> C) diff --git a/theories/Core.v b/theories/Core.v index 4ec8d9c6..f8fd2dab 100644 --- a/theories/Core.v +++ b/theories/Core.v @@ -152,7 +152,7 @@ CoFixpoint spin {E R} : itree E R := Tau spin. (** Repeat a computation infinitely. *) Definition forever {E R S} (t : itree E R) : itree E S := - cofix forever_t := Tau (bind t (fun _ => forever_t)). + cofix forever_t := bind t (fun _ => Tau (forever_t)). (* this definition exists in ExtLib (or should because it is * generic to Monads) diff --git a/theories/Eq/Eq.v b/theories/Eq/Eq.v index 21dacae1..dd9a278a 100644 --- a/theories/Eq/Eq.v +++ b/theories/Eq/Eq.v @@ -18,6 +18,57 @@ From ITree Require Import From ITree Require Export Eq.Shallow. +(* Taken from paco-v2.0.3: BEGIN *) + +Lemma paco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 + (REL: paco2 gf bot2 x0 x1) + (LEgf: gf <3= gf'): + paco2 gf' r' x0 x1. +Proof. + eapply paco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. +Qed. + +Lemma upaco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 + (REL: upaco2 gf bot2 x0 x1) + (LEgf: gf <3= gf'): + upaco2 gf' r' x0 x1. +Proof. + eapply upaco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. +Qed. + +Lemma rclo2_mon_gen {T0 T1} gf gf' (clo clo': rel2 T0 T1 -> rel2 T0 T1) r r' e0 e1 + (REL: rclo2 gf clo r e0 e1) + (LEgf: gf <3= gf') + (LEclo: clo <3= clo') + (LEr: r <2= r') : + rclo2 gf' clo' r' e0 e1. +Proof. + induction REL. + - econstructor 1. apply LEr, R. + - econstructor 2; [intros; eapply H, PR| apply LEclo, CLOR']. + - econstructor 3; [intros; eapply H, PR| apply LEgf, CLOR']. +Qed. + +Arguments paco2_fold {T0 T1} gf. +Arguments paco2_unfold {T0 T1} gf. + +Ltac pfold_reverse := + match goal with + | [|- ?gf (upaco2 _ _) _ _] => eapply (paco2_unfold gf) + | [|- ?gf (?gres (upaco2 _ _)) _ _] => eapply (paco2_unfold (compose gf gres)) + end; eauto with paco. + +Ltac punfold_reverse H := + let PP := type of H in + match PP with + | ?gf (upaco2 _ _) _ _ => eapply (paco2_fold gf) in H + | ?gf (?gres (upaco2 _ _)) _ _ => eapply (paco2_fold (compose gf gres)) in H + end; eauto with paco. + +(* Taken from paco-v2.0.3: END*) + + + (* TODO: Send to paco *) Global Instance Symmetric_bot2 (A : Type) : @Symmetric A bot2. Proof. auto. Qed. diff --git a/theories/Eq/Shallow.v b/theories/Eq/Shallow.v index 16ed7bfe..f2aff5fa 100644 --- a/theories/Eq/Shallow.v +++ b/theories/Eq/Shallow.v @@ -98,7 +98,7 @@ Lemma vis_bind {E R U V} (e: E V) (ek: V -> itree E U) (k: U -> itree E R) : Proof. apply @unfold_bind. Qed. Lemma unfold_forever {E R S} (t: itree E R): - observing eq (@ITree.forever E R S t) (Tau (ITree.bind t (fun _ => ITree.forever t))). + observing eq (@ITree.forever E R S t) (ITree.bind t (fun _ => Tau (ITree.forever t))). Proof. econstructor. reflexivity. Qed. (** ** [going]: Lift relations through [go]. *) diff --git a/theories/Eq/SimUpToTaus.v b/theories/Eq/SimUpToTaus.v index 51cf9213..edc230e3 100644 --- a/theories/Eq/SimUpToTaus.v +++ b/theories/Eq/SimUpToTaus.v @@ -412,77 +412,7 @@ Proof. - eapply EQTAUS. } Qed. -Instance sutt_interp (E F : Type -> Type) (R : Type) : - Proper (Rhom (fun _ => sutt eq) ==> sutt eq ==> sutt eq) - (fun f => @interp E F f R). -Proof. - (* note(gmm): this theorem needs to do up-to reasoning *) - red. red. red. - intros x y Hxy. - intros l r. - do 2 rewrite sutt_is_sutt1. - pcofix CIH. - intros. - eapply sutt_to_sutt1. - { intros; eapply H. } - punfold H0. - pfold. red. - do 2 rewrite unfold_interp. - induction H0; eauto. - { subst. - cbn. constructor. admit. intros. - eapply unalltausF_ret in UNTAUS1. - eapply unalltausF_ret in UNTAUS2. - subst. constructor. reflexivity. } - { cbn. - admit. } - { admit. } - { admit. } -Admitted. - -Instance eutt_interp (E F : Type -> Type) (R : Type) : - Proper (Rhom (fun _ => eutt eq) ==> eutt eq ==> eutt eq) - (fun f => @interp E F f R). -Proof. - do 3 red. intros. - eapply sutt_eutt. - { eapply sutt_interp. - { clear - H. - unfold Rhom in *. - intros; red. - intros. eapply eutt_sutt. - eapply H. } - { eapply eutt_sutt. eapply H0. } } - { eapply Proper_sutt. - { instantiate (1:=eq). - compute. intros. congruence. } - { reflexivity. } - { reflexivity. } - eapply sutt_interp. - { clear - H. - unfold Rhom in *. - intros; red. - intros. eapply eutt_sutt. - eapply Symmetric_eutt; eauto. - eapply H. } - { eapply eutt_sutt. - eapply Symmetric_eutt; eauto. } } -Qed. +(* Instance sutt_interp (E F : Type -> Type) (R : Type) : *) +(* Proper (Rhom (fun _ => sutt eq) ==> sutt eq ==> sutt eq) *) +(* (fun f => @interp E F f R). *) -(** Generalized heterogeneous version of [eutt_bind] *) -Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: - forall t1 t2, - eutt RR t1 t2 -> - forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> - @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). -Proof. - intros. - apply sutt_eutt; eapply sutt_bind_gen. - - apply eutt_sutt. eassumption. - - intros. apply eutt_sutt. apply H0; auto. - - apply eutt_sutt. - eapply Symmetric_eutt_; try eassumption; auto. - intros ? ? HH; apply HH. - - simpl. intros. apply eutt_sutt. - eapply Symmetric_eutt_; try eapply H0; eauto. -Qed. diff --git a/theories/Eq/Untaus.v b/theories/Eq/Untaus.v index 8e925501..19826083 100644 --- a/theories/Eq/Untaus.v +++ b/theories/Eq/Untaus.v @@ -16,41 +16,6 @@ From ITree Require Export Local Open Scope itree. -(* Taken from paco-v2.0.3: BEGIN *) - -Lemma paco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 - (REL: paco2 gf bot2 x0 x1) - (LEgf: gf <3= gf'): - paco2 gf' r' x0 x1. -Proof. - eapply paco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. -Qed. - -Lemma upaco2_mon_bot {T0 T1} (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1 - (REL: upaco2 gf bot2 x0 x1) - (LEgf: gf <3= gf'): - upaco2 gf' r' x0 x1. -Proof. - eapply upaco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR]. -Qed. - -Lemma rclo2_mon_gen {T0 T1} gf gf' (clo clo': rel2 T0 T1 -> rel2 T0 T1) r r' e0 e1 - (REL: rclo2 gf clo r e0 e1) - (LEgf: gf <3= gf') - (LEclo: clo <3= clo') - (LEr: r <2= r') : - rclo2 gf' clo' r' e0 e1. -Proof. - induction REL. - - econstructor 1. apply LEr, R. - - econstructor 2; [intros; eapply H, PR| apply LEclo, CLOR']. - - econstructor 3; [intros; eapply H, PR| apply LEgf, CLOR']. -Qed. - -(* Taken from paco-v2.0.3: END*) - - - Section FiniteTaus. Context {E : Type -> Type} {R : Type}. diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index 0eefc02c..cfdf14e5 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -27,8 +27,7 @@ From Coq Require Import Relations.Relations. From ITree Require Import - Core - UpToTausExplicit. + Core. From ITree Require Export Eq.Eq. @@ -48,7 +47,7 @@ Inductive euttF (RBASE: RR r1 r2): euttF eutt eutt_taus (RetF r1) (RetF r2) | euttF_vis u (e : E u) k1 k2 - (EUTTK: forall x, eutt (k1 x) (k2 x)): + (EUTTK: forall x, eutt (k1 x) (k2 x) \/ eutt_taus (observe (k1 x)) (observe (k2 x))): euttF eutt eutt_taus (VisF e k1) (VisF e k2) | euttF_tau_tau t1 t2 (EQTAUS: eutt_taus (observe t1) (observe t2)): @@ -72,6 +71,7 @@ Lemma euttF_mon r r' s s' x y euttF r' s' x y. Proof. induction EUTT; eauto. + econstructor; intros. edestruct EUTTK; eauto. Qed. Lemma monotone_euttF eutt : monotone2 (euttF eutt). @@ -118,7 +118,7 @@ Global Instance Reflexive_eutt_gen `{Reflexive _ RR} Reflexive (paco2 (eutt_ RR) r). Proof. pcofix CIH. intros. pfold. revert x. pcofix CIH'. intros. - genobs x ox. destruct ox; eauto. + genobs_clear x ox. destruct ox; eauto 7. Qed. Global Instance Reflexive_euttF_gen `{Reflexive _ RR} @@ -138,13 +138,50 @@ Proof. punfold H1. punfold H1. pfold. genobs_clear x ox. genobs_clear y oy. induction H1; pclearbot; eauto. - - econstructor. intros. destruct (EUTTK x); eauto. + - econstructor. intros. + edestruct EUTTK as [TMP | TMP]; destruct TMP; eauto 7; contradiction. - punfold EQTAUS. eauto 8. Qed. End EUTT_homo. -Lemma Symmetric_eutt_ {E R1 R2} +Section EUTT_hetero. + +Context {E : Type -> Type}. + +Lemma Symmetric_euttF_hetero {R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) (r'1 : _ -> _ -> Prop) (r'2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (SYM_r' : forall i j, r'1 i j -> r'2 j i) : + forall (ot1 : itree' E R1) (ot2 : itree' E R2), + euttF RR1 r1 r'1 ot1 ot2 -> euttF RR2 r2 r'2 ot2 ot1. +Proof. + intros. induction H; eauto 7. + econstructor; intros. edestruct EUTTK; eauto 7. +Qed. + +Lemma Symmetric_eutt__hetero {R1 R2} + (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) + (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) (r'1 : _ -> _ -> Prop) (r'2 : _ -> _ -> Prop) + (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) + (SYM_r : forall i j, r1 i j -> r2 j i) + (SYM_r' : forall i j, r'1 i j -> r'2 j i) : + forall (ot1 : itree' E R1) (ot2 : itree' E R2), + paco2 (euttF RR1 r1) r'1 ot1 ot2 -> + paco2 (euttF RR2 r2) r'2 ot2 ot1. +Proof. + pcofix CIH. intros. + pfold. punfold H0. + induction H0; pclearbot; eauto 7. + - econstructor. intros. + edestruct EUTTK; eauto. + destruct H; eauto. + - destruct EQTAUS; eauto. +Qed. + +Lemma Symmetric_eutt_hetero {R1 R2} (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R1 -> Prop) (r1 : _ -> _ -> Prop) (r2 : _ -> _ -> Prop) (SYM_RR : forall r1 r2, RR1 r1 r2 -> RR2 r2 r1) @@ -157,160 +194,209 @@ Proof. pfold. do 2 punfold H0. genobs_clear t1 ot1. genobs_clear t2 ot2. induction H0; pclearbot; eauto 7. - econstructor; intros. edestruct EUTTK; eauto. + econstructor; intros. + edestruct EUTTK as [TMP | TMP]; destruct TMP; eauto 7; contradiction. Qed. -Section EUTT_eq_EUTTE. +Lemma euttF_elim_tau_left {R1 R2} (RR: R1 -> R2 -> Prop) r (t1: itree E R1) (ot2: itree' E R2) + (REL : euttF RR r (upaco2 (euttF RR r) bot2) (TauF t1) ot2) : + euttF RR r (upaco2 (euttF RR r) bot2) (observe t1) ot2. +Proof. + remember (TauF t1) as ott1. + move REL before r. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqott1; eauto. + pclearbot. punfold EQTAUS. +Qed. -Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). +Lemma euttF_elim_tau_right {R1 R2} (RR: R1 -> R2 -> Prop) r (ot1: itree' E R1) (t2: itree E R2) + (REL : euttF RR r (upaco2 (euttF RR r) bot2) ot1 (TauF t2)) : + euttF RR r (upaco2 (euttF RR r) bot2) ot1 (observe t2). +Proof. + eapply (Symmetric_euttF_hetero _ (flip RR) _ (flip r)) in REL; eauto. + - eapply euttF_elim_tau_left in REL. + eapply Symmetric_euttF_hetero in REL; eauto. + intros. pclearbot. left. + eapply Symmetric_eutt__hetero; eauto; unfold flip; eauto. + - intros. pclearbot. left. + eapply Symmetric_eutt__hetero; eauto; unfold flip; eauto. +Qed. -Lemma euttE__impl_eutt_ r t1 t2 : - @euttE_ E R1 R2 RR r t1 t2 -> eutt_ RR r t1 t2. -Proof. - revert t1 t2. pcofix CIH'. intros. destruct H0. - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) - by (destruct ot1, ot2; simpl; tauto). - destruct EM as [EM|[EM|EM]]. - - destruct FIN as [FIN _]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS1. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct FIN as [_ FIN]. - hexploit FIN; eauto 7. clear FIN; intro FIN. - destruct FIN as [ot' [UNTAUS NOTAU]]. - hexploit EQV; eauto. intros EQNT. - induction UNTAUS; subst. - { pfold. inv EQNT; eauto. } - hexploit IHUNTAUS; eauto. - { intros. destruct UNTAUS2. - dependent destruction H; [|subst; contradiction]. - hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. - } - intros EUTT. punfold EUTT. - - destruct ot1, ot2; simpl in *; try tauto. - pfold. econstructor. right. apply CIH'. - econstructor. - + rewrite !finite_taus_tau in FIN. eauto. - + eauto using unalltaus_tau'. -Qed. - -Lemma eutt__impl_euttE_ r t1 t2 : - @eutt_ E R1 R2 RR r t1 t2 -> euttE_ RR r t1 t2. -Proof. - intros. punfold H. econstructor; intros. - - split; intros. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct H0 as [ot' [UNTAUS NOTAU]]. - move UNTAUS before r. revert_until UNTAUS. - induction UNTAUS; intros. - * induction H; eauto; try contradiction. - rewrite finite_taus_tau. eauto. - * induction H; eauto 7; try inv OBS; pclearbot - ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. - punfold EQTAUS. - - genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. - destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. - move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. - induction UNTAUS1. - + induction 1; intros. - * inv H; try contradiction; eauto. - * subst. inv H; try contradiction. eauto. - + induction 1; intros; subst. - * inv H; try contradiction; eauto. - * inv H; try contradiction; eauto. - pclearbot. eapply IHUNTAUS1; eauto. - punfold EQTAUS. -Qed. - -Lemma eutt__is_euttE_ r t1 t2 : - @eutt_ E R1 R2 RR r t1 t2 <-> euttE_ RR r t1 t2. -Proof. split; eauto using euttE__impl_eutt_, eutt__impl_euttE_. Qed. - -Lemma euttE_impl_eutt r t1 t2 : - paco2 (@euttE_ E R1 R2 RR) r t1 t2 -> paco2 (eutt_ RR) r t1 t2. -Proof. - split; intros; eapply paco2_mon_gen; eauto; intros; apply euttE__impl_eutt_; eauto. -Qed. - -Lemma eutt_impl_euttE r t1 t2 : - paco2 (@eutt_ E R1 R2 RR) r t1 t2 -> paco2 (euttE_ RR) r t1 t2. -Proof. - split; intros; eapply paco2_mon_gen; eauto; intros; apply eutt__impl_euttE_; eauto. -Qed. - -Lemma eutt_is_euttE r t1 t2 : - paco2 (@eutt_ E R1 R2 RR) r t1 t2 <-> paco2 (euttE_ RR) r t1 t2. -Proof. split; eauto using euttE_impl_eutt, eutt_impl_euttE. Qed. - -End EUTT_eq_EUTTE. - -Section EUTT_trans. +Definition isb_tau {E R} (ot: itree' E R) : bool := + match ot with | TauF _ => true | _ => false end. -Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). +Lemma eutt_Ret {R1 R2} (RR: R1 -> R2 -> Prop) x y : + RR x y -> @eutt E R1 R2 RR (Ret x) (Ret y). +Proof. + intros; pfold. pfold. econstructor. eauto. +Qed. -Ltac convert_eutt_to_euttE := - try (apply euttE__impl_eutt_ || apply euttE_impl_eutt); - repeat match goal with [H: eutt_ _ _ _ _ |- _] => apply eutt__impl_euttE_ in H end; - repeat match goal with [H: eutt _ _ _ |- _] => apply eutt_impl_euttE in H end. +Lemma eutt_Vis {R1 R2 U} RR (e: E U) k k' : + (forall x: U, @eutt E R1 R2 RR (k x) (k' x)) -> + eutt RR (Vis e k) (Vis e k'). +Proof. + intros. pfold. pfold. econstructor. + intros. left. left. apply H. +Qed. + +End EUTT_hetero. + +Section EUTT_upto. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). -Inductive eutt_trans_clo (r: itree E R1 -> itree E R2 -> Prop) : +Inductive eutt_trans_left_clo (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := -| eutt_pre_clo_intro t1 t2 t3 t4 - (EQVl: t1 ≈ t2) - (EQVr: t4 ≈ t3) +| eutt_trans_left_clo_intro t1 t2 t3 + (EQV: t1 ≈ t2) (REL: r t2 t3) - : eutt_trans_clo r t1 t4 + : eutt_trans_left_clo r t1 t3 +. +Hint Constructors eutt_trans_left_clo. + +Lemma eutt_clo_trans_left : + weak_respectful2 (@eutt_ E R1 R2 RR) eutt_trans_left_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. + eapply GF in REL. clear l LE GF. + revert_until r. pcofix CIH. intros. + pfold. punfold REL. do 2 punfold EQV. + genobs_clear t1 ot1. genobs_clear t2 ot2. genobs_clear t3 ot3. + move EQV before CIH. revert_until EQV. + induction EQV; intros; subst; pclearbot; eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - remember (VisF e k2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + - destruct (isb_tau ot3) eqn: ISTAU. + + destruct ot3; inv ISTAU. + econstructor. right. eapply CIH. eauto. + pfold. + eapply euttF_elim_tau_left in REL. + eapply euttF_elim_tau_right in REL. eauto. + + dependent destruction REL; simpobs; inv ISTAU. + econstructor. genobs_clear t2 ot. + move REL before CIH. revert_until REL. + induction REL; intros; inv H0. + * punfold EQTAUS. + genobs_clear t1 ot1. remember (RetF r1) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + * punfold EQTAUS. + genobs_clear t1 ot1. remember (VisF e k1) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + * eapply IHREL; eauto. + punfold EQTAUS. pfold. + eapply euttF_elim_tau_right in EQTAUS. eauto. + - remember (TauF t2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + punfold EQTAUS. +Qed. + +Inductive eutt_trans_right_clo (r: itree E R1 -> itree E R2 -> Prop) : + itree E R1 -> itree E R2 -> Prop := +| eutt_trans_right_clo_intro t1 t2 t3 + (EQV: t3 ≈ t2) + (REL: r t1 t2) + : eutt_trans_right_clo r t1 t3 +. +Hint Constructors eutt_trans_right_clo. + +Lemma eutt_clo_trans_right : + weak_respectful2 (@eutt_ E R1 R2 RR) eutt_trans_right_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. + eapply GF in REL. clear l LE GF. + revert_until r. pcofix CIH. intros. + pfold. punfold REL. do 2 punfold EQV. + genobs_clear t1 ot1. genobs_clear t2 ot2. genobs_clear t3 ot3. + move EQV before CIH. revert_until EQV. + induction EQV; intros; subst; pclearbot; eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - remember (VisF e k2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + - destruct (isb_tau ot1) eqn: ISTAU. + + destruct ot1; inv ISTAU. + econstructor. right. eapply CIH. eauto. + pfold. + eapply euttF_elim_tau_left in REL. + eapply euttF_elim_tau_right in REL. eauto. + + dependent destruction REL; simpobs; inv ISTAU. + econstructor. genobs_clear t2 ot. + move REL before CIH. revert_until REL. + induction REL; intros; inv H0. + * punfold EQTAUS. + remember (RetF r2) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + * punfold EQTAUS. + remember (VisF e k2) as o. + move EQTAUS before CIH. revert_until EQTAUS. + induction EQTAUS; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + econstructor. intros. + edestruct EUTTK, EUTTK0; pclearbot; eauto 7 using rclo2. + * eapply IHREL; eauto. + punfold EQTAUS. pfold. + eapply euttF_elim_tau_right in EQTAUS. eauto. + - remember (TauF t2) as o. + move REL before CIH. revert_until REL. + induction REL; intros; subst; try dependent destruction Heqo; pclearbot; eauto 7. + punfold EQTAUS. +Qed. + +Inductive eutt_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := +| eutt_bind_clo_intro U1 U2 RU t1 t2 k1 k2 + (EQV: @eutt E U1 U2 RU t1 t2) + (REL: forall v1 v2 (RELv: RU v1 v2), r (k1 v1) (k2 v2)) + : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) . -Hint Constructors eutt_trans_clo. +Hint Constructors eutt_bind_clo. -Lemma eutt_clo_trans : - weak_respectful2 (@eutt_ E R1 R2 RR) eutt_trans_clo. +Lemma eutt_clo_bind : weak_respectful2 (@eutt_ E R1 R2 RR) eutt_bind_clo. Proof. econstructor; [pmonauto|]. intros. destruct PR. - convert_eutt_to_euttE. - destruct (euttE_clo_trans E _ _ RR). clear WEAK_MON. - hexploit WEAK_RESPECTFUL. - { apply LE. } - { intros. apply GF in PR. convert_eutt_to_euttE. auto. } - { econstructor; [apply EQVl|apply EQVr|apply REL]. } - intros EUTT. - eapply monotone_euttE_; eauto; intros. - eapply rclo2_mon_gen; eauto; intros. - - convert_eutt_to_euttE. auto. - - destruct PR0. econstructor; convert_eutt_to_euttE; eauto. + assert (RELk: forall v1 v2, RU v1 v2 -> eutt_ RR r (k1 v1) (k2 v2)) by eauto. + clear l LE GF REL. + revert_until r. pcofix CIH. intros. + pfold. do 2 punfold EQV. + rewrite !unfold_bind. + genobs_clear t1 ot1. genobs_clear t2 ot2. + move EQV before CIH. revert_until EQV. + induction EQV; intros; subst; pclearbot. + - specialize (RELk _ _ RBASE). punfold RELk. + eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - econstructor. intros. + edestruct EUTTK; pclearbot; eauto 7 using rclo2. + - simpl. eauto 7. + - econstructor. rewrite unfold_bind. eauto. + - econstructor. rewrite unfold_bind. eauto. Qed. Global Instance eutt_cong_eutt r : Proper (eutt eq ==> eutt eq ==> flip impl) (paco2 (@eutt_ E R1 R2 RR ∘ gres2 (eutt_ RR)) r). Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. + repeat intro. + pupto2 eutt_clo_trans_left. econstructor; eauto. + pupto2 eutt_clo_trans_right. econstructor; eauto. Qed. Global Instance eutt_cong_gres_eutt_ r : Proper (eutt eq ==> eutt eq ==> flip impl) (gres2 (@eutt_ E R1 R2 RR) r). Proof. - repeat intro. pupto2 eutt_clo_trans. eauto. + repeat intro. + pupto2 eutt_clo_trans_left. econstructor; eauto. + pupto2 eutt_clo_trans_right. econstructor; eauto. Qed. Global Instance eutt_eq_under_rr_impl : @@ -319,18 +405,34 @@ Proof. repeat red. intros. pupto2_init. rewrite H, H0. pupto2_final. eauto. Qed. -End EUTT_trans. +End EUTT_upto. -Arguments eutt_clo_trans : clear implicits. -Hint Constructors eutt_trans_clo. +Arguments eutt_clo_trans_left : clear implicits. +Hint Constructors eutt_trans_left_clo. -Section EUTT_nested_trans. +Arguments eutt_clo_trans_right : clear implicits. +Hint Constructors eutt_trans_right_clo. + +Arguments eutt_clo_bind : clear implicits. +Hint Constructors eutt_bind_clo. + +Global Instance eutt_bind {E U R} : + Proper (eutt eq ==> + pointwise_relation _ (eutt eq) ==> + eutt eq) (@ITree.bind E U R). +Proof. + repeat intro. + pupto2_init. pupto2 eutt_clo_bind. econstructor; eauto. + intros. subst. pupto2_final. apply H0. +Qed. + +Section EUTT_nested. Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). Inductive eutt_nested_trans_clo (r: itree' E R1 -> itree' E R2 -> Prop) : itree' E R1 -> itree' E R2 -> Prop := -| eutt_nested_pre_clo_intro ot1 ot2 ot3 ot4 +| eutt_nested_trans_clo_intro ot1 ot2 ot3 ot4 (EQVl: go ot1 ≅ go ot2) (EQVr: go ot4 ≅ go ot3) (REL: r ot2 ot3) @@ -350,7 +452,14 @@ Proof. induction REL; intros; subst; try (dependent destruction EQVl; dependent destruction EQVr; [ idtac ]; pclearbot). - eauto. - - econstructor. intros. rewrite REL, REL0. eauto. + - econstructor. intros. + edestruct EUTTK. + + left. rewrite REL, REL0. eauto. + + right. eapply rclo2_step. + econstructor. + * instantiate (1:= observe(k1 x)). rewrite <- !itree_eta. eauto. + * instantiate (1:= observe(k2 x)). rewrite <- !itree_eta. eauto. + * eauto using rclo2. - econstructor. eapply rclo2_step. econstructor. + rewrite REL. reflexivity. + rewrite REL0. reflexivity. @@ -368,11 +477,44 @@ Proof. pupto2 eutt_nested_clo_trans. econstructor; eauto. Qed. -End EUTT_nested_trans. +Inductive eutt_nested_bind_clo (r: itree' E R1 -> itree' E R2 -> Prop) : itree' E R1 -> itree' E R2 -> Prop := +| eutt_nested_bind_clo_intro U1 U2 RU t1 t2 k1 k2 + (EQV: @eutt E U1 U2 RU t1 t2) + (REL: forall v1 v2 (RELv: RU v1 v2), r (observe (k1 v1)) (observe (k2 v2))) + : eutt_nested_bind_clo r (observe (ITree.bind t1 k1)) (observe (ITree.bind t2 k2)) +. +Hint Constructors eutt_nested_bind_clo. + +Lemma eutt_nested_clo_bind r : + weak_respectful2 (euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r))) + eutt_nested_bind_clo. +Proof. + econstructor; [pmonauto|]. + intros. destruct PR. + assert (RELk: forall v1 v2, RU v1 v2 -> euttF RR (gres2 (eutt_ RR) (upaco2 (eutt_ RR ∘ gres2 (eutt_ RR)) r)) r0 (observe (k1 v1)) (observe (k2 v2))) by eauto. + clear l LE GF REL. + do 2 punfold EQV. + rewrite !unfold_bind. + genobs_clear t1 ot1. genobs_clear t2 ot2. + move EQV before RU. revert_until EQV. + induction EQV; intros; subst; pclearbot. + - specialize (RELk _ _ RBASE). + eauto 7 using euttF_mon, upaco2_mon_bot, rclo2. + - econstructor. intros. + edestruct EUTTK; pclearbot; eauto 8 using rclo2. + - simpl. eauto 9 using rclo2. + - econstructor. rewrite unfold_bind. eauto. + - econstructor. rewrite unfold_bind. eauto. +Qed. + +End EUTT_nested. Arguments eutt_nested_clo_trans : clear implicits. Hint Constructors eutt_nested_trans_clo. +Arguments eutt_nested_clo_bind : clear implicits. +Hint Constructors eutt_nested_bind_clo. + Section EUTT_eq. Context {E : Type -> Type} {R : Type}. @@ -446,26 +588,6 @@ Proof. intros. pfold. pfold. econstructor. eauto. Qed. -Global Instance eutt_bind {E S R} : - Proper (eutt eq ==> - pointwise_relation _ (eutt eq) ==> - eutt eq) (@ITree.bind E R S). -Proof. - repeat intro. do 2 punfold H. - revert_until S. pcofix CIH. intros. - pfold. revert_until CIH. pcofix CIH'. intros. pfold. - rewrite !unfold_bind. genobs_clear x ox. genobs_clear y oy. - move H0 before CIH'. revert_until H0. - induction H0; intros; subst; pclearbot. - - simpl. specialize (H1 r2). do 2 punfold H1. - eauto 7 using euttF_mon, upaco2_mon_bot. - - econstructor. intros. - specialize (EUTTK x). do 2 punfold EUTTK. - - econstructor. intros. punfold EQTAUS. - - econstructor. rewrite unfold_bind. eauto. - - econstructor. rewrite unfold_bind. eauto. -Qed. - Global Instance eutt_map {E R S} : Proper (pointwise_relation _ eq ==> eutt eq ==> eutt eq) (@ITree.map E R S). Proof. @@ -476,20 +598,11 @@ Qed. Global Instance eutt_forever {E R S} : Proper (eutt eq ==> eutt eq) (@ITree.forever E R S). Proof. - cut (forall X (t1 t2: itree E X) (x y: itree E R), t1 ≈ t2 -> x ≈ y -> (t1 ;; @ITree.forever E R S x) ≈ (t2 ;; ITree.forever y)). - { repeat intro. - rewrite <-(ret_bind tt (fun _ => ITree.forever x)). - rewrite <-(ret_bind tt (fun _ => ITree.forever y)). - eapply H; eauto; reflexivity. - } - - pcofix CIH. intros. - pfold. revert_until CIH. pcofix CIH'. intros. - do 2 punfold H0. pfold. - rewrite !unfold_bind. genobs_clear t1 ot1. genobs_clear t2 ot2. - induction H0; intros; subst; pclearbot; try (econstructor; eauto 7; fail). - simpl. rewrite (unfold_forever x), (unfold_forever y). - econstructor. eauto 7. + repeat intro. pupto2_init. revert_until S. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + rewrite (unfold_forever x), (unfold_forever y). + pupto2 eutt_nested_clo_bind. econstructor; eauto. + intros. subst. pupto2_final. pfold. simpl. eauto. Qed. Global Instance eutt_when {E} (b : bool) : @@ -510,3 +623,14 @@ Lemma tau_eutt {E R} (t: itree E R) : Tau t ≈ t. Proof. pfold. pfold. econstructor. reflexivity. Qed. + +(** Generalized heterogeneous version of [eutt_bind] *) +Lemma eutt_bind_gen {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}: + forall t1 t2, + eutt RR t1 t2 -> + forall s1 s2, (forall r1 r2, RR r1 r2 -> eutt SS (s1 r1) (s2 r2)) -> + @eutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2). +Proof. + intros. red in H0. pupto2_init. pupto2 eutt_clo_bind. econstructor; eauto. + intros. pupto2_final. eauto. +Qed. diff --git a/theories/Eq/UpToTausExplicit.v b/theories/Eq/UpToTausExplicit.v index 1474689d..bdb24439 100644 --- a/theories/Eq/UpToTausExplicit.v +++ b/theories/Eq/UpToTausExplicit.v @@ -31,7 +31,8 @@ From ITree Require Import From ITree Require Export Eq.Eq - Eq.Untaus. + Eq.Untaus + Eq.UpToTaus. Local Open Scope itree. @@ -417,18 +418,18 @@ Qed. (* Lemmas about [bind]. *) Inductive euttE_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop := -| euttE_bind_clo_intro U (t1 t2: itree E U) k1 k2 - (EQV: euttE eq t1 t2) - (REL: forall v, r (k1 v) (k2 v)) +| euttE_bind_clo_intro U1 U2 RU t1 t2 k1 k2 + (EQV: @euttE E U1 U2 RU t1 t2) + (REL: forall v1 v2 (RELv: RU v1 v2), r (k1 v1) (k2 v2)) : euttE_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) . Hint Constructors euttE_bind_clo. -Lemma bind_clo_finite_taus {E U R1 R2} t1 t2 k1 k2 - (FT: finite_taus (@ITree.bind E U R1 t1 k1)) - (FTk: forall v, finite_taus (k1 v) -> finite_taus (k2 v)) - (EQV: euttE eq t1 t2): - finite_taus (@ITree.bind E U R2 t2 k2). +Lemma bind_clo_finite_taus {E U1 U2 RU R1 R2} t1 t2 k1 k2 + (FT: finite_taus (@ITree.bind E U1 R1 t1 k1)) + (FTk: forall v1 v2 (RELv: RU v1 v2 : Prop), finite_taus (k1 v1) -> finite_taus (k2 v2)) + (EQV: euttE RU t1 t2): + finite_taus (@ITree.bind E U2 R2 t2 k2). Proof. punfold EQV. destruct EQV as [[FTt _] EQV]. assert (FT1 := FT). apply finite_taus_bind_fst in FT1. @@ -448,7 +449,8 @@ Lemma euttE_clo_bind {E R1 R2} RR : weak_respectful2 (@euttE_ E R1 R2 RR) euttE_ Proof. econstructor; [pmonauto|]. intros. destruct PR. split. - - assert (EQV':=EQV). symmetry in EQV'. + - assert (EQV':=EQV). + eapply (Symmetric_euttE_ RU (flip RU) bot2 bot2) in EQV'; eauto. split; intros; eapply bind_clo_finite_taus; eauto; intros. + edestruct GF; eauto. apply FIN. eauto. + edestruct GF; eauto. apply FIN. eauto. @@ -464,7 +466,7 @@ Proof. hexploit @untaus_unalltaus_rev; [apply UT2| |]; eauto. intros UAT2. inv EQV. + rewrite unfold_bind in UAT1. rewrite unfold_bind in UAT2. cbn in *. - eapply GF in REL. destruct REL. + eapply GF in REL; eauto. destruct REL. eapply monotone_eq_notauF; eauto using rclo2. + rewrite unfold_bind in UAT1. rewrite unfold_bind in UAT2. cbn in *. destruct UAT1 as [UAT1 _]. destruct UAT2 as [UAT2 _]. @@ -509,3 +511,99 @@ Proof. Qed. Arguments euttE_clo_trans : clear implicits. + + +Section EUTT_eq_EUTTE. + +Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop). + +Lemma euttE__impl_eutt_ r t1 t2 : + @euttE_ E R1 R2 RR r t1 t2 -> eutt_ RR r t1 t2. +Proof. + revert t1 t2. pcofix CIH'. intros. destruct H0. + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + assert (EM: notauF ot1 \/ notauF ot2 \/ ~(notauF ot1 \/ notauF ot2)) + by (destruct ot1, ot2; simpl; tauto). + destruct EM as [EM|[EM|EM]]. + - destruct FIN as [FIN _]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS1. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct FIN as [_ FIN]. + hexploit FIN; eauto 7. clear FIN; intro FIN. + destruct FIN as [ot' [UNTAUS NOTAU]]. + hexploit EQV; eauto. intros EQNT. + induction UNTAUS; subst. + { pfold. inv EQNT; eauto. } + hexploit IHUNTAUS; eauto. + { intros. destruct UNTAUS2. + dependent destruction H; [|subst; contradiction]. + hexploit @unalltaus_injective; [|econstructor|]; eauto. intros; subst; eauto. + } + intros EUTT. punfold EUTT. + - destruct ot1, ot2; simpl in *; try tauto. + pfold. econstructor. right. apply CIH'. + econstructor. + + rewrite !finite_taus_tau in FIN. eauto. + + eauto using unalltaus_tau'. +Qed. + +Lemma euttE_impl_eutt r t1 t2 : + paco2 (@euttE_ E R1 R2 RR) r t1 t2 -> paco2 (eutt_ RR) r t1 t2. +Proof. + split; intros; eapply paco2_mon_gen; eauto; intros; apply euttE__impl_eutt_; eauto. +Qed. + +Lemma eutt_impl_euttE r t1 t2 : + paco2 (@eutt_ E R1 R2 RR) r t1 t2 -> paco2 (euttE_ RR) r t1 t2. +Proof. + revert_until RR. pcofix CIH. intros. + rename H0 into H. do 2 punfold H. pfold. econstructor; intros. + - split; intros. + + genobs_clear t1 ot1. genobs_clear t2 ot2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + + genobs t1 ot1. genobs t2 ot2. clear Heqot1 t1 Heqot2 t2. + destruct H0 as [ot' [UNTAUS NOTAU]]. + move UNTAUS before r. revert_until UNTAUS. + induction UNTAUS; intros. + * induction H; eauto; try contradiction. + rewrite finite_taus_tau. eauto. + * induction H; eauto 7; try inv OBS; pclearbot + ; rewrite ?finite_taus_tau; eauto; eapply IHUNTAUS; eauto. + punfold EQTAUS. + - genobs_clear t1 ot1. genobs_clear t2 ot2. + destruct UNTAUS1 as [UNTAUS1 NT1]. destruct UNTAUS2 as [UNTAUS2 NT2]. + move UNTAUS2 before r. move UNTAUS1 before r. revert_until UNTAUS1. + induction UNTAUS1. + + induction 1; intros. + * inv H; try contradiction; eauto. + econstructor. intros. + edestruct EUTTK as [TMP | TMP]; destruct TMP; eauto 7; contradiction. + * subst. inv H; try contradiction. eauto. + + induction 1; intros; subst. + * inv H; try contradiction; eauto. + * inv H; try contradiction; eauto. + pclearbot. eapply IHUNTAUS1; eauto. + punfold EQTAUS. +Qed. + +Lemma eutt_is_euttE r t1 t2 : + paco2 (@eutt_ E R1 R2 RR) r t1 t2 <-> paco2 (euttE_ RR) r t1 t2. +Proof. split; eauto using euttE_impl_eutt, eutt_impl_euttE. Qed. + +End EUTT_eq_EUTTE. diff --git a/theories/FixFacts.v b/theories/FixFacts.v index b19506db..5b505bc3 100644 --- a/theories/FixFacts.v +++ b/theories/FixFacts.v @@ -12,6 +12,7 @@ From Coq Require Import From ITree Require Import Basics Basics_Functions + OpenSum Core Morphisms MorphismsFacts @@ -100,40 +101,19 @@ Qed. Theorem unfold_interp_mrec {T} (c : itree _ T) : interp_mrec ctx _ c ≈ interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) _ c. Proof. - revert_until ctx. - cut (forall T R (t: itree E R) k, - ITree.bind t (fun x => interp_mrec ctx T (k x)) ≈ - ITree.bind t (fun x => interp (Sum1.elim (C:=itree E) (mrec ctx) ITree.liftE) T (k x))). - { intros. specialize (H _ _ (Ret ()) (fun _ => c)). - rewrite !ret_bind in H. auto. - } - - intros. pupto2_init. revert_until T. pcofix CIH. - intros. pfold. pupto2_init. revert_until CIH. pcofix CIH'. - intros. rewrite (itree_eta t). genobs_clear t ot. - destruct ot. - - rewrite !ret_bind. - generalize (k r1) as t. clear R k r1. - intros. rewrite (itree_eta t). genobs_clear t ot. - destruct ot. - + rewrite ret_mrec, ret_interp. simpl. eauto. - + rewrite tau_mrec, tau_interp. simpl. - pfold. econstructor. pupto2_final. right. - apply (CIH' _ (Ret tt) (fun _ => t)). - + destruct e. - * rewrite vis_mrec_left, vis_interp. simpl. - rewrite interp_mrec_bind. - pfold. econstructor. pupto2_final. eauto. - * rewrite vis_mrec_right, vis_interp. simpl. - setoid_rewrite vis_bind_. setoid_rewrite ret_bind_. - pfold. econstructor. econstructor. intros. - rewrite <- (ret_bind () (fun _ => interp_mrec _ _ _)). - rewrite <- (ret_bind () (fun _ => interp _ _ _)). - pupto2_final. eauto. - - rewrite !tau_bind. - pfold. econstructor. pupto2_final. eauto. - - rewrite !vis_bind. - pfold. econstructor. intros. pupto2_final. eauto. + repeat intro. pupto2_init. revert_until T. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + rewrite observe_interp_mrecF, unfold_interp. + destruct (observe c); [| |destruct e]; simpl; eauto 7. + - rewrite interp_mrec_bind. + pfold. econstructor. + pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros; subst. eauto. + - unfold ITree.liftE. rewrite vis_bind_. + pfold. econstructor. econstructor. intros. left. + rewrite ret_bind. + pupto2_final. eauto. Qed. Theorem unfold_mrec {T} (d : D T) : @@ -415,7 +395,21 @@ Lemma bind_aloop {E A B C} (f : A -> itree E (A + B)) (g : B -> itree E (B + C)) | inl a => ITree.map inl (f a) | inr b => ITree.map (sum_map1 inr) (g b) end) (inl x). -Admitted. +Proof. + pupto2_init. revert_until g. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite !unfold_aloop', bind_bind, map_bind. + pupto2 eutt_nested_clo_bind. econstructor; [reflexivity|]. + intros; subst. destruct v2; simpl. + - rewrite tau_bind_. + pfold. econstructor. eauto. + - rewrite ret_bind_. pfold. econstructor. pfold_reverse. + revert_until x. pcofix CIH''. intros. + rewrite !unfold_aloop', map_bind. + pupto2 eutt_nested_clo_bind. econstructor; [reflexivity|]. + intros. subst. destruct v2; simpl; eauto 7. +Qed. Instance eq_itree_loop {E A B C} : Proper ((eq ==> eq_itree eq) ==> eq ==> eq_itree eq) (@loop E A B C). @@ -621,19 +615,33 @@ Lemma interp_state_loop {E F S A B C} (RS : S -> S -> Prop) (t1 t2 : C + A -> itree E (C + B)) : (forall ca s1 s2, RS s1 s2 -> eutt (fun a b => RS (fst a) (fst b) /\ snd a = snd b) - (interp_state h _ (t1 ca) s1) - (interp_state h _ (t2 ca) s2)) -> - (forall a s1 s2, RS s1 s2 -> + (interp_state h (C+B) (t1 ca) s1) + (interp_state h (C+B) (t2 ca) s2)) -> + (forall ca s1 s2, RS s1 s2 -> eutt (fun a b => RS (fst a) (fst b) /\ snd a = snd b) - (interp_state h _ (loop t1 a) s1) - (interp_state h _ (loop t2 a) s2)). + (interp_state h B (loop_ t1 ca) s1) + (interp_state h B (loop_ t2 ca) s2)). Proof. -Admitted. - -Require Import ITree.OpenSum. + repeat intro. pupto2_init. revert_until H. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite (itree_eta (loop_ t1 ca)), (itree_eta (loop_ t2 ca)), !unfold_loop''. + unfold loop_once. rewrite <- !itree_eta, !interp_state_bind. + pupto2 eutt_nested_clo_bind. econstructor; eauto. + intros. destruct RELv. rewrite H2. destruct (snd v2). + - rewrite !interp_state_tau. + pfold. econstructor. pupto2_final. eauto. + - rewrite !interp_state_ret. simpl. eauto 7. +Qed. Lemma interp1_loop {E F G} `{F -< G} (f : E ~> itree G) {A B C} - (t : C + A -> itree (E +' F) (C + B)) a : - interp1 f _ (loop t a) ≅ loop (fun ca => interp1 f _ (t ca)) a. + (t : C + A -> itree (E +' F) (C + B)) ca : + interp1 f _ (loop_ t ca) ≅ loop_ (fun ca => interp1 f _ (t ca)) ca. Proof. -Admitted. + pupto2_init. revert ca. pcofix CIH. intros. + unfold loop. rewrite !unfold_loop'. unfold loop_once. + rewrite interp1_bind. + pupto2 eq_itree_clo_bind. econstructor; [reflexivity|]. + intros. subst. rewrite unfold_interp1. pupto2_final. pfold. red. + destruct u2; simpl; eauto. +Qed. diff --git a/theories/Morphisms.v b/theories/Morphisms.v index 601c766c..0159c039 100644 --- a/theories/Morphisms.v +++ b/theories/Morphisms.v @@ -240,9 +240,9 @@ Import ITree.Basics.Monads. Definition interp_state_match {E F S R} (h : E ~> stateT S (itree F)) (rec : itree E R -> stateT S (itree F) R) - (t:itree E R) : stateT S (itree F) R := + (ot:itree' E R) : stateT S (itree F) R := fun s => - match t.(observe) with + match ot with | RetF r => Ret (s, r) | VisF e k => Tau (ITree.bind (h _ e s) (fun sx => @@ -252,14 +252,14 @@ Definition interp_state_match {E F S R} (h : E ~> stateT S (itree F)) CoFixpoint interp_state {E F S} (h : E ~> stateT S (itree F)) : itree E ~> stateT S (itree F) := - fun R => interp_state_match h (interp_state h R). + fun R t => interp_state_match h (interp_state h R) (observe t). Definition interp1_state_match {E F S R} (h : E ~> stateT S (itree F)) (rec : itree (E +' F) R -> stateT S (itree F) R) - (t : itree (E +' F) R) : stateT S (itree F) R := + (ot : itree' (E +' F) R) : stateT S (itree F) R := fun s => - match t.(observe) with + match ot with | RetF r => Ret (s, r) | VisF ef k => match ef with @@ -274,7 +274,7 @@ Definition interp1_state_match {E F S R} (h : E ~> stateT S (itree F)) CoFixpoint interp1_state {E F S} (h : E ~> stateT S (itree F)) : itree (E +' F) ~> stateT S (itree F) := - fun R => interp1_state_match h (interp1_state h R). + fun R t => interp1_state_match h (interp1_state h R) (observe t). Definition translate1_state {E F S} (h : E ~> state S) : itree (E +' F) ~> stateT S (itree F) := diff --git a/theories/MorphismsFacts.v b/theories/MorphismsFacts.v index 42975ebe..1eb3ace9 100644 --- a/theories/MorphismsFacts.v +++ b/theories/MorphismsFacts.v @@ -114,25 +114,16 @@ Instance eutt_interp (E F : Type -> Type) (R : Type) : Proper (Rhom (fun _ => eutt eq) ==> eutt eq ==> eutt eq) (fun f => @interp E F f R). Proof. - repeat intro. revert_until H. repeat red in H. - cut (forall T t1 t2 k1 k2 (EQt: t1 ≈ t2) (EQk: forall v:T, k1 v ≈ k2 v), - (v <- t1 ;; interp x R (k1 v)) ≈ (v <- t2 ;; interp y R (k2 v))). - { intros. - hexploit (H0 _ (Ret ()) (Ret ()) (fun _ => x0) (fun _ => y0)); try reflexivity; eauto. intros EQV. - rewrite !ret_bind in EQV. eauto. - } + repeat intro. pupto2_init. revert_until H. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. - pcofix CIH. intros. - pfold. revert_until CIH. pcofix CIH'. intros. - do 2 punfold EQt. pfold. - rewrite !unfold_bind. genobs_clear t1 ot1. genobs_clear t2 ot2. - induction EQt; intros; subst; pclearbot; try (econstructor; eauto 7; fail). - simpl. rewrite !unfold_interp. unfold interp_u. unfold handleF. - specialize (EQk r2). do 2 punfold EQk. - genobs (k1 r2) kr1. genobs (k2 r2) kr2. clear Heqkr1 k1 Heqkr2 k2 r2. - induction EQk; intros; subst; pclearbot; try (econstructor; eauto 7; fail). - econstructor. right. - eapply (CIH' _ (Ret ()) (Ret ()) (fun _ => t1) (fun _ => t2)); try reflexivity; eauto. + rewrite !unfold_interp. do 2 punfold H1. pfold. + induction H1; intros; subst; pclearbot; simpl; eauto. + - econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [apply H|]. + intros; subst. pupto2_final. + right. eapply CIH'. edestruct EUTTK; pclearbot; eauto. + - econstructor. pupto2_final. eauto 7. Qed. Lemma interp_ret : forall {E F R} x @@ -163,7 +154,6 @@ Proof. + intros; subst. specialize (CIH _ (k0 u2) k); auto. Qed. - Lemma interp_liftE {E F : Type -> Type} {R : Type} (f : E ~> (itree F)) (e : E R) : @@ -197,9 +187,8 @@ Proof. - pfold. econstructor. cbn. econstructor. intros. assert (ITree.bind' (fun x0 : u => interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0)) (Ret x) = (x0 <- Ret x ;; interp (fun (T : Type) (e0 : E T) => ITree.liftE e0) R (k x0))). { intros; reflexivity. } - rewrite H. - rewrite ret_bind. - pupto2_final. right. apply CIH. + left. rewrite H, ret_bind. + pupto2_final. eauto. Qed. @@ -233,13 +222,12 @@ Qed. Lemma unfold_interp_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, observe (interp_state h _ t s) = - observe (interp_state_match h (interp_state h R) t s). + observe (interp_state_match h (interp_state h R) (observe t) s). Proof. intros E F S R h t s. econstructor. Qed. - Instance eq_itree_interp_state {E F S R} (h : E ~> Monads.stateT S (itree F)) : Proper (eq_itree eq ==> eq ==> eq_itree eq) (interp_state h R). @@ -261,7 +249,7 @@ Qed. Lemma unfold_interp1_state : forall {E F S R} (h : E ~> Monads.stateT S (itree F)) t s, observe (interp1_state h _ t s) = - observe (interp1_state_match h (interp1_state h R) t s). + observe (interp1_state_match h (interp1_state h R) (observe t) s). Proof. intros E F S R h t s. econstructor. @@ -449,8 +437,17 @@ Instance eutt_interp_state {E F: Type -> Type} {S : Type} (h : E ~> Monads.stateT S (itree F)) R : Proper (eutt eq ==> eq ==> eutt eq) (@interp_state E F S h R). Proof. -Admitted. + repeat intro. subst. pupto2_init. revert_until R. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + rewrite !unfold_interp_state. do 2 punfold H0. pfold. + induction H0; intros; subst; simpl; pclearbot; eauto. + - econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros; subst. pupto2_final. + right. eapply CIH'. edestruct EUTTK; pclearbot; eauto. + - econstructor. pupto2_final. eauto 7. +Qed. (* Commuting interpreters --------------------------------------------------- *) @@ -489,12 +486,13 @@ Proof. unfold translateF, interp_u, handleF. pfold. revert t. pcofix CIH'. intros t. - destruct (observe t); cbn; eauto. + destruct (observe t); cbn; simpl in *; eauto. - pfold. econstructor. right. rewrite unfold_translate. unfold translateF. rewrite unfold_interp. unfold interp_u. apply CIH'. - pfold. econstructor. unfold ITree.liftE. rewrite vis_bind. econstructor. intros. + left. rewrite (itree_eta (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))). assert ((observe (x0 <- Ret x;; interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x0))) = observe (interp (fun (T : Type) (e0 : E T) => Vis (f T e0) (fun x1 : T => Ret x1)) R (k x))). @@ -529,6 +527,7 @@ Proof. - pfold. econstructor. cbn. econstructor. intros. assert (ITree.bind' (fun x0 : u => interp eh_id R (k x0)) (Ret x) = (x0 <- Ret x ;; interp eh_id R (k x0))). { intros; reflexivity. } + left. rewrite H. rewrite ret_bind. (* TODO: [ret_bind] doesn't work *) pupto2_final. right. apply CIH. Qed. @@ -652,61 +651,30 @@ Proof. rewrite itree_eta, unfold_interp1, <-itree_eta. reflexivity. Qed. Section interp1_is_interp. Context {E F G : Type -> Type} `{F -< G} (f : E ~> itree G). - + Definition interp_match : (E +' F) ~> itree G := fun _ ef => match ef with inl1 e => f _ e | inr1 e => Vis (subeffect _ e) (fun r => Ret r) end. -Inductive interp_inv {R} : relation (itree' G R) := -| _interp_inv_main t: - interp_inv - (observe (interp interp_match _ t)) (observe (interp1 f _ t)) -| _interp_inv_bind u t (k: u -> _): - interp_inv - (observe (ITree.bind t (fun x => interp interp_match _ (k x)))) - (observe (ITree.bind t (fun x => interp1 f _ (k x)))) -. -Hint Constructors interp_inv. - -Lemma interp_inv_main_step R (t: itree _ R) : - euttF eq (fun x y => interp_inv (observe x) (observe y)) interp_inv - (observe (interp interp_match _ t)) (observe (interp1 f _ t)). -Proof. - rewrite unfold_interp, unfold_interp1. - genobs t ot. clear Heqot t. - destruct ot; simpl; eauto. - destruct e; simpl; eauto. - econstructor. rewrite unfold_bind. - econstructor. intros. - fold_bind. rewrite unfold_bind. simpl. eauto. -Qed. - -Lemma interp_is_interp1 R (t : itree _ R) : +Lemma interp_is_interp1 R (t: itree _ R) : interp interp_match _ t ≈ interp1 f _ t. Proof. - revert t. - cut (forall (t1 t2: itree _ R) (REL: interp_inv (observe t1) (observe t2)), t1 ≈ t2). - { eauto. } - - intros. revert_until R. pcofix CIH. intros. - pfold. revert_until CIH. pcofix CIH'. intros. - destruct REL. - - pfold. eapply euttF_mon; eauto using interp_inv_main_step; intros. - eapply upaco2_mon; eauto. intros. - eapply (CIH' (go x2) (go x3)); eauto. - - rewrite !unfold_bind. fold_bind. - genobs_clear t ot. - destruct ot; simpl; eauto 10. - pfold. eapply euttF_mon; eauto using interp_inv_main_step; intros. - eapply upaco2_mon; eauto. intros. - eapply (CIH' (go x2) (go x3)); eauto. + pupto2_init. revert_until R. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite unfold_interp, unfold_interp1. unfold interp_u, interp1_u. + destruct (observe t); [| |destruct e]; simpl; eauto. + - pfold; econstructor. pupto2_final. eauto. + - pfold; econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros. subst. eauto. + - rewrite vis_bind_. pfold. econstructor. econstructor. + left. rewrite ret_bind_. pupto2_final. eauto. Qed. End interp1_is_interp. -Lemma eq_itree_interp1_ {E F R} (h1 h2 : E ~> itree F) : - (forall T (e : E T), h1 _ e ≅ h2 _ e) -> - forall t1 t2 : itree (E +' F) R, - t1 ≅ t2 -> interp1 h1 _ t1 ≅ interp1 h2 _ t2. +Instance eq_itree_interp1 {E F G R} `{F -< G} (h : E ~> itree G) : + Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). Proof. repeat intro. pupto2_init. revert_until R. pcofix CIH. intros. @@ -716,28 +684,29 @@ Proof. - pupto2_final. pfold. red. cbn. eauto. - pupto2_final. pfold. red. cbn. eauto. - pfold. destruct e; cbn; econstructor. - + pupto2 (eq_itree_clo_bind F R). + + pupto2 eq_itree_clo_bind. econstructor. - * eauto. + * reflexivity. * intros; subst. pupto2_final; eauto. + intros. pupto2_final. eauto. Qed. -Instance eq_itree_interp1 {E F G} `{F -< G} {R} (h : E ~> itree F) : - Proper (@eq_itree (E +' F) _ _ eq ==> eq_itree eq) (interp1 h R). -Proof. - repeat intro. - eapply eq_itree_interp1_; auto. - reflexivity. -Qed. - -Instance eutt_interp1 {E F G: Type -> Type} `{F -< G} (h: E ~> itree G) R: +Instance eutt_interp1 {E F G R} `{F -< G} (h: E ~> itree G): Proper (eutt eq ==> eutt eq) (@interp1 E F G _ h R). Proof. - repeat intro. - rewrite <- 2 interp_is_interp1. - eapply eutt_interp; auto. - red; reflexivity. + repeat intro. pupto2_init. revert_until H. pcofix CIH. intros. + pfold. pupto2_init. revert_until CIH. pcofix CIH'. intros. + + rewrite !unfold_interp1. do 2 punfold H1. pfold. + induction H1; intros; subst; pclearbot; simpl; eauto. + - destruct e. + + econstructor. pupto2 eutt_nested_clo_bind. + econstructor; [reflexivity|]. + intros; subst. pupto2_final. + right. eapply CIH'. edestruct EUTTK; pclearbot; eauto. + + econstructor. left. pupto2_final. + right. eapply CIH. edestruct EUTTK; pclearbot; eauto. + - econstructor. pupto2_final. eauto 7. Qed. Lemma interp1_bind {E F G} `{F -< G} {R S} (h : E ~> itree G) (t : _ R) (k : _ -> itree (E +' F) S) : From f665f9bda9a9fdb3abb7347407b0ffb41ed09e5f Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sat, 2 Mar 2019 00:00:12 -0500 Subject: [PATCH 140/142] fix implicit arguments on inl1 and inr1 --- theories/Effect/Sum.v | 3 +++ 1 file changed, 3 insertions(+) diff --git a/theories/Effect/Sum.v b/theories/Effect/Sum.v index 5f34d616..8d7a737f 100644 --- a/theories/Effect/Sum.v +++ b/theories/Effect/Sum.v @@ -15,6 +15,9 @@ From ITree Require Import Variant sum1 (E1 E2 : Type -> Type) (X : Type) : Type := | inl1 (_ : E1 X) | inr1 (_ : E2 X). +Arguments inr1 {_ _} [_] _. +Arguments inl1 {_ _} [_] _. + Notation "E1 +' E2" := (sum1 E1 E2) (at level 60, right associativity) : type_scope. From 9562660d7633aa781eea7c0e072b84d0a3b078b5 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 2 Mar 2019 00:06:16 -0500 Subject: [PATCH 141/142] 8.8 hotfix --- theories/Eq/UpToTaus.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/theories/Eq/UpToTaus.v b/theories/Eq/UpToTaus.v index cfdf14e5..02e7d742 100644 --- a/theories/Eq/UpToTaus.v +++ b/theories/Eq/UpToTaus.v @@ -356,7 +356,8 @@ Inductive eutt_bind_clo {E R1 R2} (r: itree E R1 -> itree E R2 -> Prop) : itree | eutt_bind_clo_intro U1 U2 RU t1 t2 k1 k2 (EQV: @eutt E U1 U2 RU t1 t2) (REL: forall v1 v2 (RELv: RU v1 v2), r (k1 v1) (k2 v2)) - : eutt_bind_clo r (ITree.bind t1 k1) (ITree.bind t2 k2) + : @eutt_bind_clo E R1 R2 r (ITree.bind t1 k1) (ITree.bind t2 k2) + (* TODO: 8.8 doesn't like the implicit arguments *) . Hint Constructors eutt_bind_clo. From 4cbd3669ebd8db6bee96872655175b0c32504140 Mon Sep 17 00:00:00 2001 From: Lysxia Date: Sat, 2 Mar 2019 00:07:45 -0500 Subject: [PATCH 142/142] Clean up stash --- examples/Imp2AsmCorrectness.v | 72 ----------------------------------- 1 file changed, 72 deletions(-) diff --git a/examples/Imp2AsmCorrectness.v b/examples/Imp2AsmCorrectness.v index 50e36c34..05a5d361 100644 --- a/examples/Imp2AsmCorrectness.v +++ b/examples/Imp2AsmCorrectness.v @@ -89,54 +89,6 @@ Section alistFacts. (* Generic facts about alists. To eventually move to ExtLib. *) -(* STASHED - -Definition eq_locals {R1 R2} (RR : R1 -> R2 -> Prop) - (Renv_ : _ -> _ -> Prop) - t1 t2 := - forall g1 g2, - Renv_ g1 g2 -> - eutt (fun a (b : alist var value * R2) => Renv_ (fst a) (fst b) /\ RR (snd a) (snd b)) - (interp_locals t1 g1) - (interp_locals t2 g2). - -Instance eutt_eq_locals (Renv_ : _ -> _ -> Prop) {R} RR : - Proper (eutt eq ==> eutt eq ==> iff) (@eq_locals R R RR Renv_). -Proof. - repeat intro. - split; repeat intro. - - rewrite <- H, <- H0; auto. - - rewrite H, H0; auto. -Qed. - -Definition eq_locals_bind_gen (Renv_ : _ -> _ -> Prop) - {R1 R2 S1 S2} (RR : R1 -> R2 -> Prop) - (RS : S1 -> S2 -> Prop) : - forall t1 t2, - eq_locals RR Renv_ t1 t2 -> - forall k1 k2, - (forall r1 r2, RR r1 r2 -> eq_locals RS Renv_ (k1 r1) (k2 r2)) -> - eq_locals RS Renv_ (t1 >>= k1) (t2 >>= k2). -Proof. - repeat intro. - rewrite 2 interp_locals_bind. - eapply eutt_bind_gen. - { eapply H; auto. } - intros. eapply H0; destruct H2; auto. -Qed. - -Lemma eq_locals_loop {A B C} x (t1 t2 : C + A -> itree E (C + B)) : - (forall l, eq_locals eq Renv (t1 l) (t2 l)) -> - eq_locals eq Renv (loop t1 x) (loop t2 x). -Proof. - unfold eq_locals, interp_locals, run_env. - intros. unfold loop. - rewrite 2 interp1_loop. - eapply interp_state_loop; auto. -Qed. - - Set Nested Proofs Allowed. -*) Arguments alist_find {_ _ _ _}. @@ -552,30 +504,6 @@ Section Correctness. eapply Renv_write_local; eauto. Qed. -(* STASHED - - Lemma sym_den_unfold {E} {A B}: - lift_den sum_comm ⩰ @sym_den E A B. - Proof. - reflexivity. - Qed. - - Lemma seq_linking_den {E} {A B C} (ab : @den E A B) (bc : den B C) : - loop_den (sym_den >=> ab ⊗ bc) ⩰ ab >=> bc. - Proof. - rewrite tensor_den_slide. - rewrite <- compose_den_assoc. - rewrite loop_compose. - rewrite tensor_swap. - repeat rewrite <- compose_den_assoc. - rewrite sym_nilpotent, id_den_left. - rewrite compose_loop. - erewrite yanking_den. - rewrite id_den_right. - reflexivity. - Qed. -*) - Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) : eq_ktree (denote_asm (seq_asm ab bc)) (denote_asm ab >=> denote_asm bc).