Benjamin_Loison/Synchronous_reactive_systems
1
0
Fork 0
Code Issues 7 Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems

Browse Source
This commit is contained in:
Benjamin Loison 2022-12-15 19:52:02 +01:00
commit 72ba196142
11 changed files with 340 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitignore vendored
View File

@ -1,2 +1,10 @@
_build
tags
beamer.aux
beamer.log
beamer.nav
beamer.out
beamer.pdf
beamer.snm
beamer.toc
texput.log

39
beamer/beamer.tex
View File

@ -1,6 +1,5 @@
\documentclass{beamer}
\usepackage{tikz}
%\usepackage{minted}
\usetikzlibrary{positioning}
\usetheme{Darmstadt}
@ -43,42 +42,6 @@
\centering
\includegraphics[width=.75\textwidth]{imgs/gadt.png}
\end{figure}
%type _ t_var =
% | BVar: ident -> bool t_var
% | IVar: ident -> int t_var
% | RVar: ident -> real t_var
%
%type _ t_expression =
% | EVar: 'a t_var -> 'a t_expression
% | EMonOp: monop * 'a t_expression -> 'a t_expression
% | EBinOp: binop * 'a t_expression * 'a t_expression -> 'a t_expression
% | ETriOp: triop * bool t_expression * 'a t_expression * 'a t_expression -> 'a t_expression
% | EComp: compop * 'a t_expression * 'a t_expression -> bool t_expression
% | EConst: 'a const -> 'a t_expression
% | ETuple: 'a t_expression * 'b t_expression -> ('a * 'b) t_expression
% | EApp: (('a -> 'b) t_node) * 'a t_expression -> 'b t_expression
%
%and _ t_varlist =
% | NVar: 'a t_varlist
% | CVar: 'a t_var * 'b t_varlist -> ('a * 'b) t_varlist
%
%and 'a t_equation = 'a t_varlist * 'a t_expression
%
%and _ t_eqlist =
% | NEql: unit t_eqlist
% | CEql: 'a t_equation * 'b t_eqlist -> ('a * 'b) t_eqlist
%
%and _ t_node =
% | MakeNode:
% ident
% * 'i t_varlist * 'o t_varlist
% * 'l t_varlist * 'e t_eqlist
% -> ('i -> 'o) t_node
%
%type _ t_nodelist =
% | NNode: unit t_nodelist
% | CNode: ('a -> 'b) t_node * 'c t_nodelist -> (('a -> 'b) * 'c) t_nodelist
% \end{minted}
\end{frame}
\begin{frame}
\begin{block}{Pros of using GADTs}
@ -134,7 +97,7 @@
\section{Passes}
\begin{frame}{Passes}
\begin{block}
\begin{block}{Classification}
The passes of our compiler are functions of taking a program and either:
\begin{itemize}
\item returning a program if the pass succeeded

2
src/ast.ml
View File

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

20
src/main.ml
View File

@ -25,7 +25,8 @@ let exec_passes ast main_fn verbose debug passes f =
let _ =
(** Usage and argument parsing. *)
let default_passes = ["chkvar_init_unicity"; "pre2vars"; "linearization"] in
let default_passes = ["pre2vars"; "linearization"; "equations_ordering"] in
let sanity_passes = ["chkvar_init_unicity"; "check_typing"] in
let usage_msg =
"Usage: main [-passes p1,...,pn] [-ast] [-verbose] [-debug] \
[-o output_file] [-m main_function] source_file\n" in
@ -37,10 +38,14 @@ let _ =
let passes = ref [] in
let main_fn = ref "main" in
let source_file = ref "" in
let testopt = ref false in
let output_file = ref "out.c" in
let anon_fun filename = source_file := filename in
let speclist =
[
("-test", Arg.Set testopt, "Runs the sanity passes not only at the \
begining of the compilation, but also after \
each pass altering the AST.");
("-ast", Arg.Set ppast, "Only print the AST of the input file");
("-nop", Arg.Set nopopt, "Only computes the AST and execute the passes");
("-verbose", Arg.Set verbose, "Output some debug information");
@ -66,6 +71,8 @@ let _ =
("pre2vars", Passes.pre2vars);
("chkvar_init_unicity", Passes.chkvar_init_unicity);
("linearization", Passes.pass_linearization);
("equations_ordering", Passes.pass_eq_reordering);
("check_typing", Passes.pass_typing);
];
(** Main functionality below *)
@ -99,12 +106,19 @@ let _ =
end
in
let passes = List.map (fun (pass: string) -> (pass,
let passes =
List.map
(fun (pass: string) -> (pass,
match Hashtbl.find_opt passes_table pass with
| None ->
(exit_error (Format.sprintf "The pass %s does not exist.\n" pass); exit 0)
| Some f ->
(print_debug ("The pass "^pass^" has been selected.\n"); f))) !passes in
(print_debug ("The pass "^pass^" has been selected.\n"); f)))
(sanity_passes @
if !testopt
then List.flatten (List.map (fun p -> p :: sanity_passes) !passes)
else !passes)
in
print_debug (Format.asprintf "Initial AST (before executing any passes):\n%a"
Pp.pp_ast ast) ;

8
src/parser.mly
View File

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

141
src/passes.ml
View File

