[passes] pass to check the typing tags of the program / expressions

This commit is contained in:
Arnaud DABY-SEESARAM 2022-12-15 18:33:04 +01:00
parent db5c584435
commit 8582337774
8 changed files with 286 additions and 205 deletions

View File

@ -69,8 +69,6 @@ and t_node =
n_local_vars: t_varlist; n_local_vars: t_varlist;
n_equations: t_eqlist; n_equations: t_eqlist;
n_automata: t_autolist; n_automata: t_autolist;
n_inputs_type : full_ty;
n_outputs_type : full_ty;
} }
type t_nodelist = t_node list type t_nodelist = t_node list

View File

@ -26,7 +26,7 @@ let exec_passes ast main_fn verbose debug passes f =
let _ = let _ =
(** Usage and argument parsing. *) (** Usage and argument parsing. *)
let default_passes = ["pre2vars"; "linearization"; "equations_ordering"] in let default_passes = ["pre2vars"; "linearization"; "equations_ordering"] in
let sanity_passes = ["chkvar_init_unicity"] in let sanity_passes = ["chkvar_init_unicity"; "check_typing"] in
let usage_msg = let usage_msg =
"Usage: main [-passes p1,...,pn] [-ast] [-verbose] [-debug] \ "Usage: main [-passes p1,...,pn] [-ast] [-verbose] [-debug] \
[-o output_file] [-m main_function] source_file\n" in [-o output_file] [-m main_function] source_file\n" in
@ -72,6 +72,7 @@ let _ =
("chkvar_init_unicity", Passes.chkvar_init_unicity); ("chkvar_init_unicity", Passes.chkvar_init_unicity);
("linearization", Passes.pass_linearization); ("linearization", Passes.pass_linearization);
("equations_ordering", Passes.pass_eq_reordering); ("equations_ordering", Passes.pass_eq_reordering);
("check_typing", Passes.pass_typing);
]; ];
(** Main functionality below *) (** Main functionality below *)

View File

