(* *********************************************************************)
(*                                                                     *)
(*              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 INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Type-checking Linear code. *)
(** The rules are presented as boolean-valued functions so that we get an executable type-checker for free. *)
Section WT_INSTR.
Variable funct: function.
Definition slot_valid (sl: slot) (ofs: Z) (ty: typ): bool :=
match sl with
| Local => zle 0 ofs
| Outgoing => zle 0 ofs
| Incoming => In_dec Loc.eq (S Incoming ofs ty) (regs_of_rpairs (loc_parameters funct.(fn_sig)))
end
&& Zdivide_dec (typealign ty) ofs (typealign_pos ty).
Definition slot_writable (sl: slot) : bool :=
match sl with
| Local => true
| Outgoing => true
| Incoming => false
end.
Definition loc_valid (l: loc) : bool :=
match l with
| R r => true
| S Local ofs ty => slot_valid Local ofs ty
| S _ _ _ => false
end.
Fixpoint wt_builtin_res (ty: typ) (res: builtin_res mreg) : bool :=
match res with
| BR r => subtype ty (mreg_type r)
| BR_none => true
| BR_splitlong hi lo => wt_builtin_res Tint hi && wt_builtin_res Tint lo
end.
Definition wt_instr (i: instruction) : bool :=
match i with
| Lgetstack sl ofs ty r =>
subtype ty (mreg_type r) && slot_valid sl ofs ty
| Lsetstack r sl ofs ty =>
slot_valid sl ofs ty && slot_writable sl
| Lop op args res =>
match is_move_operation op args with
| Some arg =>
subtype (mreg_type arg) (mreg_type res)
| None =>
let (targs, tres) := type_of_operation op in
subtype tres (mreg_type res)
end
| Lload chunk addr args dst =>
subtype (type_of_chunk chunk) (mreg_type dst)
| Ltailcall sg ros =>
zeq (size_arguments sg) 0
| Lbuiltin ef args res =>
wt_builtin_res (proj_sig_res (ef_sig ef)) res
&& forallb loc_valid (params_of_builtin_args args)
| _ =>
true
end.
End WT_INSTR.
Definition wt_code (f: function) (c: code) : bool :=
forallb (wt_instr f) c.
Definition wt_function (f: function) : bool :=
wt_code f f.(fn_code).
(** Typing the run-time state. *)
Definition wt_locset (ls: locset) : Prop :=
forall l, Val.has_type (ls l) (Loc.type l).

(* Specifications: *)
Lemma wt_setreg:
forall ls r v,
Val.has_type v (mreg_type r) -> wt_locset ls -> wt_locset (Locmap.set (R r) v ls).
Lemma wt_setstack:
forall ls sl ofs ty v,
wt_locset ls -> wt_locset (Locmap.set (S sl ofs ty) v ls).
Lemma wt_undef_regs:
forall rs ls, wt_locset ls -> wt_locset (undef_regs rs ls).
Lemma wt_call_regs:
forall ls, wt_locset ls -> wt_locset (call_regs ls).
Lemma wt_return_regs:
forall caller callee,
wt_locset caller -> wt_locset callee -> wt_locset (return_regs caller callee).
Lemma wt_undef_caller_save_regs:
forall ls, wt_locset ls -> wt_locset (undef_caller_save_regs ls).
Lemma wt_init:
wt_locset (Locmap.init Vundef).
Lemma wt_setpair:
forall sg v rs,
Val.has_type v (proj_sig_res sg) ->
wt_locset rs ->
wt_locset (Locmap.setpair (loc_result sg) v rs).
Lemma wt_setres:
forall res ty v rs,
wt_builtin_res ty res = true ->
Val.has_type v ty ->
wt_locset rs ->
wt_locset (Locmap.setres res v rs).
Lemma wt_find_label:
forall f lbl c,
wt_function f = true ->
find_label lbl f.(fn_code) = Some c ->
wt_code f c = true.