(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Multi-way branches (``switch'' statements) and their compilation to comparison trees. *)
(** A multi-way branch is composed of a list of (key, action) pairs, plus a default action.  *)
Definition table : Type := list (Z * nat).
Fixpoint switch_target (n: Z) (dfl: nat) (cases: table)
{struct cases} : nat :=
match cases with
| nil => dfl
| (key, action) :: rem =>
if zeq n key then action else switch_target n dfl rem
end.
Inductive switch_argument: bool -> val -> Z -> Prop :=
| switch_argument_32: forall i,
switch_argument false (Vint i) (Int.unsigned i)
| switch_argument_64: forall i,
switch_argument true (Vlong i) (Int64.unsigned i).
(** Multi-way branches are translated to comparison trees. Each node of the tree performs either - an equality against one of the keys; - or a "less than" test against one of the keys; - or a computed branch (jump table) against a range of key values. *)
Inductive comptree : Type :=
| CTaction (act: nat)
| CTifeq (key: Z) (act: nat) (cne: comptree)
| CTiflt (key: Z) (clt: comptree) (cge: comptree)
| CTjumptable (ofs: Z) (sz: Z) (acts: list nat) (cother: comptree).
Section COMPTREE.
Variable modulus: Z.
Hypothesis modulus_pos: modulus > 0.
Fixpoint comptree_match (n: Z) (t: comptree) {struct t}: option nat :=
match t with
| CTaction act => Some act
| CTifeq key act t' =>
if zeq n key then Some act else comptree_match n t'
| CTiflt key t1 t2 =>
if zlt n key then comptree_match n t1 else comptree_match n t2
| CTjumptable ofs sz tbl t' =>
let delta := (n - ofs) mod modulus in
if zlt delta sz
then list_nth_z tbl (delta mod Int.modulus)
else comptree_match n t'
end.
(** The translation from a table to a comparison tree is performed by untrusted Caml code (function [compile_switch] in file [RTLgenaux.ml]).  In Coq, we validate a posteriori the result of this function.  In other terms, we now develop and prove correct Coq functions that take a table and a comparison tree, and check that their semantics are equivalent. *)
Fixpoint split_lt (pivot: Z) (cases: table)
{struct cases} : table * table :=
match cases with
| nil => (nil, nil)
| (key, act) :: rem =>
let (l, r) := split_lt pivot rem in
if zlt key pivot
then ((key, act) :: l, r)
else (l, (key, act) :: r)
end.
Fixpoint split_eq (pivot: Z) (cases: table)
{struct cases} : option nat * table :=
match cases with
| nil => (None, nil)
| (key, act) :: rem =>
let (same, others) := split_eq pivot rem in
if zeq key pivot
then (Some act, others)
else (same, (key, act) :: others)
end.
Fixpoint split_between (dfl: nat) (ofs sz: Z) (cases: table)
{struct cases} : ZMap.t nat * table :=
match cases with
| nil => (ZMap.init dfl, nil)
| (key, act) :: rem =>
let (inside, outside) := split_between dfl ofs sz rem in
if zlt ((key - ofs) mod modulus) sz
then (ZMap.set key act inside, outside)
else (inside, (key, act) :: outside)
end.
Definition refine_low_bound (v lo: Z) :=
if zeq v lo then lo + 1 else lo.
Definition refine_high_bound (v hi: Z) :=
if zeq v hi then hi - 1 else hi.
Fixpoint validate_jumptable (cases: ZMap.t nat)
(tbl: list nat) (n: Z) {struct tbl} : bool :=
match tbl with
| nil => true
| act :: rem =>
Nat.eqb act (ZMap.get n cases)
&& validate_jumptable cases rem (Z.succ n)
end.
Fixpoint validate (default: nat) (cases: table) (t: comptree)
(lo hi: Z) {struct t} : bool :=
match t with
| CTaction act =>
match cases with
| nil =>
Nat.eqb act default
| (key1, act1) :: _ =>
zeq key1 lo && zeq lo hi && Nat.eqb act act1
end
| CTifeq pivot act t' =>
zle 0 pivot && zlt pivot modulus &&
match split_eq pivot cases with
| (None, _) =>
false
| (Some act', others) =>
Nat.eqb act act'
&& validate default others t'
(refine_low_bound pivot lo)
(refine_high_bound pivot hi)
end
| CTiflt pivot t1 t2 =>
zle 0 pivot && zlt pivot modulus &&
match split_lt pivot cases with
| (lcases, rcases) =>
validate default lcases t1 lo (pivot - 1)
&& validate default rcases t2 pivot hi
end
| CTjumptable ofs sz tbl t' =>
let tbl_len := list_length_z tbl in
zle 0 ofs && zlt ofs modulus &&
zle 0 sz && zlt sz modulus &&
zle (ofs + sz) modulus && zle sz tbl_len && zlt sz Int.modulus &&
match split_between default ofs sz cases with
| (inside, outside) =>
validate_jumptable inside tbl ofs
&& validate default outside t' lo hi
end
end.
Definition validate_switch (default: nat) (cases: table) (t: comptree) :=
validate default cases t 0 (modulus - 1).
(** Structural properties checked by validation *)
Inductive wf_comptree: comptree -> Prop :=
| wf_action: forall act,
wf_comptree (CTaction act)
| wf_ifeq: forall key act cne,
0 <= key < modulus -> wf_comptree cne -> wf_comptree (CTifeq key act cne)
| wf_iflt: forall key clt cge,
0 <= key < modulus -> wf_comptree clt -> wf_comptree cge -> wf_comptree (CTiflt key clt cge)
| wf_jumptable: forall ofs sz acts cother,
0 <= ofs < modulus -> 0 <= sz < modulus ->
wf_comptree cother ->
wf_comptree (CTjumptable ofs sz acts cother).

(* Specifications: *)
Lemma validate_wf:
forall default t cases lo hi,
validate default cases t lo hi = true ->
wf_comptree t.
Lemma validate_wf:
forall default t cases lo hi,
validate default cases t lo hi = true ->
wf_comptree t.