@ -198,9 +198,7 @@ node_content:
n_outputs = (t_out, e_out); n_outputs = (t_out, e_out);
n_local_vars = $10; n_local_vars = $10;
n_equations = eqs; n_equations = eqs;
n_automata = aut; n_automata = aut; } in
n_inputs_type = t_in;
n_outputs_type = t_out; } in
if Hashtbl.find_opt defined_nodes node_name <> None if Hashtbl.find_opt defined_nodes node_name <> None
then raise (MyParsingError then raise (MyParsingError
(Format.asprintf "The node %s is already defined." (Format.asprintf "The node %s is already defined."
@ -386,8 +384,8 @@ expr:
{ let name = $1 in { let name = $1 in
let node = fetch_node name in let node = fetch_node name in
let args = $3 in let args = $3 in
if type_exp args = node.n_inputs_type if type_exp args = fst node.n_inputs
then EApp (node.n_outputs_type, fetch_node name, args) then EApp (fst node.n_outputs, fetch_node name, args)
else raise (MyParsingError ("The application does not type check!", else raise (MyParsingError ("The application does not type check!",
current_location())) current_location()))
} }

View File

@ -2,6 +2,7 @@
open Ast open Ast
open Passes_utils open Passes_utils
open Utils
let pre2vars verbose debug main_fn = let pre2vars verbose debug main_fn =
let rec all_pre expr = let rec all_pre expr =
@ -13,7 +14,7 @@ let pre2vars verbose debug main_fn =
in in
let rec pre_push expr : t_expression = let rec pre_push expr : t_expression =
match expr with match expr with
| EVar _ -> EMonOp (Utils.type_exp expr, MOp_pre, expr) | EVar _ -> EMonOp (type_exp expr, MOp_pre, expr)
| EConst _ -> expr (** pre(c) = c for any constant c *) | EConst _ -> expr (** pre(c) = c for any constant c *)
| EMonOp (ty, mop, expr) -> | EMonOp (ty, mop, expr) ->
begin begin
@ -82,7 +83,7 @@ let pre2vars verbose debug main_fn =
let arg = aux arg in let arg = aux arg in
EApp (ty, node, arg) EApp (ty, node, arg)
in in
expression_pass (Utils.somify aux) expression_pass (somify aux)
let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option = let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option =
let aux (node: t_node) : t_node option = let aux (node: t_node) : t_node option =
@ -92,7 +93,7 @@ let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option
| Some num -> Hashtbl.replace h n (num + 1) | Some num -> Hashtbl.replace h n (num + 1)
in in
let incr_eq h (((_, patt), _): t_equation) = let incr_eq h (((_, patt), _): t_equation) =
List.iter (fun v -> incr_aux h (Utils.name_of_var v)) patt List.iter (fun v -> incr_aux h (name_of_var v)) patt
in in
let rec incr_eqlist h = function let rec incr_eqlist h = function
| [] -> () | [] -> ()
@ -161,14 +162,14 @@ let pass_linearization verbose debug main_fn =
| ETuple (_, hexps :: texps) -> | ETuple (_, hexps :: texps) ->
debug "An ETuple has been recognized, inlining..."; debug "An ETuple has been recognized, inlining...";
let p1, p2 = let p1, p2 =
Utils.list_select list_select
(List.length (Utils.type_exp hexps)) (List.length (type_exp hexps))
(snd pat) in (snd pat) in
let t1 = List.flatten (List.map Utils.type_var p1) in let t1 = List.flatten (List.map type_var p1) in
let t2 = List.flatten (List.map Utils.type_var p2) in let t2 = List.flatten (List.map type_var p2) in
((t1, p1), hexps) ((t1, p1), hexps)
:: (tpl ((t2, p2), :: (tpl ((t2, p2),
ETuple (List.flatten (List.map Utils.type_exp texps), texps))) ETuple (List.flatten (List.map type_exp texps), texps)))
| ETuple (_, []) -> [] | ETuple (_, []) -> []
| _ -> [(pat, exp)] | _ -> [(pat, exp)]
in in
@ -187,8 +188,6 @@ let pass_linearization verbose debug main_fn =
n_local_vars = new_locvars; n_local_vars = new_locvars;
n_equations = new_equations; n_equations = new_equations;
n_automata = node.n_automata; n_automata = node.n_automata;
n_inputs_type = node.n_inputs_type;
n_outputs_type = node.n_outputs_type;
} }
in in
node_pass node_lin node_pass node_lin
@ -203,22 +202,97 @@ let pass_eq_reordering verbose debug main_fn ast =
(fun (patt, expr) -> (fun (patt, expr) ->
List.for_all List.for_all
(fun v -> List.mem v init_vars) (fun v -> List.mem v init_vars)
(Utils.vars_of_expr expr)) (vars_of_expr expr))
remaining_equations with remaining_equations with
| [] -> raise EquationOrderingIssue | [] -> raise (PassExn "[equation ordering] The equations cannot be ordered.")
| h :: t -> | h :: t ->
let init_vars = let init_vars =
List.fold_left List.fold_left
(fun acc vs -> (fun acc vs ->
acc @ (Utils.vars_of_patt (fst vs))) init_vars (h :: t) in acc @ (vars_of_patt (fst vs))) init_vars (h :: t) in
pick_equations init_vars (eqs@(h :: t)) pick_equations init_vars (eqs@(h :: t))
(List.filter (fun eq -> List.for_all (fun e -> eq <> e) (h :: t)) remaining_equations) (List.filter (fun eq -> List.for_all (fun e -> eq <> e) (h :: t)) remaining_equations)
end end
in in
let node_eq_reorganising (node: t_node): t_node option = let node_eq_reorganising (node: t_node): t_node option =
let init_vars = List.map Utils.name_of_var (snd node.n_inputs) in let init_vars = List.map name_of_var (snd node.n_inputs) in
try
begin
match pick_equations init_vars [] node.n_equations with match pick_equations init_vars [] node.n_equations with
| None -> None | None -> None
| Some eqs -> Some { node with n_equations = eqs } | Some eqs -> Some { node with n_equations = eqs }
end
with PassExn err -> (verbose err; None)
in in
node_pass node_eq_reorganising ast node_pass node_eq_reorganising ast
let pass_typing verbose debug main_fn ast =
let htbl = Hashtbl.create (List.length ast) in
let () = debug "[typing verification]" in
let () = List.iter
(fun n -> Hashtbl.add htbl n.n_name (fst n.n_inputs, fst n.n_outputs))
ast in
let rec check_varlist vl =
let t = fst vl in
let l = snd vl in
match t, l with
| [], [] -> true
| TInt :: t, IVar _ :: l -> check_varlist (t, l)
| TBool :: t, BVar _ :: l -> check_varlist (t, l)
| TReal :: t, RVar _ :: l -> check_varlist (t, l)
| _, _ -> false
in
let rec check_expr vl = function
| EVar (t, v) -> t = type_var v
| EMonOp (t, _, e) -> check_expr vl e && type_exp e = t
| EBinOp (t, _, e, e') -> check_expr vl e && check_expr vl e'
&& t = type_exp e && t = type_exp e'
| ETriOp (t, _, c, e, e') ->
check_expr vl e && check_expr vl e' && check_expr vl c
&& type_exp c = [TBool] && type_exp e = t && type_exp e' = t
| EComp (t, _, e, e') ->
check_expr vl e && check_expr vl e' && t = [TBool]
| EWhen (t, e, e') ->
check_expr vl e && check_expr vl e'
&& t = type_exp e && [TBool] = type_exp e'
| EReset (t, e, e') ->
check_expr vl e && check_expr vl e' && t = type_exp e && type_exp e' = [TBool]
| EConst (t, c) -> type_const c = t
| ETuple (t, l) ->
List.for_all (check_expr vl) l
&& t = List.flatten (List.map type_exp l)
| EApp (t, n, e) ->
check_expr vl e && t = (fst n.n_outputs) && type_exp e = (fst n.n_inputs)
in
let check_equation vl ((peq, eeq): t_equation) =
if check_varlist peq
then
if check_expr vl eeq
then fst peq = type_exp eeq
else false
else false
in
let rec check_equations vl = function
| [] -> true
| eq :: eqs ->
if check_equation vl eq
then check_equations vl eqs
else false
in
let check_one_node node =
check_varlist (node.n_inputs)
&& check_varlist (node.n_outputs)
&& check_varlist (node.n_local_vars)
&& check_equations
(varlist_concat node.n_inputs
(varlist_concat node.n_outputs node.n_local_vars))
node.n_equations
in
let rec aux = function
| [] -> Some ast
| n :: nodes ->
if check_one_node n
then aux nodes
else None
in aux ast

View File

@ -18,8 +18,6 @@ let equation_pass (f: t_equation -> t_equation option) ast: t_nodelist option =
n_local_vars = node.n_local_vars; n_local_vars = node.n_local_vars;
n_equations = eqs; n_equations = eqs;
n_automata = node.n_automata; n_automata = node.n_automata;
n_inputs_type = node.n_inputs_type;
n_outputs_type = node.n_outputs_type;
} }
in in
node_pass aux ast node_pass aux ast
@ -32,4 +30,4 @@ let expression_pass f: t_nodelist -> t_nodelist option =
in in
equation_pass aux equation_pass aux
exception EquationOrderingIssue exception PassExn of string

View File

@ -1,4 +1,5 @@
node diagonal_int (i: int) returns (o1, o2 : int); node diagonal_int (i: int) returns (o1, o2 : int);
let i: int;
let let
(o1, o2) = (i, i); (o1, o2) = (i, i);
tel tel

View File

@ -1,4 +1,7 @@
node diagonal_int (i: int) returns (o1, o2 : int); node diagonal_int (i: int) returns (o1, o2 : int);
var y: int;
let let
(o1, o2) = (i, i); o2 = y;
y = i;
o1 = i;
tel tel

View File

@ -24,6 +24,11 @@ let rec list_chk v = function
exception MyParsingError of (string * location) exception MyParsingError of (string * location)
let type_const = function
| CReal _ -> [TReal]
| CInt _ -> [TInt ]
| CBool _ -> [TBool]
let type_var (v: t_var) = let type_var (v: t_var) =
match v with match v with
| IVar _ -> [TInt] | IVar _ -> [TInt]
@ -77,3 +82,6 @@ let rec vars_of_expr (expr: t_expression) : ident list =
(vars_of_expr e) @ (vars_of_expr e') @ (vars_of_expr e'') (vars_of_expr e) @ (vars_of_expr e') @ (vars_of_expr e'')
| ETuple (_, l) -> List.flatten (List.map vars_of_expr l) | ETuple (_, l) -> List.flatten (List.map vars_of_expr l)
let rec varlist_concat (l1: t_varlist) (l2: t_varlist): t_varlist =
(fst l1 @ fst l2, snd l1 @ snd l2)