diff options
author | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2019-09-05 11:19:22 +0200 |
---|---|---|
committer | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2019-09-05 11:19:22 +0200 |
commit | c4cc75dc6abcb0eee6f3288e96fea4aec540fd68 (patch) | |
tree | e63d0437c3f3cb43eb26cced8ad94acc62e82dad /backend | |
parent | 7042070a3668ae149ec6a490b8e7c1a6aa82d6fe (diff) | |
download | compcert-kvx-c4cc75dc6abcb0eee6f3288e96fea4aec540fd68.tar.gz compcert-kvx-c4cc75dc6abcb0eee6f3288e96fea4aec540fd68.zip |
more proofs going through
Diffstat (limited to 'backend')
-rw-r--r-- | backend/Allocation.v | 24 | ||||
-rw-r--r-- | backend/Bounds.v | 6 | ||||
-rw-r--r-- | backend/Debugvar.v | 2 | ||||
-rw-r--r-- | backend/LTL.v | 19 | ||||
-rw-r--r-- | backend/Linear.v | 23 | ||||
-rw-r--r-- | backend/Linearize.v | 4 | ||||
-rw-r--r-- | backend/Lineartyping.v | 16 | ||||
-rw-r--r-- | backend/RTL.v | 2 | ||||
-rw-r--r-- | backend/Tunnelingproof.v | 25 |
9 files changed, 95 insertions, 26 deletions
diff --git a/backend/Allocation.v b/backend/Allocation.v index c2e80f1c..2fa3fc0b 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -58,19 +58,19 @@ Inductive block_shape: Type := (mv2: moves) (s: node) | BSopdead (op: operation) (args: list reg) (res: reg) (mv: moves) (s: node) - | BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) + | BSload (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) | BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) (mv: moves) (s: node) - | BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg) + | BSload2 (trap : trapping_mode) (addr1 addr2: addressing) (args: list reg) (dst: reg) (mv1: moves) (args1': list mreg) (dst1': mreg) (mv2: moves) (args2': list mreg) (dst2': mreg) (mv3: moves) (s: node) - | BSload2_1 (addr: addressing) (args: list reg) (dst: reg) + | BSload2_1 (trap : trapping_mode) (addr: addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) - | BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg) + | BSload2_2 (trap : trapping_mode) (addr addr': addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) | BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg) @@ -229,32 +229,34 @@ Definition pair_instr_block | Iload trap chunk addr args dst s => let (mv1, b1) := extract_moves nil b in match b1 with - | Lload chunk' addr' args' dst' :: b2 => + | Lload trap' chunk' addr' args' dst' :: b2 => + assertion (trapping_mode_eq trap' trap); if chunk_eq chunk Mint64 && Archi.splitlong then assertion (chunk_eq chunk' Mint32); let (mv2, b3) := extract_moves nil b2 in match b3 with - | Lload chunk'' addr'' args'' dst'' :: b4 => + | Lload trap'' chunk'' addr'' args'' dst'' :: b4 => + assertion (trapping_mode_eq trap'' trap); let (mv3, b5) := extract_moves nil b4 in assertion (chunk_eq chunk'' Mint32); assertion (eq_addressing addr addr'); assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'')); assertion (check_succ s b5); - Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) + Some(BSload2 trap addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) | _ => assertion (check_succ s b3); if (eq_addressing addr addr') then - Some(BSload2_1 addr args dst mv1 args' dst' mv2 s) + Some(BSload2_1 trap addr args dst mv1 args' dst' mv2 s) else (assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr')); - Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s)) + Some(BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s)) end else ( let (mv2, b3) := extract_moves nil b2 in assertion (chunk_eq chunk chunk'); assertion (eq_addressing addr addr'); assertion (check_succ s b3); - Some(BSload chunk addr args dst mv1 args' dst' mv2 s)) + Some(BSload trap chunk addr args dst mv1 args' dst' mv2 s)) | _ => assertion (check_succ s b1); Some(BSloaddead chunk addr args dst mv1 s) @@ -1023,7 +1025,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) | BSopdead op args res mv s => assertion (reg_unconstrained res e); track_moves env mv e - | BSload chunk addr args dst mv1 args' dst' mv2 s => + | BSload trap chunk addr args dst mv1 args' dst' mv2 s => do e1 <- track_moves env mv2 e; do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1; track_moves env mv1 e2 diff --git a/backend/Bounds.v b/backend/Bounds.v index fa695234..b8c12166 100644 --- a/backend/Bounds.v +++ b/backend/Bounds.v @@ -67,7 +67,7 @@ Definition instr_within_bounds (i: instruction) := | Lgetstack sl ofs ty r => slot_within_bounds sl ofs ty /\ mreg_within_bounds r | Lsetstack r sl ofs ty => slot_within_bounds sl ofs ty | Lop op args res => mreg_within_bounds res - | Lload chunk addr args dst => mreg_within_bounds dst + | Lload trap chunk addr args dst => mreg_within_bounds dst | Lcall sig ros => size_arguments sig <= bound_outgoing b | Lbuiltin ef args res => (forall r, In r (params_of_builtin_res res) \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r) @@ -104,7 +104,7 @@ Definition record_regs_of_instr (u: RegSet.t) (i: instruction) : RegSet.t := | Lgetstack sl ofs ty r => record_reg u r | Lsetstack r sl ofs ty => record_reg u r | Lop op args res => record_reg u res - | Lload chunk addr args dst => record_reg u dst + | Lload trap chunk addr args dst => record_reg u dst | Lstore chunk addr args src => u | Lcall sig ros => u | Ltailcall sig ros => u @@ -280,7 +280,7 @@ Definition defined_by_instr (r': mreg) (i: instruction) := match i with | Lgetstack sl ofs ty r => r' = r | Lop op args res => r' = res - | Lload chunk addr args dst => r' = dst + | Lload trap chunk addr args dst => r' = dst | Lbuiltin ef args res => In r' (params_of_builtin_res res) \/ In r' (destroyed_by_builtin ef) | _ => False end. diff --git a/backend/Debugvar.v b/backend/Debugvar.v index 1f361030..56908855 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -233,7 +233,7 @@ Definition transfer (lm: labelmap) (before: option avail) (i: instruction): (lm, Some (kill (S sl ofs ty) s)) | Lop op args dst => (lm, Some (kill (R dst) s)) - | Lload chunk addr args dst => + | Lload trap chunk addr args dst => (lm, Some (kill (R dst) s)) | Lstore chunk addr args src => (lm, before) diff --git a/backend/LTL.v b/backend/LTL.v index 5e7eec8c..ee8b4826 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -29,7 +29,7 @@ Definition node := positive. Inductive instruction: Type := | Lop (op: operation) (args: list mreg) (res: mreg) - | Lload (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) + | Lload (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) | Lgetstack (sl: slot) (ofs: Z) (ty: typ) (dst: mreg) | Lsetstack (src: mreg) (sl: slot) (ofs: Z) (ty: typ) | Lstore (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) @@ -209,11 +209,24 @@ Inductive step: state -> trace -> state -> Prop := rs' = Locmap.set (R res) v (undef_regs (destroyed_by_op op) rs) -> step (Block s f sp (Lop op args res :: bb) rs m) E0 (Block s f sp bb rs' m) - | exec_Lload: forall s f sp chunk addr args dst bb rs m a v rs', + | exec_Lload: forall s f sp trap chunk addr args dst bb rs m a v rs', eval_addressing ge sp addr (reglist rs args) = Some a -> Mem.loadv chunk m a = Some v -> rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) -> - step (Block s f sp (Lload chunk addr args dst :: bb) rs m) + step (Block s f sp (Lload trap chunk addr args dst :: bb) rs m) + E0 (Block s f sp bb rs' m) + | exec_Lload_notrap1: forall s f sp chunk addr args dst bb rs m rs', + eval_addressing ge sp addr (reglist rs args) = None -> + rs' = Locmap.set (R dst) (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (Block s f sp (Lload NOTRAP chunk addr args dst :: bb) rs m) + E0 (Block s f sp bb rs' m) + | exec_Lload_notrap2: forall s f sp chunk addr args dst bb rs m a rs', + eval_addressing ge sp addr (reglist rs args) = Some a -> + Mem.loadv chunk m a = None -> + rs' = Locmap.set (R dst) (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (Block s f sp (Lload NOTRAP chunk addr args dst :: bb) rs m) E0 (Block s f sp bb rs' m) | exec_Lgetstack: forall s f sp sl ofs ty dst bb rs m rs', rs' = Locmap.set (R dst) (rs (S sl ofs ty)) (undef_regs (destroyed_by_getstack sl) rs) -> diff --git a/backend/Linear.v b/backend/Linear.v index 447c6ba6..1443f795 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -28,7 +28,7 @@ Inductive instruction: Type := | Lgetstack: slot -> Z -> typ -> mreg -> instruction | Lsetstack: mreg -> slot -> Z -> typ -> instruction | Lop: operation -> list mreg -> mreg -> instruction - | Lload: memory_chunk -> addressing -> list mreg -> mreg -> instruction + | Lload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lcall: signature -> mreg + ident -> instruction | Ltailcall: signature -> mreg + ident -> instruction @@ -160,11 +160,28 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Lop op args res :: b) rs m) E0 (State s f sp b rs' m) | exec_Lload: - forall s f sp chunk addr args dst b rs m a v rs', + forall s f sp trap chunk addr args dst b rs m a v rs', eval_addressing ge sp addr (reglist rs args) = Some a -> Mem.loadv chunk m a = Some v -> rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) -> - step (State s f sp (Lload chunk addr args dst :: b) rs m) + step (State s f sp (Lload trap chunk addr args dst :: b) rs m) + E0 (State s f sp b rs' m) + | exec_Lload_notrap1: + forall s f sp chunk addr args dst b rs m rs', + eval_addressing ge sp addr (reglist rs args) = None -> + rs' = Locmap.set (R dst) + (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (State s f sp (Lload NOTRAP chunk addr args dst :: b) rs m) + E0 (State s f sp b rs' m) + | exec_Lload_notrap2: + forall s f sp chunk addr args dst b rs m a rs', + eval_addressing ge sp addr (reglist rs args) = Some a -> + Mem.loadv chunk m a = None -> + rs' = Locmap.set (R dst) + (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (State s f sp (Lload NOTRAP chunk addr args dst :: b) rs m) E0 (State s f sp b rs' m) | exec_Lstore: forall s f sp chunk addr args src b rs m m' a rs', diff --git a/backend/Linearize.v b/backend/Linearize.v index 2cfa4d3c..4216958c 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -163,8 +163,8 @@ Fixpoint linearize_block (b: LTL.bblock) (k: code) : code := | nil => k | LTL.Lop op args res :: b' => Lop op args res :: linearize_block b' k - | LTL.Lload chunk addr args dst :: b' => - Lload chunk addr args dst :: linearize_block b' k + | LTL.Lload trap chunk addr args dst :: b' => + Lload trap chunk addr args dst :: linearize_block b' k | LTL.Lgetstack sl ofs ty dst :: b' => Lgetstack sl ofs ty dst :: linearize_block b' k | LTL.Lsetstack src sl ofs ty :: b' => diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 1fe23a9d..da66b6ff 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -76,7 +76,7 @@ Definition wt_instr (i: instruction) : bool := let (targs, tres) := type_of_operation op in subtype tres (mreg_type res) end - | Lload chunk addr args dst => + | Lload trap chunk addr args dst => subtype (type_of_chunk chunk) (mreg_type dst) | Ltailcall sg ros => zeq (size_arguments sg) 0 @@ -332,6 +332,20 @@ Local Opaque mreg_type. apply wt_setreg. eapply Val.has_subtype; eauto. destruct a; simpl in H0; try discriminate. eapply Mem.load_type; eauto. apply wt_undef_regs; auto. +- (* load notrap1 *) + simpl in *; InvBooleans. + econstructor; eauto. + apply wt_setreg. eapply Val.has_subtype; eauto. + unfold default_notrap_load_value. + constructor. + apply wt_undef_regs; auto. +- (* load notrap2 *) + simpl in *; InvBooleans. + econstructor; eauto. + apply wt_setreg. eapply Val.has_subtype; eauto. + unfold default_notrap_load_value. + constructor. + apply wt_undef_regs; auto. - (* store *) simpl in *; InvBooleans. econstructor. eauto. eauto. eauto. diff --git a/backend/RTL.v b/backend/RTL.v index 95fa1f82..29a49311 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -195,8 +195,6 @@ Definition find_function end end. -Definition default_notrap_load_value (chunk : memory_chunk) := Vundef. - (** The transitions are presented as an inductive predicate [step ge st1 t st2], where [ge] is the global environment, [st1] the initial state, [st2] the final state, and [t] the trace diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 4f95ac9b..d3b8a9f0 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -441,6 +441,31 @@ Proof. rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. +- (* Lload notrap1 *) + exploit eval_addressing_lessdef_none. apply reglist_lessdef; eauto. eassumption. + left; simpl; econstructor; split. + eapply exec_Lload_notrap1. + rewrite <- H0. + apply eval_addressing_preserved. exact symbols_preserved. eauto. + econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. +- (* Lload notrap2 *) + exploit eval_addressing_lessdef. apply reglist_lessdef; eauto. eauto. + intros (ta & EV & LD). + destruct (Mem.loadv chunk tm ta) eqn:Htload. + { + left; simpl; econstructor; split. + eapply exec_Lload. + rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved. + exact Htload. eauto. + econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. + } + { + left; simpl; econstructor; split. + eapply exec_Lload_notrap2. + rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved. + exact Htload. eauto. + econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. + } - (* Lgetstack *) left; simpl; econstructor; split. econstructor; eauto. |