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

.gitignore

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

beamer/beamer.tex

@@ -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

src/ast.ml

@@ -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

src/main.ml

@@ -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) ;

src/parser.mly

@@ -198,9 +198,7 @@ node_content:
           n_outputs    = (t_out, e_out);
           n_local_vars = $10;
           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
         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
+        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!",
                       current_location()))
          }

src/passes.ml

@@ -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
@@ -82,7 +83,7 @@ let pre2vars verbose debug main_fn =
       let arg = aux arg in
       EApp (ty, node, arg)
 in
-  expression_pass (Utils.somify aux)
+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 =
@@ -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)
     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
     | [] -> ()
@@ -159,15 +160,16 @@ let pass_linearization verbose debug main_fn =
   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_select
-              (List.length (Utils.type_exp hexps))
+            (List.length (type_exp hexps))
             (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)
           :: (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
+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
+

src/passes_utils.ml

@@ -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

src/pp.ml

@@ -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

src/test.node

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

src/test2.node

@@ -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

src/utils.ml

@@ -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)
+