@ -2,6 +2,7 @@
open Ast
open Passes_utils
open Utils
let pre2vars verbose debug main_fn =
let rec all_pre expr =
@ -13,7 +14,7 @@ let pre2vars verbose debug main_fn =
in
let rec pre_push expr : t_expression =
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 *)
| EMonOp (ty, mop, expr) ->
begin
@ -47,8 +48,8 @@ let pre2vars verbose debug main_fn =
| EApp (ty, node, arg) ->
let arg = pre_push arg in
EApp (ty, node, arg)
in
let rec aux (expr: t_expression) =
in
let rec aux (expr: t_expression) =
match expr with
| EVar _ -> expr
| EMonOp (ty, mop, expr) ->
@ -81,18 +82,18 @@ let pre2vars verbose debug main_fn =
| EApp (ty, node, arg) ->
let arg = aux arg in
EApp (ty, node, arg)
in
expression_pass (Utils.somify aux)
in
expression_pass (somify aux)
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 =
let incr_aux h n =
match Hashtbl.find_opt h n with
| None -> failwith "todo, should not happend."
| Some num -> Hashtbl.replace h n (num + 1)
in
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
let rec incr_eqlist h = function
| [] -> ()
@ -151,23 +152,24 @@ let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option
else None
end
(** never purge -> failwith never executed! purge_initialized h; *)
in
node_pass aux
in
node_pass aux
let pass_linearization verbose debug main_fn =
let node_lin (node: t_node): t_node option =
let node_lin (node: t_node): t_node option =
let rec tpl ((pat, exp): t_equation) =
match exp with
| ETuple (_, hexps :: texps) ->
debug "An ETuple has been recognized, inlining...";
let p1, p2 =
Utils.list_select
(List.length (Utils.type_exp hexps))
list_select
(List.length (type_exp hexps))
(snd pat) in
let t1 = List.flatten (List.map Utils.type_var p1) in
let t2 = List.flatten (List.map Utils.type_var p2) in
let t1 = List.flatten (List.map type_var p1) in
let t2 = List.flatten (List.map type_var p2) in
((t1, p1), hexps)
:: (tpl ((t2, p2),
ETuple (List.flatten (List.map Utils.type_exp texps), texps)))
ETuple (List.flatten (List.map type_exp texps), texps)))
| ETuple (_, []) -> []
| _ -> [(pat, exp)]
in
@ -186,8 +188,111 @@ let pass_linearization verbose debug main_fn =
n_local_vars = new_locvars;
n_equations = new_equations;
n_automata = node.n_automata;
n_inputs_type = node.n_inputs_type;
n_outputs_type = node.n_outputs_type;
}
in
node_pass node_lin
let pass_eq_reordering verbose debug main_fn ast =
let rec pick_equations init_vars eqs remaining_equations =
match remaining_equations with
| [] -> Some eqs
| _ ->
begin
match List.filter
(fun (patt, expr) ->
List.for_all
(fun v -> List.mem v init_vars)
(vars_of_expr expr))
remaining_equations with
| [] -> raise (PassExn "[equation ordering] The equations cannot be ordered.")
| h :: t ->
let init_vars =
List.fold_left
(fun acc vs ->
acc @ (vars_of_patt (fst vs))) init_vars (h :: t) in
pick_equations init_vars (eqs@(h :: t))
(List.filter (fun eq -> List.for_all (fun e -> eq <> e) (h :: t)) remaining_equations)
end
in
node_pass node_lin
let node_eq_reorganising (node: t_node): t_node option =
let init_vars = List.map name_of_var (snd node.n_inputs) in
try
begin
match pick_equations init_vars [] node.n_equations with
| None -> None
| Some eqs -> Some { node with n_equations = eqs }
end
with PassExn err -> (verbose err; None)
in
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

4
src/passes_utils.ml
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_equations = eqs;
n_automata = node.n_automata;
n_inputs_type = node.n_inputs_type;
n_outputs_type = node.n_outputs_type;
}
in
node_pass aux ast
@ -31,3 +29,5 @@ let expression_pass f: t_nodelist -> t_nodelist option =
| Some expr -> Some (patt, expr)
in
equation_pass aux
exception PassExn of string

3
src/pp.ml
View File

@ -136,7 +136,8 @@ let pp_expression =
let rec pp_equations fmt: t_eqlist -> unit = function
| [] -> ()
| (patt, expr) :: eqs ->
Format.fprintf fmt "\t\t∗ Equation of type : %a\n\t\t left side: %a\n\t\t right side:\n%a\n%a"
Format.fprintf fmt "\t\t∗ Equation of type : %a\n\t\t left side: %a\n\
\t\t right side:\n%a\n\n%a"
debug_type_pp (Utils.type_exp expr)
pp_varlist patt
pp_expression expr

1
src/test.node
View File

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

5
src/test2.node
View File

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

27
src/utils.ml
View File

@ -22,7 +22,12 @@ let rec list_chk v = function
| [] -> false
| h :: t -> if h = v then true else list_chk v t
exception MyParsingError of (string * Ast.location)
exception MyParsingError of (string * location)
let type_const = function
| CReal _ -> [TReal]
| CInt _ -> [TInt ]
| CBool _ -> [TBool]
let type_var (v: t_var) =
match v with
@ -60,3 +65,23 @@ let rec fresh_var_name (l: t_varlist) n : ident =
if List.filter (fun v -> name_of_var v = name) (snd l) = []
then name
else fresh_var_name l n
let vars_of_patt patt = List.map name_of_var (snd patt)
let rec vars_of_expr (expr: t_expression) : ident list =
match expr with
| EConst _ -> []
| EVar (_, v) -> [name_of_var v]
(** pre (e) does not rely on anything in this round *)
| EMonOp (_, MOp_pre, _) -> []
| EApp (_, _, e) | EMonOp (_, _, e) -> vars_of_expr e
| EComp (_, _, e, e') | EReset (_, e, e') | EBinOp (_, _, e, e')
| EWhen (_, e, e') ->
(vars_of_expr e) @ (vars_of_expr e')
| ETriOp (_, _, e, e', e'') ->
(vars_of_expr e) @ (vars_of_expr e') @ (vars_of_expr e'')
| 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)