(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)
(** Typing rules and a type inference algorithm for RTL. *)
(** * The type system *)
(** Like Cminor and all intermediate languages, RTL can be equipped with a simple type system that statically guarantees that operations and addressing modes are applied to the right number of arguments and that the arguments are of the correct types.   The type algebra is very simple, consisting of the four types [Tint] (for integers and pointers), [Tfloat] (for double-precision floats), [Tlong] (for 64-bit integers) and [Tsingle] (for single-precision floats).  Additionally, we impose that each pseudo-register has the same type throughout the function.  This requirement helps with register allocation, enabling each pseudo-register to be mapped to a single hardware register or stack location of the correct type.  Finally, we also check that the successors of instructions are valid, i.e. refer to non-empty nodes in the CFG.  The typing judgement for instructions is of the form [wt_instr f env instr], where [f] is the current function (used to type-check [Ireturn] instructions) and [env] is a typing environment associating types to pseudo-registers.  Since pseudo-registers have unique types throughout the function, the typing environment does not change during type-checking of individual instructions.  One point to note is that we have one polymorphic operator, [Omove], which can work over both integers and floats. *)
Definition regenv := reg -> typ.
Section WT_INSTR.
Variable funct: function.
Variable env: regenv.
Definition valid_successor (s: node) : Prop :=
exists i, funct.(fn_code)!s = Some i.
Definition type_of_builtin_arg (a: builtin_arg reg) : typ :=
match a with
| BA r => env r
| BA_int _ => Tint
| BA_long _ => Tlong
| BA_float _ => Tfloat
| BA_single _ => Tsingle
| BA_loadstack chunk ofs => type_of_chunk chunk
| BA_addrstack ofs => Tptr
| BA_loadglobal chunk id ofs => type_of_chunk chunk
| BA_addrglobal id ofs => Tptr
| BA_splitlong hi lo => Tlong
| BA_addptr a1 a2 => Tptr
end.
Definition type_of_builtin_res (r: builtin_res reg) : typ :=
match r with
| BR r => env r
| _    => Tint
end.
Inductive wt_instr : instruction -> Prop :=
| wt_Inop:
forall s,
valid_successor s ->
wt_instr (Inop s)
| wt_Iopmove:
forall r1 r s,
env r = env r1 ->
valid_successor s ->
wt_instr (Iop Omove (r1 :: nil) r s)
| wt_Iop:
forall op args res s,
op <> Omove ->
map env args = fst (type_of_operation op) ->
env res = snd (type_of_operation op) ->
valid_successor s ->
wt_instr (Iop op args res s)
| wt_Iload:
forall chunk addr args dst s,
map env args = type_of_addressing addr ->
env dst = type_of_chunk chunk ->
valid_successor s ->
wt_instr (Iload chunk addr args dst s)
| wt_Istore:
forall chunk addr args src s,
map env args = type_of_addressing addr ->
env src = type_of_chunk chunk ->
valid_successor s ->
wt_instr (Istore chunk addr args src s)
| wt_Icall:
forall sig ros args res s,
match ros with inl r => env r = Tptr | inr s => True end ->
map env args = sig.(sig_args) ->
env res = proj_sig_res sig ->
valid_successor s ->
wt_instr (Icall sig ros args res s)
| wt_Itailcall:
forall sig ros args,
match ros with inl r => env r = Tptr | inr s => True end ->
map env args = sig.(sig_args) ->
sig.(sig_res) = funct.(fn_sig).(sig_res) ->
tailcall_possible sig ->
wt_instr (Itailcall sig ros args)
| wt_Ibuiltin:
forall ef args res s,
match ef with
| EF_annot _ _ _ | EF_debug _ _ _ => True
| _ => map type_of_builtin_arg args = (ef_sig ef).(sig_args)
end ->
type_of_builtin_res res = proj_sig_res (ef_sig ef) ->
valid_successor s ->
wt_instr (Ibuiltin ef args res s)
| wt_Icond:
forall cond args s1 s2,
map env args = type_of_condition cond ->
valid_successor s1 ->
valid_successor s2 ->
wt_instr (Icond cond args s1 s2)
| wt_Ijumptable:
forall arg tbl,
env arg = Tint ->
(forall s, In s tbl -> valid_successor s) ->
list_length_z tbl * 4 <= Int.max_unsigned ->
wt_instr (Ijumptable arg tbl)
| wt_Ireturn_none:
funct.(fn_sig).(sig_res) = None ->
wt_instr (Ireturn None)
| wt_Ireturn_some:
forall arg ty,
funct.(fn_sig).(sig_res) = Some ty ->
env arg = ty ->
wt_instr (Ireturn (Some arg)).
End WT_INSTR.
(** A function [f] is well-typed w.r.t. a typing environment [env], written [wt_function env f], if all instructions are well-typed, parameters agree in types with the function signature, and parameters are pairwise distinct. *)
Record wt_function (f: function) (env: regenv): Prop :=
mk_wt_function {
wt_params:
map env f.(fn_params) = f.(fn_sig).(sig_args);
wt_norepet:
list_norepet f.(fn_params);
wt_instrs:
forall pc instr,
f.(fn_code)!pc = Some instr -> wt_instr f env instr;
wt_entrypoint:
valid_successor f f.(fn_entrypoint)
}.
Inductive wt_fundef: fundef -> Prop :=
| wt_fundef_external: forall ef,
wt_fundef (External ef)
| wt_function_internal: forall f env,
wt_function f env ->
wt_fundef (Internal f).
Definition wt_program (p: program): Prop :=
forall i f, In (i, Gfun f) (prog_defs p) -> wt_fundef f.
(** * Type inference *)
(** Type inference reuses the generic solver for unification constraints defined in module [Unityping]. *)
Module RTLtypes <: TYPE_ALGEBRA.
Definition t := typ.
Definition eq := typ_eq.
Definition default := Tint.
End RTLtypes.
Module S := UniSolver(RTLtypes).
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 opt_typ_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, f.(fn_sig).(sig_res) with
| None, None => OK e
| Some r, Some t => S.set e r t
| _, _ => 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.

(* Specifications: *)
Lemma type_ros_sound:
forall e ros e' te, type_ros e ros = OK e' -> S.satisf te e' ->
match ros with inl r => te r = Tptr | inr s => True end.
Lemma check_successor_sound:
forall s x, check_successor s = OK x -> valid_successor f s.