Section INFERENCE.
Local Open Scope error_monad_scope.
Variable f: function.
(** Checking the validity of successor nodes. *)
Definition check_successor (s: node): res unit :=
match f.(fn_code)!s with
| None => Error (MSG "bad successor " :: POS s :: nil)
| Some i => OK tt
end.
Fixpoint check_successors (sl: list node): res unit :=
match sl with
| nil => OK tt
| s1 :: sl' => do x <- check_successor s1; check_successors sl'
end.
(** Check structural constraints and process / record all type constraints. *)
Definition type_ros (e: S.typenv) (ros: reg + ident) : res S.typenv :=
match ros with
| inl r => S.set e r Tptr
| inr s => OK e
end.
Definition is_move (op: operation) : bool :=
match op with Omove => true | _ => false end.
Definition type_expect (e: S.typenv) (t1 t2: typ) : res S.typenv :=
if typ_eq t1 t2 then OK e else Error(msg "unexpected type").
Definition type_builtin_arg (e: S.typenv) (a: builtin_arg reg) (ty: typ) : res S.typenv :=
match a with
| BA r => S.set e r ty
| BA_int _ => type_expect e ty Tint
| BA_long _ => type_expect e ty Tlong
| BA_float _ => type_expect e ty Tfloat
| BA_single _ => type_expect e ty Tsingle
| BA_loadstack chunk ofs => type_expect e ty (type_of_chunk chunk)
| BA_addrstack ofs => type_expect e ty Tptr
| BA_loadglobal chunk id ofs => type_expect e ty (type_of_chunk chunk)
| BA_addrglobal id ofs => type_expect e ty Tptr
| BA_splitlong hi lo => type_expect e ty Tlong
| BA_addptr a1 a2 => type_expect e ty Tptr
end.
Fixpoint type_builtin_args (e: S.typenv) (al: list (builtin_arg reg)) (tyl: list typ) : res S.typenv :=
match al, tyl with
| nil, nil => OK e
| a1 :: al, ty1 :: tyl =>
do e1 <- type_builtin_arg e a1 ty1; type_builtin_args e1 al tyl
| _, _ =>
Error (msg "builtin arity mismatch")
end.
Definition type_builtin_res (e: S.typenv) (a: builtin_res reg) (ty: typ) : res S.typenv :=
match a with
| BR r => S.set e r ty
| _    => type_expect e ty Tint
end.
Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv :=
match i with
| Inop s =>
do x <- check_successor s; OK e
| Iop op args res s =>
do x <- check_successor s;
if is_move op then
match args with
| arg :: nil => do (changed, e') <- S.move e res arg; OK e'
| _ => Error (msg "ill-formed move")
end
else
(let (targs, tres) := type_of_operation op in
do e1 <- S.set_list e args targs; S.set e1 res tres)
| Iload chunk addr args dst s =>
do x <- check_successor s;
do e1 <- S.set_list e args (type_of_addressing addr);
S.set e1 dst (type_of_chunk chunk)
| Istore chunk addr args src s =>
do x <- check_successor s;
do e1 <- S.set_list e args (type_of_addressing addr);
S.set e1 src (type_of_chunk chunk)
| Icall sig ros args res s =>
do x <- check_successor s;
do e1 <- type_ros e ros;
do e2 <- S.set_list e1 args sig.(sig_args);
S.set e2 res (proj_sig_res sig)
| Itailcall sig ros args =>
do e1 <- type_ros e ros;
do e2 <- S.set_list e1 args sig.(sig_args);
if rettype_eq sig.(sig_res) f.(fn_sig).(sig_res) then
if tailcall_is_possible sig
then OK e2
else Error(msg "tailcall not possible")
else Error(msg "bad return type in tailcall")
| Ibuiltin ef args res s =>
let sig := ef_sig ef in
do x <- check_successor s;
do e1 <-
match ef with
| EF_annot _ _ _ | EF_debug _ _ _ => OK e
| _ => type_builtin_args e args sig.(sig_args)
end;
type_builtin_res e1 res (proj_sig_res sig)
| Icond cond args s1 s2 =>
do x1 <- check_successor s1;
do x2 <- check_successor s2;
S.set_list e args (type_of_condition cond)
| Ijumptable arg tbl =>
do x <- check_successors tbl;
do e1 <- S.set e arg Tint;
if zle (list_length_z tbl * 4) Int.max_unsigned
then OK e1
else Error(msg "jumptable too big")
| Ireturn optres =>
match optres, rettype_eq f.(fn_sig).(sig_res) Tvoid with
| None, left _ => OK e
| Some r, right _ => S.set e r (proj_sig_res f.(fn_sig))
| _, _ => Error(msg "bad return")
end
end.
Definition type_code (e: S.typenv): res S.typenv :=
PTree.fold (fun re pc i =>
match re with
| Error _ => re
| OK e =>
match type_instr e i with
| Error msg => Error(MSG "At PC " :: POS pc :: MSG ": " :: msg)
| OK e' => OK e'
end
end)
f.(fn_code) (OK e).
(** Solve remaining constraints *)
Definition check_params_norepet (params: list reg): res unit :=
if list_norepet_dec Reg.eq params
then OK tt
else Error(msg "duplicate parameters").
Definition type_function : res regenv :=
do e1 <- type_code S.initial;
do e2 <- S.set_list e1 f.(fn_params) f.(fn_sig).(sig_args);
do te <- S.solve e2;
do x1 <- check_params_norepet f.(fn_params);
do x2 <- check_successor f.(fn_entrypoint);
OK te.
(** ** Soundness proof *)
Remark type_ros_incr:
forall e ros e' te, type_ros e ros = OK e' -> S.satisf te e' -> S.satisf te e.
Hint Resolve type_ros_incr: ty.
Hint Resolve check_successor_sound: ty.
Remark type_expect_incr:
forall e ty1 ty2 e' te, type_expect e ty1 ty2 = OK e' -> S.satisf te e' -> S.satisf te e.
Hint Resolve type_expect_incr: ty.
Hint Resolve type_builtin_args_incr type_builtin_res_incr: ty.
(** ** Completeness proof *)
End INFERENCE.
(** * Type preservation during evaluation *)
(** The type system for RTL is not sound in that it does not guarantee progress: well-typed instructions such as [Icall] can fail because of run-time type tests (such as the equality between callee and caller's signatures).  However, the type system guarantees a type preservation property: if the execution does not fail because of a failed run-time test, the result values and register states match the static typing assumptions.  This preservation property will be useful later for the proof of semantic equivalence between [Linear] and [Mach]. Even though we do not need it for [RTL], we show preservation for [RTL] here, as a warm-up exercise and because some of the lemmas will be useful later. *)
Definition wt_regset (env: regenv) (rs: regset) : Prop :=
forall r, Val.has_type (rs#r) (env r).

Lemma wt_regset_setres:
forall env rs v res,
wt_regset env rs ->
Val.has_type v (type_of_builtin_res env res) ->
wt_regset env (regmap_setres res v rs).