Compare commits

...

86 Commits

Author SHA1 Message Date
Arnaud DABY-SEESARAM
8c3e3d1eac [C] malloc->calloc + conditions merged in free_state_* 2022-12-20 16:52:59 +01:00
Arnaud DABY-SEESARAM
a673c447e3 [messages] better comment and errors 2022-12-20 16:41:21 +01:00
Arnaud DABY-SEESARAM
03def2ce1a [C] new lines in then output after each step 2022-12-20 16:38:29 +01:00
Arnaud DABY-SEESARAM
ffa8918330 [C] a few fixes 2022-12-20 16:34:31 +01:00
Arnaud DABY-SEESARAM
24108925fd [cprint] free the allocated memory (states). 2022-12-20 16:29:35 +01:00
fd95446636 Modify C main to initialize correctly the state with is_reset = false 2022-12-20 15:46:31 +01:00
19524ea99c Merge branch 'ast2C_proposition' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems into ast2C_proposition 2022-12-20 15:42:59 +01:00
88c145a527 Disable mallocs when reseting 2022-12-20 15:39:33 +01:00
Arnaud DABY-SEESARAM
52092b1480 [cprint] code reduction 2022-12-20 15:24:55 +01:00
Arnaud DABY-SEESARAM
f121f55432 [cprint] add a main function 2022-12-20 15:11:12 +01:00
Arnaud DABY-SEESARAM
42536df81c [parser] update of some error messages 2022-12-20 14:10:34 +01:00
Arnaud DABY-SEESARAM
c7edb27fb0 [lustre_pp] fix a typing error 2022-12-20 14:04:50 +01:00
Arnaud DABY-SEESARAM
3ad133344a [lustre_pp] precise error messages 2022-12-20 14:02:00 +01:00
4303dcd0e4 Correct a typo in src/main.ml disabling the compilation 2022-12-20 13:09:09 +01:00
Arnaud DABY-SEESARAM
f5daae824c [merge] 2022-12-20 09:51:59 +01:00
9fbdb7000f Merge branch 'ast2C_proposition' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems into ast2C_proposition 2022-12-20 03:51:31 +01:00
e1de3e6829 Add support for resets 2022-12-20 03:51:28 +01:00
657fe7e6fa Add support for resets 2022-12-20 03:48:37 +01:00
Arnaud DABY-SEESARAM
91ff654fc9 [passes] ensure that apps don't mix with operators 2022-12-19 23:21:11 +01:00
025d25a146 Replace nunmbers to numbers in two comments of src/parser.mly 2022-12-19 19:48:21 +01:00
10838d3f2d Remove TODO in src/passes.ml:automaton_translation
As Antoine Grimod said that it was already done.
2022-12-19 17:45:33 +01:00
e63123d8f6 Move from the x reset y syntax to reset x every y one
As described on https://www.di.ens.fr/~pouzet/cours/mpri/cours7/coiteration.pdf#page=4
2022-12-19 16:28:03 +01:00
Arnaud DABY-SEESARAM
01d4a08e8a [c pass] idem 2022-12-19 14:30:39 +01:00
Arnaud DABY-SEESARAM
9483f7df5e [c pass] merge neighbour conditionals (improved) 2022-12-19 14:22:19 +01:00
9a0bfd468c Correct some typos 2022-12-19 14:06:18 +01:00
609870755c Remove debugging symbols in failwith
As running `OCAMLRUNPARAM=b ./_build/main.native ...` provides in case of `failwith` a better stacktrace.
This enables moving `failwith`s from a file to the other without adapting them.
2022-12-19 13:56:48 +01:00
Arnaud DABY-SEESARAM
906a3d948b [oups] forgot a pattern matching 2022-12-19 12:20:03 +01:00
Arnaud DABY-SEESARAM
249ac37934 [general] renaming, comments and removal of unused function in [pass_linearization_pre] 2022-12-19 12:18:21 +01:00
Arnaud DABY-SEESARAM
1d39173e94 [general] useless fn removed in pass_linearization_app + comments + print_debug in ast_to_c 2022-12-19 12:07:43 +01:00
Arnaud DABY-SEESARAM
4ff193759b [passes] removal of constructs: seems ok 2022-12-19 11:22:16 +01:00
Arnaud DABY-SEESARAM
c52dce6c02 [passes] linearization: done for app, tuples (lvl 1 behind when) and pre 2022-12-18 22:34:07 +01:00
Arnaud DABY-SEESARAM
c344f125e5 [passes] linearization of tuple-equations + deletion of unused pass 2022-12-18 19:00:24 +01:00
Arnaud DABY-SEESARAM
aa7f7514d3 [Lustre -> intermediate] fix for the [pre] construct 2022-12-18 17:36:10 +01:00
Arnaud DABY-SEESARAM
77c865e360 [intermediate_ast] remove unused fields of i_nodes 2022-12-18 17:25:34 +01:00
02130cf57c Rename maybeprint to print_if_any to precise the purpose of this function 2022-12-18 14:50:55 +01:00
273a868162 Simplify cp_value for boolean constants in src/cprint.ml 2022-12-18 14:45:23 +01:00
37dfcdda35 Remove unneeded node prototypes, as Lustre only allows to call already defined nodes 2022-12-18 14:42:26 +01:00
c3a64a2bae Correct some typos 2022-12-18 14:31:56 +01:00
dsac
1491e279f7 [ast2C] printer: ok. 2022-12-18 13:38:40 +01:00
dsac
ce686f6c9a [ast2C] merge ok (needs linearization) 2022-12-18 10:41:36 +01:00
dsac
1d4e1820e4 [ast2C] Applications to values 2022-12-18 09:41:22 +01:00
dsac
007c5b2862 [c printer] Ok. 2022-12-18 00:26:51 +01:00
dsac
243e8f245a [ast2C] adding the (->) construct 2022-12-18 00:11:02 +01:00
dsac
791af71913 [ast2C] print all basic operators 2022-12-17 23:58:45 +01:00
dsac
233b385608 missing 'state->' added + print +,-,*,... 2022-12-17 23:46:39 +01:00
dsac
7a32d474d4 [ast2C] support for some basic operations (exemple in test.node) 2022-12-17 23:36:07 +01:00
dsac
cbc834b32a [ast2C] constants, simple assignations, variables (+ one fix about pre storage) 2022-12-17 22:36:42 +01:00
dsac
a877501cca [general] renaming: done. 2022-12-17 21:37:37 +01:00
dsac
3cbfaeb2a8 [general] renaming (pp -> lustre_pp ; c_* -> intermediate_*) 2022-12-17 21:26:32 +01:00
dsac
916c7f544b [ast2C] initialize states of auxiliary nodes. 2022-12-17 18:34:11 +01:00
dsac
6291957be5 [ast2C] init or not init (field added to the state of the node) 2022-12-17 16:35:49 +01:00
dsac
bb99a5882b [ast2C] store old values of variables used in the pre construct 2022-12-17 16:30:10 +01:00
dsac
0da0f58b22 [ast2C] proposition initiale 2022-12-17 16:01:48 +01:00
Arnaud DABY-SEESARAM
fa052f70e2 [beamer] pause added 2022-12-16 17:00:24 +01:00
0175749296 Merge branch 'master' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems 2022-12-16 15:53:14 +01:00
Arnaud DABY-SEESARAM
4054da7d47 [beamer] 2022-12-16 16:51:49 +01:00
Antoine Grimod
fc0a12fa12 beamer automaton pass 2022-12-16 16:40:34 +01:00
edfec42738 Add Git link to title slide of beamer 2022-12-16 16:03:47 +01:00
d06fccf36b Add second slide concerning AST to C 2022-12-16 16:02:03 +01:00
b616bad07a Modify second slide concerning AST to C 2022-12-16 15:53:04 +01:00
7a0f54f291 Remove unused pp_loc from src/ast_to_c.ml which was copied from src/pp.ml but never used 2022-12-16 15:40:24 +01:00
dbf1583ffd Complete first slide of AST to C 2022-12-16 15:33:39 +01:00
9e96697991 First slide of AST to C 2022-12-16 15:07:46 +01:00
Antoine Grimod
aa84a07902 testing clock unification 2022-12-16 14:51:41 +01:00
Antoine Grimod
ed54fd0114 clock unification added 2022-12-16 14:51:41 +01:00
Arnaud DABY-SEESARAM
b69b6998ec [passes] linearisation: update the local variables + lienarisation of tri ops 2022-12-16 14:41:37 +01:00
73b753bec2 Merge branch 'master' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems 2022-12-16 05:57:55 +01:00
a0383dbf13 Make last equation of a node potentially not ending with a semi column be correctly parsed
Otherwise the following code:

```
-- count the number of top between two tick
node counting (tick:bool; top:bool)
returns (o: bool);
	var v: int;
	let o = if tick then v else 0 -> pre o + v;
		v = if top then 1 else 0
	tel;
```

was involving the following error:

```
Syntax error at <line 1: -- count the number of top between two tick >
```
2022-12-16 05:57:25 +01:00
530f6ddf51 Merge branch 'master' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems 2022-12-16 05:55:15 +01:00
Arnaud DABY-SEESARAM
57dd9c1aa4 [passes] linearozation: avoir duplication of variables 2022-12-16 14:16:13 +01:00
21414e6461 Make last equation of a node potentially not ending with a semi column
Otherwise the following code:

```
-- count the number of top between two tick
node counting (tick:bool; top:bool)
returns (o: bool);
	var v: int;
	let o = if tick then v else 0 -> pre o + v;
		v = if top then 1 else 0
	tel;
```

was involving the following error:

```
Syntax error at <line 1: -- count the number of top between two tick >
```
2022-12-16 05:54:41 +01:00
c37e819f1a Add a title frame to the beamer 2022-12-16 05:06:27 +01:00
ea94bb84dd Merge branch 'master' of https://gitea.lemnoslife.com/Benjamin_Loison/Synchronous_reactive_systems 2022-12-16 04:47:05 +01:00
Arnaud DABY-SEESARAM
3fa0f92233 [beamer] A few straight forward slides added 2022-12-16 10:45:20 +01:00
Arnaud DABY-SEESARAM
3417d75620 [passes] linearisation: correction (10 -> pre (20 -> 30)) works 2022-12-16 09:44:50 +01:00
f55cd56fde Clean other tries 2022-12-16 04:46:48 +01:00
012131e035 Solve C warnings and support renaming outputs of functions 2022-12-16 04:45:30 +01:00
b58b250532 WIP to remove C warnings 2022-12-16 03:18:21 +01:00
78e096d2f4 Add support for returning multiple variables but generate C errors, as we keep returning variables for void functions 2022-12-16 03:03:12 +01:00
621658e177 Removing first try to implement generalized function results 2022-12-16 01:55:53 +01:00
85ecea0b9e First try to implement generalized function results 2022-12-16 01:55:21 +01:00
7c2c43fe24 Precise to what extent considering integers work fine with working with floats instead 2022-12-16 01:20:42 +01:00
Arnaud DABY-SEESARAM
c7a97f3305 [passes] linearization: merge fix 2022-12-16 09:00:03 +01:00
Arnaud DABY-SEESARAM
8d6349dd3f Merge remote-tracking branch 'origin/master' into wip 2022-12-16 08:53:55 +01:00
Arnaud DABY-SEESARAM
d7f0f148e9 [pre linearization] done, not tested 2022-12-16 08:52:48 +01:00
dsac
9987922e0f [passes] linearization of pre (wip) 2022-12-16 07:47:20 +01:00
22 changed files with 1997 additions and 524 deletions

View File

@@ -1,4 +1,11 @@
\documentclass{beamer}
\usepackage{listings}
\lstset{
basicstyle=\ttfamily,
columns=fullflexible,
frame=single,
breaklines=true,
}
\usepackage{tikz}
\usetikzlibrary{positioning}
@@ -6,6 +13,13 @@
\begin{document}
\title{Presentation of our Lustre-to-C compiler}
\subtitle{github.com/Benjamin-Loison/Synchronous-reactive-systems}
\date{16 December 2022}
\author{Benjamin Loison, Arnaud Daby-Seesaram, Antoine Grimod}
\frame{\titlepage}
\section{Structure of the compiler}
\begin{frame}{Main ideas}
\begin{figure}
@@ -96,36 +110,137 @@
\end{frame}
\section{Passes}
\begin{frame}{Passes}
\begin{block}{Classification}
The passes of our compiler are functions of taking a program and either:
\begin{frame}{}
\begin{block}{Classification}
\begin{itemize}
\item node-passes: for all nodes, do \texttt{P: t\_node -> t\_node
option}
\pause
\item equation-passes: for all equations of all nodes, do
\texttt{P: t\_equation -> t\_equation option}
(the definition uses the node-passes constructor)
\pause
\item expression-passes: for all expression of all equations, do
\texttt{P: t\_expression -> t\_expression option}
(the definition uses the equation-passes constructor)
\end{itemize}
\end{block}
\end{frame}
\begin{frame}{Implemented Passes}
\begin{block}{Sanity checks}
\begin{itemize}
\item returning a program if the pass succeeded
\item returns nothing otherwise
\item Check the well-typedness of a program
\pause
\item Check that there are no assignment conflicts in a programs
(node-pass)
\pause
\end{itemize}
\end{block}
\begin{block}{AST modification}
\begin{itemize}
\item Rewrite automata into \texttt{if-then-else} constructs
(node-pass)
\pause
\item Linearization of the equations:
\begin{itemize}
\item for all, \texttt{pre e} add a, intermediate variable
\item \texttt{v1, v2, v3 = f(i), e3;} is rewritten into
\texttt{v1, v2 = f(i); v3 = e3;}
\end{itemize}
(node-pass)
\pause
\item (no longer required) Push the \texttt{pre} to variables
(expression-pass)
\end{itemize}
We only have one language in our compiler: no intermediary language.
\end{block}
\end{frame}
\subsection{Check}
\begin{frame}[fragile]{Translation of automaton}
\only<1>{\lstinputlisting[language=ml, firstline=1, lastline=7]{code/example_automaton.lus}}
\only<2>{\lstinputlisting[language=ml, firstline=9, lastline=14]{code/example_automaton.lus}}
\end{frame}
\begin{frame}{Restriction on automaton}
The patterns that appears on the left of equations must be the
same in all branches
\only<2>{\lstinputlisting[language=ml, firstline=16, lastline=22]{code/example_automaton.lus}}
\end{frame}
\begin{frame}{Clock unification}
Derived from the rules provided in \emph{Clock-directed Modular Code Generation for Synchronous
Data-flow Languages}
\end{frame}
\section{Translation to C}
\begin{frame}
\begin{block}{Passes}
The passes can be split into:
\begin{itemize}
\item those checking the program validity
\item those modifying the AST of the program
\end{itemize}
\end{block}
\texttt{ast\_to\_c.ml} architecture similar to Arnaud's AST pretty-printer.
\pause
For instance, go from \texttt{counting.lus} to \texttt{counting.c}.
\pause
Use of three tricks, as our compiler only manages \texttt{bool}s, \texttt{int}s and \texttt{float}s:
\begin{enumerate}
\item \texttt{0} can be interpreted as a \texttt{bool}, an \texttt{int} and a \texttt{float}
\pause
\item A \texttt{float} correctly encode \texttt{bool}s (\texttt{true} and \texttt{false}) and \texttt{int}s (between $[-2^{24} + 1; 2^{24} + 1]$)
\pause
\item To run an assignment of \texttt{value} to \texttt{variable} within the condition of a \texttt{if} and also make the cases of the \texttt{if} depends on a condition \texttt{condition}, we can do \texttt{if(((variable = value) \&\& false) || condition)}\\
\pause
We can also use this trick to execute an assignment and \textit{return} a value \texttt{value\_to\_return} without using any \texttt{;}, by using \texttt{((variable = value) || true) ? value\_to\_return : 0} (thanks to the first trick)
\end{enumerate}
\end{frame}
\begin{frame}{Implemented passes}
\begin{block}{\texttt{pre}-propagation to leaves}
\end{block}
\begin{block}{Check: unique initialization for variables}
\end{block}
\begin{block}{Linearization of the equations}
\end{block}
\begin{frame}
\begin{itemize}
\item
\begin{itemize}
\item \texttt{pp\_varlist (Base | Arg | Dec)}
\item \texttt{pp\_retvarlist}
\item \texttt{pp\_prevarlist}
\item \texttt{pp\_asnprevarlist}
\end{itemize}
\pause
\item \texttt{when} implementation error: division by zero for instance, so used the first trick (\texttt{when\_merge.node})
\pause
\item \texttt{->}: use global variable \texttt{init\_\{NODE\_NAME\}}\\
\texttt{1 -> 2 -> 3} returns \texttt{0} on first run and only \texttt{3} on the following ones, correct? (\texttt{arrow.node})
\pause
\item \texttt{pre}
\pause
\item \texttt{reset}% (\texttt{reset})
\pause
\item Functions returning tuples thanks to Arnaud's linearization only have to deal with \texttt{(a0, a1, ..., an) = return\_tuple\_a0\_a1\_dots\_an(0)} (\texttt{function\_returning\_tuple.node})
\end{itemize}
\end{frame}
\section{Tests}
\begin{frame}{Tests}
\begin{block}{testing methods}
We thought of three testing methods:
\begin{itemize}
\item manual testing of our functionalities
\item run the sanity-checks-passes after any AST-altering pass
\item simulation of the nodes (aborted)
\end{itemize}
\end{block}
\end{frame}
\section{Possible improvements}
\begin{frame}{Improvements}
\begin{itemize}
\item Increase the expressivity of the accepted programs
\item Improve the complexity of the different passes
\begin{itemize}
\item Group neighbour passes of the same type (node-, expression or
equation-pass).
\end{itemize}
\item \dots{}
\end{itemize}
\end{frame}
\end{document}

View File

@@ -0,0 +1,22 @@
node auto (i: int) returns (o : int);
var x, y:int;
let
automaton
| Incr -> do (o,x) = (0 fby o + 1, 2); until o < 5 then Decr
| Decr -> do (o,x) = diagonal_int(0 fby o); until o > 3 then Incr
tel
node auto (i: int) returns (o: int);
var x, y: int;
let
_s1 = 1 -> (if _s = 1 and o < 5 then 2 else if _s = 2 and o > then 1 else 1);
o, x = if _s = 1 then (0 fby o + 1, 2) else if _s = 2 then diagonal_int(0 fby 0) else (0, 0);
tel
node auto (i: int) returns (o : int);
var x, y:int;
let
automaton
| Incr -> do (o,x) = (0 fby o + 1, 2); until o < 5 then Decr
| Decr -> do (x,o) = diagonal_int(0 fby o); until o > 3 then Incr
tel

View File

@@ -73,3 +73,7 @@ and t_node =
type t_nodelist = t_node list
type t_ck = base_ck list
and base_ck =
| Base
| On of base_ck * t_expression

View File

@@ -1,246 +1,324 @@
open Ast
open Intermediate_ast
open Intermediate_utils
open Cprint
open Cast
open Utils
open Ctranslation
let pp_loc fmt (start, stop) =
Lexing.(
Format.fprintf fmt "%s: <l: %d, c: %d> -- <l: %d, c: %d>"
start.pos_fname
start.pos_lnum start.pos_cnum
stop.pos_lnum stop.pos_cnum)
type var_list_delim =
| Base
| Arg
| Dec
let rec pp_varlist var_list_delim fmt : t_varlist -> unit = function
| ([], []) -> ()
| ([TInt] , IVar h :: []) -> Format.fprintf fmt (
match var_list_delim with
| Base -> "%s"
| Arg -> "int %s"
| Dec -> "int %s;") h
| ([TReal], RVar h :: []) -> Format.fprintf fmt (
match var_list_delim with
| Base -> "%s"
| Arg -> "float %s"
| Dec -> "float %s;") h
| ([TBool], BVar h :: []) -> Format.fprintf fmt (
match var_list_delim with
| Base -> "%s"
| Arg -> "bool %s"
| Dec -> "bool %s;") h
| (TInt :: tl, IVar h :: h' :: l) ->
Format.fprintf fmt (
match var_list_delim with
| Base -> "%s, %a"
| Arg -> "int %s, %a"
| Dec -> "int %s;\n\t%a") h (pp_varlist var_list_delim) (tl, h' :: l)
| (TBool :: tl, BVar h :: h' :: l) ->
Format.fprintf fmt (
match var_list_delim with
| Base -> "%s, %a"
| Arg -> "bool %s, %a"
| Dec -> "bool %s;\n\t%a") h (pp_varlist var_list_delim) (tl, h' :: l)
| (TReal :: tl, RVar h :: h' :: l) ->
Format.fprintf fmt (
match var_list_delim with
| Base -> "%s, %a"
| Arg -> "float %s, %a"
| Dec -> "float %s;\n\t%a") h (pp_varlist var_list_delim) (tl, h' :: l)
| _ -> raise (MyTypeError "This exception should not have beed be raised.")
(** [ast_to_intermediate_ast] translates a [t_nodelist] into a [i_nodelist] *)
let ast_to_intermediate_ast (nodes: t_nodelist) (h: node_states): i_nodelist =
let c = ref 1 in
let ast_to_intermediate_ast_varlist vl = snd vl in
let rec ast_to_intermediate_ast_expr hloc = function
| EVar (_, v) ->
begin
match Hashtbl.find_opt hloc (Utils.name_of_var v, false) with
| None -> IEVar (CVInput (name_of_var v))
| Some (s, i) -> IEVar (CVStored (s, i))
end
| EMonOp (_, MOp_pre, EVar (_, v)) ->
let s, i = Hashtbl.find hloc (Utils.name_of_var v, true) in
IEVar (CVStored (s, i))
| EMonOp (_, op, e) -> IEMonOp (op, ast_to_intermediate_ast_expr hloc e)
| EBinOp (_, op, e, e') ->
IEBinOp (op, ast_to_intermediate_ast_expr hloc e, ast_to_intermediate_ast_expr hloc e')
| ETriOp (_, op, e, e', e'') ->
IETriOp
(op, ast_to_intermediate_ast_expr hloc e, ast_to_intermediate_ast_expr hloc e', ast_to_intermediate_ast_expr hloc e'')
| EComp (_, op, e, e') ->
IEComp (op, ast_to_intermediate_ast_expr hloc e, ast_to_intermediate_ast_expr hloc e')
| EWhen (_, e, e') ->
IEWhen (ast_to_intermediate_ast_expr hloc e, ast_to_intermediate_ast_expr hloc e')
| EReset (_, e, e') ->
IEReset (ast_to_intermediate_ast_expr hloc e, ast_to_intermediate_ast_expr hloc e')
| EConst (_, c) -> IEConst c
| ETuple (_, l) -> IETuple (List.map (ast_to_intermediate_ast_expr hloc) l)
| EApp (_, n, e) ->
begin
let e = ast_to_intermediate_ast_expr hloc e in
let res = IEApp (!c, n, e) in
let () = incr c in
res
end
in
let ast_to_intermediate_ast_eq hloc (patt, expr) : i_equation =
(ast_to_intermediate_ast_varlist patt, ast_to_intermediate_ast_expr hloc expr) in
List.map
begin
fun node ->
let () = c := 1 in
let hloc = (Hashtbl.find h node.n_name).nt_map in
{
in_name = node.n_name;
in_inputs = ast_to_intermediate_ast_varlist node.n_inputs;
in_outputs = ast_to_intermediate_ast_varlist node.n_outputs;
in_local_vars = ast_to_intermediate_ast_varlist node.n_local_vars;
in_equations = List.map (ast_to_intermediate_ast_eq hloc) node.n_equations;
}
end
nodes
let rec pp_retvarlist fmt : t_varlist -> unit = function
| ([], []) -> ()
| ([TInt] , IVar h :: []) -> Format.fprintf fmt "int"
| ([TReal], RVar h :: []) -> Format.fprintf fmt "float"
| ([TBool], BVar h :: []) -> Format.fprintf fmt "bool"
| (TInt :: tl, IVar h :: h' :: l) ->
Format.fprintf fmt "int, %a" pp_retvarlist (tl, h' :: l)
| (TBool :: tl, BVar h :: h' :: l) ->
Format.fprintf fmt "float, %a" pp_retvarlist (tl, h' :: l)
| (TReal :: tl, RVar h :: h' :: l) ->
Format.fprintf fmt "bool, %a" pp_retvarlist (tl, h' :: l)
| _ -> raise (MyTypeError "This exception should not have beed be raised.")
(** The following function defines the [node_states] for the nodes of a program,
* and puts them in a hash table. *)
let make_state_types nodes: node_states =
(* Hash table to fill *)
let h: (ident, node_state) Hashtbl.t = Hashtbl.create (List.length nodes) in
let rec pp_prevarlist node_name fmt : t_varlist -> unit = function
| ([], []) -> ()
| ([TInt] , IVar h :: []) -> Format.fprintf fmt "int pre_%s_%s;" node_name h
| ([TReal], RVar h :: []) -> Format.fprintf fmt "float pre_%s_%s;" node_name h
| ([TBool], BVar h :: []) -> Format.fprintf fmt "bool pre_%s_%s;" node_name h
| (TInt :: tl, IVar h :: h' :: l) ->
Format.fprintf fmt "int pre_%s_%s;\n%a" node_name h (pp_prevarlist node_name) (tl, h' :: l)
| (TBool :: tl, BVar h :: h' :: l) ->
Format.fprintf fmt "float pre_%s_%s;\n%a" node_name h (pp_prevarlist node_name) (tl, h' :: l)
| (TReal :: tl, RVar h :: h' :: l) ->
Format.fprintf fmt "bool pre_%s_%s;\n%a" node_name h (pp_prevarlist node_name) (tl, h' :: l)
| _ -> raise (MyTypeError "This exception should not have beed be raised.")
(** [one_node node pv ty] computes the number of variables of type [ty] in
* [node] and a mapping from the variables of type ([ty] * bool) to int,
* where [pv] is a list of variables used in the pre construct in the
* program. *)
let one_node node pv ty =
(* variables of type [ty] among output and local variables *)
let vars =
List.filter (fun v -> type_var v = [ty])
(snd (varlist_concat node.n_outputs node.n_local_vars)) in
let all_vars =
List.filter (fun v -> type_var v = [ty])
(snd (varlist_concat (varlist_concat node.n_inputs node.n_outputs) node.n_local_vars)) in
let pre_vars =
List.filter (fun v -> List.mem v pv) all_vars in
let vars = List.map Utils.name_of_var vars in
let pre_vars = List.map Utils.name_of_var pre_vars in
let nb = (List.length vars) + (List.length pre_vars) in
let tyh: (ident * bool, int) Hashtbl.t = Hashtbl.create nb in
let i =
List.fold_left
(fun i v -> let () = Hashtbl.add tyh (v, false) i in i + 1) 0 vars in
let _ =
List.fold_left
(fun i v -> let () = Hashtbl.add tyh (v, true) i in i + 1) i pre_vars in
(nb, tyh)
in
let rec pp_asnprevarlist node_name fmt : t_varlist -> unit = function
| ([], []) -> ()
| ([TInt] , IVar h :: []) | ([TReal], RVar h :: []) | ([TBool], BVar h :: []) -> Format.fprintf fmt "\tpre_%s_%s = %s;" node_name h h
| (TInt :: tl, IVar h :: h' :: l) | (TBool :: tl, BVar h :: h' :: l) | (TReal :: tl, RVar h :: h' :: l) ->
Format.fprintf fmt "\tpre_%s_%s = %s;\n%a" node_name h h (pp_asnprevarlist node_name) (tl, h' :: l)
| _ -> raise (MyTypeError "This exception should not have beed be raised.")
let reset_expressions_counter = ref 0;;
let pp_expression node_name =
let rec pp_expression_aux fmt expression =
let rec pp_expression_list fmt exprs =
match exprs with
| ETuple([], []) -> ()
| ETuple (_ :: tt, expr :: exprs) ->
Format.fprintf fmt "%a%s%a"
pp_expression_aux expr
(if (List.length tt > 0) then ", " else "")
pp_expression_list (ETuple (tt, exprs))
| _ -> raise (MyTypeError "This exception should not have been raised.")
(** [find_prevars n] returns the list of variables appearing after a pre in
* the node [n].
* Note that the only occurrence of pre are of the form pre (var), due to
* the linearization pass.
*)
let find_prevars node =
let rec find_prevars_expr = function
| EConst _ | EVar _ -> []
| EMonOp (_, MOp_pre, EVar (_, v)) -> [v]
| EMonOp (_, _, e) -> find_prevars_expr e
| ETriOp (_, _, e, e', e'') ->
(find_prevars_expr e) @ (find_prevars_expr e') @ (find_prevars_expr e'')
| EComp (_, _, e, e')
| EBinOp (_, _, e, e')
| EWhen (_, e, e')
| EReset (_, e, e') -> (find_prevars_expr e) @ (find_prevars_expr e')
| ETuple (_, l) -> List.flatten (List.map (find_prevars_expr) l)
| EApp (_, _, e) -> find_prevars_expr e
in
match expression with
| EWhen (_, e1, e2) ->
begin
Format.fprintf fmt "%a ? %a : 0"
pp_expression_aux e2
pp_expression_aux e1
end
| EReset (_, e1, e2) ->
begin
incr reset_expressions_counter;
(* Use following trick as we can't use `;`:
if(((var = val) && false) || condition)
is equivalent to an incorrect statement like
if({var = val; condition})
We also use this trick with the fact that `0` can be interpreted as a `bool`, an `int` and a `float` *)
(* could use C macros to simplify the C code *)
Format.fprintf fmt "(((tmp_reset[%i] = %a) && false) || init_%s) ? (((init[%i] = tmp_reset[%i]) || true) ? tmp_reset[%i] : 0) : (%a ? init[%i] : tmp_reset[%i])"
(!reset_expressions_counter - 1)
pp_expression_aux e1
node_name
(!reset_expressions_counter - 1)
(!reset_expressions_counter - 1)
(!reset_expressions_counter - 1)
pp_expression_aux e2
(!reset_expressions_counter - 1)
(!reset_expressions_counter - 1)
end
| EConst (_, c) ->
begin match c with
| CBool b -> Format.fprintf fmt "%s" (Bool.to_string b)
| CInt i -> Format.fprintf fmt "%i" i
| CReal r -> Format.fprintf fmt "%f" r
end
| EVar (_, IVar v) | EVar (_, BVar v) | EVar (_, RVar v) -> Format.fprintf fmt "%s" v
| EMonOp (_, mop, arg) ->
begin match mop with
| MOp_not ->
Format.fprintf fmt "!%a"
pp_expression_aux arg
| MOp_minus ->
Format.fprintf fmt "-%a"
pp_expression_aux arg
| MOp_pre ->
Format.fprintf fmt "pre_%s_%a" node_name
pp_expression_aux arg
end
| EBinOp (_, BOp_arrow, arg, arg') ->
Format.fprintf fmt "init_%s ? %a : %a"
node_name
pp_expression_aux arg
pp_expression_aux arg'
| EBinOp (_, bop, arg, arg') ->
begin
let s = match bop with
| BOp_add -> " + " | BOp_sub -> " - "
| BOp_mul -> " * " | BOp_div -> " / " | BOp_mod -> " % "
| BOp_and -> " && " | BOp_or -> " || " | _ -> "" (* `ocamlc` doesn't detect that `BOp_arrow` can't match here *) in
Format.fprintf fmt "%a%s%a"
pp_expression_aux arg
s
pp_expression_aux arg'
end
| EComp (_, cop, arg, arg') ->
begin
let s = match cop with
| COp_eq -> " == "
| COp_neq -> " != "
| COp_le -> " <= " | COp_lt -> " < "
| COp_ge -> " >= " | COp_gt -> " > " in
Format.fprintf fmt "%a%s%a"
pp_expression_aux arg
s
pp_expression_aux arg'
end
| ETriOp (_, top, arg, arg', arg'') ->
begin
Format.fprintf fmt "%a ? %a : %a"
pp_expression_aux arg
pp_expression_aux arg'
pp_expression_aux arg''
end
| EApp (_, f, args) ->
Format.fprintf fmt "%s(%a)"
f.n_name
pp_expression_list args
| ETuple _ ->
Format.fprintf fmt "%a"
pp_expression_list expression;
in
pp_expression_aux
list_remove_duplicates
(List.fold_left
(fun acc (_, expr) -> (find_prevars_expr expr) @ acc)
[] node.n_equations)
in
let rec pp_equations node_name fmt: t_eqlist -> unit = function
(** [count_app n] count the number of auxiliary nodes calls in [n] *)
let count_app n =
let rec count_app_expr = function
| EConst _ | EVar _ -> 0
| EMonOp (_, _, e) -> count_app_expr e
| ETriOp (_, _, e, e', e'') ->
(count_app_expr e) + (count_app_expr e') + (count_app_expr e'')
| EComp (_, _, e, e')
| EBinOp (_, _, e, e')
| EWhen (_, e, e')
| EReset (_, e, e') -> (count_app_expr e) + (count_app_expr e')
| ETuple (_, l) ->
List.fold_left (fun acc e -> acc + count_app_expr e) 0 l
| EApp (_, _, e) -> 1 + count_app_expr e
in
List.fold_left
(fun i (_, expr) -> i + count_app_expr expr)
0 n.n_equations
in
(** [aux] iterates over all nodes of the program to build the required hash
* table *)
let rec aux nodes =
match nodes with
| [] -> h
| node :: nodes ->
begin
let h = aux nodes in
let node_name = node.n_name in
let pv = find_prevars node in
let nb_int_vars, h_int = one_node node pv TInt in
let nb_bool_vars, h_bool = one_node node pv TBool in
let nb_real_vars, h_real = one_node node pv TReal in
(** h_map gathers information from h_* maps above *)
let h_map =
Hashtbl.create (nb_int_vars + nb_bool_vars + nb_real_vars) in
let () =
Hashtbl.iter (fun k v -> Hashtbl.add h_map k ("ivars", v)) h_int in
let () =
Hashtbl.iter (fun k v -> Hashtbl.add h_map k ("bvars", v)) h_bool in
let () =
Hashtbl.iter (fun k v -> Hashtbl.add h_map k ("rvars", v)) h_real in
let node_out_vars = snd node.n_outputs in
let h_out = Hashtbl.create (List.length node_out_vars) in
let () = List.iteri
(fun n (v: t_var) ->
match v with
| IVar s ->
let i = Hashtbl.find h_int (s, false) in
Hashtbl.add h_out n ("ivars", i)
| BVar s ->
let i = Hashtbl.find h_bool (s, false) in
Hashtbl.add h_out n ("bvars", i)
| RVar s ->
let i = Hashtbl.find h_real (s, false) in
Hashtbl.add h_out n ("rvars", i))
(snd node.n_outputs) in
let () = Hashtbl.add h node_name
{
nt_name = Format.asprintf "t_state_%s" node.n_name;
nt_nb_int = nb_int_vars;
nt_nb_bool = nb_bool_vars;
nt_nb_real = nb_real_vars;
nt_map = h_map;
nt_output_map = h_out;
nt_prevars = pv;
nt_count_app = count_app node;
} in
h
end
in
aux nodes
(** The following C-printer functions are in this file, as they need to work on
* the AST and are not simple printers. *)
(** The following function prints the code to remember previous values of
* variables used with the pre construct. *)
let cp_prevars fmt (node, h) =
let node_st = Hashtbl.find h node.in_name in
match (Hashtbl.find h node.in_name).nt_prevars with
| [] -> ()
| (([], []), (ETuple ([], []))) :: eqs -> Format.fprintf fmt "%a" (pp_equations node_name) eqs
| ((l_type :: l_types, var :: vars), (ETuple (r_type :: r_types, expr :: exprs))) :: eqs -> Format.fprintf fmt "%a" (pp_equations node_name) ((([l_type], [var]), expr) :: ((l_types, vars), (ETuple (r_types, exprs))) :: eqs)
| (patt, expr) :: eqs ->
Format.fprintf fmt "\t%a = %a;\n%a"
(pp_varlist Base) patt
(pp_expression node_name) expr
(pp_equations node_name) eqs
| l ->
Format.fprintf fmt
"\n\t/* Remember the values used in the [pre] construct */\n";
List.iter
(fun v -> (** Note that «dst_array = src_array» should hold. *)
match Hashtbl.find_opt node_st.nt_map (v, false) with
| Some (src_array, src_idx) ->
let (dst_array, dst_idx) = Hashtbl.find node_st.nt_map (v, true) in
Format.fprintf fmt "\tstate->%s[%d] = state->%s[%d];\n"
dst_array dst_idx src_array src_idx
| None ->
let (dst_array, dst_idx) = Hashtbl.find node_st.nt_map (v, true) in
Format.fprintf fmt "\tstate->%s[%d] = %s;\n"
dst_array dst_idx v
)
(List.map Utils.name_of_var l)
(* By prepending to the `Format.formatter` `fmt` we could just declare these arrays once with a size of the maximum `reset_expressions_counter` *)
let pp_resvars reset_expressions_counter =
(* use the fact that any boolean and any integer can be encoded as a float *)
Format.sprintf "float tmp_reset[%i], init[%i];" reset_expressions_counter reset_expressions_counter
(* TODO: manage general outputs *)
let pp_node fmt node =
(* undefined behavior if the initial code uses a variable with name:
- `init_{NODE_NAME}`
- `tmp_reset_{int}`
- `init_{int}`
- `pre_{NODE_MAIN}_{VARIABLE}` *)
reset_expressions_counter := 0;
let _ = (pp_equations node.n_name) Format.str_formatter node.n_equations in
reset_expressions_counter := 0;
Format.fprintf fmt "bool init_%s = true;\n\n%a\n\n%a\n\n%a\n\n%s\n\n%a %s(%a)\n{\n\t%a\n\n\t%a\n\n%a\n\tinit_%s = false;\n\n%a\n\n%a\n\n%a\n\n\treturn %a;\n}\n"
node.n_name
(* could avoid declaring unused variables *)
(pp_prevarlist node.n_name) node.n_inputs
(pp_prevarlist node.n_name) node.n_local_vars
(pp_prevarlist node.n_name) node.n_outputs
(pp_resvars !reset_expressions_counter)
pp_retvarlist node.n_outputs
node.n_name
(* could avoid newlines if they aren't used to seperate statements *)
(pp_varlist Arg) node.n_inputs
(pp_varlist Dec) node.n_local_vars
(pp_varlist Dec) node.n_outputs
(pp_equations node.n_name) node.n_equations
node.n_name
(pp_asnprevarlist node.n_name) node.n_inputs
(pp_asnprevarlist node.n_name) node.n_local_vars
(pp_asnprevarlist node.n_name) node.n_outputs
(pp_varlist Base) node.n_outputs
let rec pp_nodes fmt nodes =
(** The following function defines the behaviour to have at the first
* execution of a node, namely:
* - initialize the states of auxiliary nodes
*)
let cp_init_aux_nodes fmt (node, h) =
let rec aux fmt (node, nst, i) =
match find_app_opt node.in_equations i with
| None -> () (** All auxiliary nodes have been initialized *)
| Some n ->
begin
Format.fprintf fmt "%a\t\tif(!state->is_reset) {\n\
\t\t\tstate->aux_states[%d] = calloc (1, sizeof (%s));\n\
\t\t}\n\
\t\t((%s*)(state->aux_states[%d]))->is_init = true;\n\
\t\t((%s*)(state->aux_states[%d]))->is_reset = state->is_reset;\n"
aux (node, nst, i-1)
(i-1) (Format.asprintf "t_state_%s" n.n_name)
(Format.asprintf "t_state_%s" n.n_name) (i-1)
(Format.asprintf "t_state_%s" n.n_name) (i-1)
end
in
let nst = Hashtbl.find h node.in_name in
if nst.nt_count_app = 0
then ()
else begin
Format.fprintf fmt "\t/* Initialize the auxiliary nodes */\n\
\tif (state->is_init) {\n%a\t}\n\n\n"
aux (node, nst, nst.nt_count_app)
end
(** [cp_equations] prints the node equations. *)
let cp_equations fmt (eqs, hloc, h) =
(** [main_block] is modified through some optimization passes, eg:
* - merge two CIf blocks using the same condition
* - replace [if (! c) { b1 } else { b2 }] by [if(c) { b2 } else { b1 }]
*
* These passes are defined in [ctranslation.ml]
*)
let main_block: c_block =
List.map (fun eq -> equation_to_expression (hloc, h, eq)) eqs in
let main_block = remove_ifnot main_block in
let main_block = merge_neighbour_ifs main_block in
Format.fprintf fmt "\t/*Main code :*/\n%a"
cp_block (main_block, hloc.nt_map)
(** [cp_node] prints a single node *)
let cp_node fmt (node, h) =
Format.fprintf fmt "%a\n{\n%a%a\n\n\tstate->is_init = false;\n%a}\n"
cp_prototype (node, h)
cp_init_aux_nodes (node, h)
cp_equations (node.in_equations, Hashtbl.find h node.in_name, h)
cp_prevars (node, h)
(** [cp_nodes] recursively prints all the nodes of a program. *)
let rec cp_nodes fmt (nodes, h) =
match nodes with
| [] -> ()
| node :: nodes ->
Format.fprintf fmt "%a\n%a" pp_node node pp_nodes nodes
Format.fprintf fmt "%a\n%a"
cp_node (node, h)
cp_nodes (nodes, h)
let ast_to_c fmt prog =
Format.fprintf fmt
(* could verify that uses, possibly indirectly (cf `->` implementation), a boolean in the ast before including `<stdbool.h>` *)
"#include <stdbool.h>\n\n%a"
pp_nodes prog
(** [dump_var_locations] dumps the internal tables to map the program variable
* (after all the passes) to their location in the final C program. *)
let dump_var_locations fmt (st: node_states) =
Format.fprintf fmt "Tables mapping the AST variables to the C variables:\n";
Hashtbl.iter
(fun n st ->
Format.fprintf fmt " NODE: %s\n" n;
Hashtbl.iter
(fun (s, (ispre: bool)) ((arr: string), (idx: int)) ->
match ispre with
| true -> Format.fprintf fmt " PRE Variable %s stored as %s[%d]\n" s arr idx
| false -> Format.fprintf fmt " Variable %s stored as %s[%d]\n" s arr idx)
st.nt_map)
st
(** main function that prints a C-code from a term of type [t_nodelist]. *)
let ast_to_c verbose debug prog =
verbose "Computation of the node_states";
let prog_st_types = make_state_types prog in
debug (Format.asprintf "%a" dump_var_locations prog_st_types);
let iprog: i_nodelist = ast_to_intermediate_ast prog prog_st_types in
Format.printf "%a\n\n%a\n\n%a\n\n/* Nodes: */\n%a%a\n"
cp_includes (Config.c_includes)
cp_state_types prog_st_types
cp_state_frees (iprog, prog_st_types)
cp_nodes (iprog, prog_st_types)
cp_main_fn (prog, prog_st_types)

27
src/cast.ml Normal file
View File

@@ -0,0 +1,27 @@
open Intermediate_ast
open Ast
(** This file contains a small subset of the syntax of C required for the
* translation. *)
(** A [c_block] represents a block in C. *)
type c_block = c_expression list
(** A [c_expresion] represents a C expression, which can need sequences and
* function calls. *)
and c_expression =
| CAssign of c_var * c_value
| CSeq of c_expression * c_expression
| CIf of c_value * c_block * c_block
| CApplication of ident * int * c_var list * c_var list * node_states
| CReset of ident * int * c_value * c_block
(** A value here is anything that can be inlined into a single C expression
* containing no function call, condition, ... *)
and c_value =
| CVariable of c_var
| CMonOp of monop * c_value
| CBinOp of binop * c_value * c_value
| CComp of compop * c_value * c_value
| CConst of const

View File

@@ -3,3 +3,4 @@
* variables. *)
let maxvar = 100
let c_includes = ["stdbool"; "stdlib"; "stdio"; "string"]

446
src/cprint.ml Normal file
View File

@@ -0,0 +1,446 @@
open Intermediate_utils
open Intermediate_ast
open Ast
open Cast
(** This file contains extremely simple functions printing C code. *)
let rec cp_includes fmt = function
| [] -> ()
| h :: t ->
Format.fprintf fmt "#include <%s.h>\n%a" h cp_includes t
let cp_node_state fmt (st: node_state) =
let print_if_any fmt (ty, nb, name): unit =
if nb = 0
then ()
else Format.fprintf fmt "\n\t%s %s[%d];" ty name nb
in
if st.nt_count_app = 0
then
Format.fprintf fmt "typedef struct {%a%a%a\n\
\tbool is_init, is_reset;\n\
} %s;\n\n"
print_if_any ("int", st.nt_nb_int, "ivars")
print_if_any ("bool", st.nt_nb_bool, "bvars")
print_if_any ("double", st.nt_nb_real, "rvars")
st.nt_name
else
Format.fprintf fmt "typedef struct {%a%a%a\n\
\tbool is_init, is_reset;\n\
\tvoid* aux_states[%d]; /* stores the states of auxiliary nodes */\n\
} %s;\n\n"
print_if_any ("int", st.nt_nb_int, "ivars")
print_if_any ("bool", st.nt_nb_bool, "bvars")
print_if_any ("double", st.nt_nb_real, "rvars")
st.nt_count_app st.nt_name
let cp_state_types fmt (h: (ident, node_state) Hashtbl.t): unit =
Hashtbl.iter (fun n nst ->
Format.fprintf fmt "/* Struct holding states of the node %s: */\n%a" n
cp_node_state nst) h
(** [cp_state_frees] prints the required code to recursively free the node
* states. *)
let cp_state_frees fmt (iprog, sts) =
let rec find_callee (i: int) (f: i_node) =
let rec aux_expr = function
| IETuple [] | IEVar _ | IEConst _ -> None
| IEMonOp (_, e) -> aux_expr e
| IEWhen (e, e')
| IEReset (e, e')
| IEComp (_, e, e')
| IEBinOp (_, e, e') ->
begin
match aux_expr e with
| None -> aux_expr e'
| Some res -> Some res
end
| IETriOp (_, e, e', e'') ->
begin
match aux_expr e with
| None ->
(match aux_expr e' with
| None -> aux_expr e''
| Some res -> Some res)
| Some res -> Some res
end
| IETuple (h :: t) ->
begin
match aux_expr h with
| None -> aux_expr (IETuple t)
| Some res -> Some res
end
| IEApp (j, n, e) ->
if i = j
then Some n.n_name
else aux_expr e
in
List.fold_right
(fun (_, expr) acc ->
match acc with
| Some _ -> acc
| None -> aux_expr expr)
f.in_equations None
in
let rec cp_free_aux fmt (i, caller_name) =
let idx = i - 1 in
match find_callee i (List.find (fun n -> n.in_name = caller_name) iprog)with
| None -> ()
| Some callee_name ->
let callee_st = Hashtbl.find sts callee_name in
if callee_st.nt_count_app > 0
then
Format.fprintf fmt "\tif (st->aux_states[%d]) {\n\
\t\tfree_state_%s((t_state_%s*)(st->aux_states[%d]));\n\
\t\tfree (st->aux_state[%d]);\n\t}\n%a"
idx callee_name callee_name idx
idx cp_free_aux (i+1, caller_name)
else Format.fprintf fmt "\tif (st->aux_states[%d])\n\
\t\tfree(st->aux_states[%d]);\n%a"
idx idx cp_free_aux (i+1, caller_name)
in
Hashtbl.iter
(fun node_name node_st ->
if node_st.nt_count_app = 0
then () (** Nothing to free for the node [node_name]. *)
else
Format.fprintf fmt "void free_state_%s(t_state_%s *);\n"
node_name node_name) sts;
Hashtbl.iter
(fun node_name node_st ->
if node_st.nt_count_app = 0
then () (** Nothing to free for the node [node_name]. *)
else
Format.fprintf fmt "void free_state_%s(t_state_%s *st)\n\
{\n\
%a\
}\n"
node_name node_name
cp_free_aux (1, node_name)) sts
let cp_var' fmt = function
| CVStored (arr, idx) -> Format.fprintf fmt "state->%s[%d]" arr idx
| CVInput s -> Format.fprintf fmt "%s" s
let cp_var fmt = function
| IVar s -> Format.fprintf fmt "int %s" s
| BVar s -> Format.fprintf fmt "bool %s" s
| RVar s -> Format.fprintf fmt "double %s" s
let rec cp_varlist' fmt vl =
let print_if_any fmt = function
| [] -> ()
| _ :: _ -> Format.fprintf fmt ", "
in
match vl with
| [] -> ()
| v :: vl ->
Format.fprintf fmt "%a%a%a"
cp_var' v
print_if_any vl
cp_varlist' vl
let rec cp_varlist fmt vl =
let print_if_any fmt = function
| [] -> ()
| _ :: _ -> Format.fprintf fmt ", "
in
match vl with
| [] -> ()
| v :: vl ->
Format.fprintf fmt "%a%a%a"
cp_var v
print_if_any vl
cp_varlist vl
(** [cp_prototype] prints functions prototypes (without the «;»). It is only
* used to write the beginning of functions right now. If we later allow to
* use auxiliary nodes before their definition, it might be useful to declare
* all the prototypes at the beginning of the file (Cf. [cp_prototypes] below.
*)
let cp_prototype fmt (node, h): unit =
match Hashtbl.find_opt h node.in_name with
| None -> failwith "This should not happened!"
| Some nst ->
begin
Format.fprintf fmt "void fn_%s (%s *state, %a)"
node.in_name
nst.nt_name
cp_varlist node.in_inputs
end
let rec cp_prototypes fmt ((nodes, h): i_nodelist * node_states) =
match nodes with
| [] -> ()
| node :: nodes ->
Format.fprintf fmt "%a;\n%a"
cp_prototype (node, h)
cp_prototypes (nodes, h)
(** [cp_value] prints values, that is unary or binary operations which can be
* inlined in the final code without requiring many manipulations.
* It uses a lot of parenthesis at the moment. An improvement would be to
* remove useless ones at some point. *)
let rec cp_value fmt (value, (hloc: (ident * bool, string * int) Hashtbl.t)) =
let string_of_binop = function
| BOp_add -> "+"
| BOp_sub -> "-"
| BOp_mul -> "*"
| BOp_div -> "/"
| BOp_mod -> "%"
| BOp_and -> "&&"
| BOp_or -> "||"
| BOp_arrow -> failwith "string_of_binop undefined on (->)"
in
let string_of_compop = function
| COp_eq -> "=="
| COp_neq -> "!="
| COp_le -> "<="
| COp_lt -> "<"
| COp_ge -> ">="
| COp_gt -> ">"
in
match value with
| CVariable (CVInput s) -> Format.fprintf fmt "%s" s
| CVariable (CVStored (arr, idx)) -> Format.fprintf fmt "state->%s[%d]" arr idx
| CConst (CInt i) -> Format.fprintf fmt "%d" i
| CConst (CBool b) -> Format.fprintf fmt "%s" (Bool.to_string b)
| CConst (CReal r) -> Format.fprintf fmt "%f" r
| CMonOp (MOp_not, v) -> Format.fprintf fmt "! (%a)" cp_value (v, hloc)
| CMonOp (MOp_minus, v) -> Format.fprintf fmt "- (%a)" cp_value (v, hloc)
| CMonOp (MOp_pre, (CVariable v)) ->
let varname = (match v with
| CVStored (arr, idx) ->
begin
match find_varname hloc (arr, idx) with
| None -> failwith "This varname should be defined."
| Some (n, _) -> n
end
| CVInput n -> n) in
let (arr, idx) = Hashtbl.find hloc (varname, true) in
Format.fprintf fmt "state->%s[%d]" arr idx
| CBinOp (BOp_arrow, v, v') ->
Format.fprintf fmt "(state->is_init ? (%a) : (%a))"
cp_value (v, hloc) cp_value (v', hloc)
| CBinOp (op, v, v') ->
Format.fprintf fmt "(%a) %s (%a)"
cp_value (v, hloc) (string_of_binop op) cp_value (v', hloc)
| CComp (op, v, v') ->
Format.fprintf fmt "(%a) %s (%a)"
cp_value (v, hloc) (string_of_compop op) cp_value (v', hloc)
| CMonOp (MOp_pre, _) ->
failwith "The linearization should have removed this case."
let prefix_ = ref "\t"
(** The following function prints one transformed equation of the program into a
* set of instruction ending in assignments. *)
let rec cp_block fmt (b, hloc) =
match b with
| [] -> ()
| e :: b ->
Format.fprintf fmt "%a%a" cp_expression (e, hloc) cp_block (b, hloc)
and cp_expression fmt (expr, hloc) =
let prefix = !prefix_ in
match expr with
| CAssign (CVStored (arr, idx), value) ->
begin
Format.fprintf fmt "%sstate->%s[%d] = %a;\n"
prefix arr idx cp_value (value, hloc)
end
| CAssign (CVInput _, _) -> failwith "never assign an input."
| CSeq (e, e') ->
Format.fprintf fmt "%a%a"
cp_expression (e, hloc)
cp_expression (e', hloc)
| CApplication (fn, nb, argl, destl, h) ->
begin
let aux_node_st = Hashtbl.find h fn in
let h_out = aux_node_st.nt_output_map in
Format.fprintf fmt "%sfn_%s(%s, %a);\n"
prefix fn
(Format.asprintf "state->aux_states[%d]" (nb-1))
cp_varlist' argl;
let _ = List.fold_left
(fun i var ->
match var with
| CVStored (arr, idx) ->
let (arr', idx') = Hashtbl.find h_out i in
Format.fprintf fmt "%sstate->%s[%d] = ((%s*)(state->aux_states[%d]))->%s[%d];\n"
prefix arr idx
aux_node_st.nt_name (nb-1)
arr' idx';
i+1
| CVInput _ -> failwith "Impossible!")
0 destl in ()
end
| CReset (node_name, i, v, b) ->
begin
Format.fprintf fmt "\tif (%a) {\n\
\t\t((t_state_%s*)(state->aux_states[%d]))->is_init = true;\n\
\t\t((t_state_%s*)(state->aux_states[%d]))->is_reset = true;\n\
\t}\n\
%a\n"
cp_value (v, hloc)
node_name
(i - 1)
node_name
(i - 1)
cp_block (b, hloc)
end
| CIf (v, b1, []) ->
let p = prefix in
prefix_ := prefix^"\t";
Format.fprintf fmt "%sif (%a) {\n%a%s}\n"
p
cp_value (v, hloc)
cp_block (b1, hloc)
p;
prefix_ := p
| CIf (v, b1, b2) ->
let p = prefix in
prefix_ := prefix^"\t";
Format.fprintf fmt "%sif (%a) {\n%a%s} else {\n%a%s}\n"
p
cp_value (v, hloc)
cp_block (b1, hloc)
p
cp_block (b2, hloc)
p;
prefix_ := p
(** [cp_main] prints a main function to the C code if necessary:
* if there is a function [main] in the lustre program, it will generate a main
* function in the C code, otherwise it does not do anything.
*)
let cp_main_fn fmt (prog, sts) =
let rec cp_array fmt (vl: t_var list): unit =
match vl with
| [] -> ()
| v :: vl ->
let typ, name =
match v with
| IVar s -> ("int", s)
| RVar s -> ("double", s)
| BVar s ->
Format.fprintf fmt "\tchar _char_of_%s;\n" s;
("bool", s)
in
Format.fprintf fmt "\t%s %s;\n%a" typ name
cp_array vl
in
let rec cp_inputs fmt (f, l) =
match l with
| [] -> ()
| h :: t ->
(if f
then Format.fprintf fmt ", %s%a"
else Format.fprintf fmt "%s%a")
(Utils.name_of_var h)
cp_inputs (true, t)
in
let cp_scanf fmt vl =
let rec cp_scanf_str fmt (b, vl) =
match vl with
| [] -> ()
| h :: t ->
(if b
then Format.fprintf fmt " %s%a"
else Format.fprintf fmt "%s%a")
(match h with
| IVar _ -> "%d"
| BVar _ -> "%c"
| RVar _ -> "%lf")
cp_scanf_str (true, t)
in
let rec cp_scanf_args fmt vl =
match vl with
| [] -> ()
| RVar s :: vl | IVar s :: vl ->
Format.fprintf fmt ", &%s%a" s cp_scanf_args vl
| BVar s :: vl ->
Format.fprintf fmt ", &%s%a" (Format.sprintf "_char_of_%s" s)
cp_scanf_args vl
in
Format.fprintf fmt "\"%a\"%a"
cp_scanf_str (false, vl)
cp_scanf_args vl
in
let cp_printf fmt vl =
let rec cp_printf_str fmt (b, vl) =
match vl with
| [] -> ()
| h :: t ->
(if b
then Format.fprintf fmt " %s%a"
else Format.fprintf fmt "%s%a")
(match h with
| IVar _ -> "%d"
| BVar _ -> "%c"
| RVar _ -> "%f")
cp_printf_str (true, t)
in
let rec cp_printf_arg fmt (h, i) =
match Hashtbl.find_opt h i with
| None -> ()
| Some (s, i) ->
Format.fprintf fmt ", state.%s[%d]%a"
s i cp_printf_arg (h, i+1)
in
Format.fprintf fmt "\"%a\\n\"%a"
cp_printf_str (false, vl)
cp_printf_arg ((Hashtbl.find sts "main").nt_output_map, 0)
in
let rec cp_char_to_bool fmt vl =
match vl with
| [] -> ()
| RVar _ :: vl | IVar _ :: vl -> Format.fprintf fmt "%a" cp_char_to_bool vl
| BVar s :: vl ->
Format.fprintf fmt "\t\t%s = (%s == 't') ? true : false;\n%a"
s (Format.sprintf "_char_of_%s" s)
cp_char_to_bool vl
in
let cp_free fmt () =
let main_st = Hashtbl.find sts "main" in
if main_st.nt_count_app = 0
then ()
else Format.fprintf fmt "\tfree_state_main(&state);\n"
in
match List.find_opt (fun n -> n.n_name = "main") prog with
| None -> ()
| Some node ->
Format.fprintf fmt "int main (int argc, char **argv)\n\
{\n%a\n\
\tchar _buffer[1024];\n\
\tt_state_main state;\n\
\tstate.is_init = true;\n\
\tstate.is_reset = false;\n\
\twhile(true) {\n\
\t\tscanf(\"%%s\", _buffer);\n\
\t\tif(!strcmp(_buffer, \"exit\")) { break; }\n\
\t\tsscanf(_buffer, %a);\n%a\
\t\tfn_main(&state, %a);\n\
\t\tprintf(%a);\n\
\t}\n\
%a\treturn EXIT_SUCCESS;\n\
}\n"
cp_array (snd node.n_inputs)
cp_scanf (snd node.n_inputs)
cp_char_to_bool (snd node.n_inputs)
cp_inputs (false, snd node.n_inputs)
cp_printf (snd node.n_outputs)
cp_free ()

120
src/ctranslation.ml Normal file
View File

@@ -0,0 +1,120 @@
open Ast
open Intermediate_ast
open Cast
let rec iexpression_to_cvalue e =
match e with
| IEVar v -> CVariable v
| IEMonOp (op, e) -> CMonOp (op, iexpression_to_cvalue e)
| IEBinOp (op, e, e') ->
CBinOp (op, iexpression_to_cvalue e, iexpression_to_cvalue e')
| IEComp (op, e, e') ->
CComp (op, iexpression_to_cvalue e, iexpression_to_cvalue e')
| IEConst c -> CConst c
| IEWhen _
| IEReset _
| IETuple _
| IEApp _
| IETriOp _ -> failwith "Should not happened."
let rec equation_to_expression (node_st, node_sts, (vl, expr)) =
let hloc = node_st.nt_map in
let fetch_unique_var () =
match vl with
| [v] ->
begin
match Hashtbl.find_opt hloc (Utils.name_of_var v, false) with
| None -> CVInput (Utils.name_of_var v)
| Some (arr, idx) -> CVStored (arr, idx)
end
| _ -> failwith "This should not happened."
in
match expr with
| IEVar vsrc ->
CAssign (fetch_unique_var (), CVariable vsrc)
| IEMonOp (MOp_pre, IEVar v) ->
CAssign (fetch_unique_var (), CVariable v)
| IEConst c ->
CAssign (fetch_unique_var (), CConst c)
| IEMonOp (op, e) ->
CAssign (fetch_unique_var (),
CMonOp (op, iexpression_to_cvalue e))
| IEBinOp (op, e, e') ->
CAssign (fetch_unique_var (),
CBinOp (op, iexpression_to_cvalue e, iexpression_to_cvalue e'))
| IEComp (op, e, e') ->
CAssign (fetch_unique_var (),
CComp (op, iexpression_to_cvalue e, iexpression_to_cvalue e'))
(** [CApp] below represents the i-th call to an aux node *)
| IEApp (i, node, e) ->
(** e is a tuple of variables due to the linearization pass *)
let al: c_var list =
match e with
| IETuple l ->
List.map
(function
| IEVar v -> v
| _ -> failwith "should not happened due to the linearization pass."
) l
| _ -> failwith "should not happened due to the linearization pass."
in
let vl =
List.map
(fun v ->
match Hashtbl.find_opt hloc (Utils.name_of_var v, false) with
| Some (arr, idx) -> CVStored (arr, idx)
| None -> CVInput (Utils.name_of_var v))
vl
in
CApplication (node.n_name,i , al, vl, node_sts)
| IETuple _ -> failwith "linearization should have \
transformed the tuples of the right members."
| IEWhen (expr, cond) ->
begin
CIf (iexpression_to_cvalue cond,
[equation_to_expression (node_st, node_sts, (vl, expr))],
[])
end
| IETriOp (TOp_if, _, _, _) ->
failwith "A pass should have turned conditionnals into merges."
| IETriOp (TOp_merge, c, e, e') ->
CIf (iexpression_to_cvalue c,
[equation_to_expression (node_st, node_sts, (vl, e))],
[equation_to_expression (node_st, node_sts, (vl, e'))])
| IEReset (IEApp (i, node, b), c) -> CReset (node.n_name, i, iexpression_to_cvalue c, [equation_to_expression (node_st, node_sts, (vl, IEApp (i, node, b)))])
| IEReset _ -> failwith "A pass should have turned not function resets into function resets"
let rec remove_ifnot = function
| [] -> []
| CIf (CMonOp (MOp_not, c), bh :: bt, b'h :: b't) :: block ->
(CIf (c, b'h :: b't, bh :: bt)) :: (remove_ifnot block )
| stmt :: block ->
stmt :: (remove_ifnot block)
let rec merge_neighbour_ifs = function
| [] -> []
| [stmt] -> [stmt]
| CIf (c, e1, e2) :: CIf (c', e'1, e'2) :: b ->
begin
if c = c' then
merge_neighbour_ifs
(CIf (c,
merge_neighbour_ifs (e1 @ e'1),
merge_neighbour_ifs (e2 @ e'2)) :: b)
else if c = CMonOp (MOp_not, c') then
merge_neighbour_ifs
(CIf (c',
merge_neighbour_ifs (e2 @ e'1),
merge_neighbour_ifs (e1 @ e'2)) :: b)
else if c' = CMonOp (MOp_not, c) then
merge_neighbour_ifs
(CIf (c,
merge_neighbour_ifs (e1 @ e'2),
merge_neighbour_ifs (e2 @ e'1)) :: b)
else CIf (c, e1, e2) :: merge_neighbour_ifs (CIf (c', e'1, e'2) :: b)
end
| stmt :: stmt' :: b ->
stmt :: merge_neighbour_ifs (stmt' :: b)

75
src/intermediate_ast.ml Normal file
View File

@@ -0,0 +1,75 @@
open Ast
(** A node state is translated into a struct. This struct has:
* 1. A name (t_state_<name of the node>)
* 2. A number of local and output variables of each type (int, real, bool)
* 3-5. mappings that maps
* [(variable, is_pre)] to an index of the corresponding array (see below)
* where [variable] is of type [t_var], and [is_pre] indicated whether we
* deal with pre (x) or x.
* 6. A mapping mapping any variable to the name of the C table containing it
* and the index at which it is stored (= union of the tables [nt_map_*])
* 7. A mapping mapping the output number i to its location (name of the
* table that contains it and index.
*
* Important Note: if a variable x appears behind a pre, it will count as two
* variables in the point 2. above..
*
* It should be translated as follow in C:
typedef struct {
int ivars[nt_nb_int]; (or nothing if nt_nb_int = 0)
int bvars[nt_nb_bool]; (or nothing if nt_nb_bool = 0)
int rvars[nt_nb_real]; (or nothing if nt_nb_real = 0)
bool is_init;
} t_state_<node name>;
*)
type node_state =
{
nt_name: string;
nt_nb_int : int;
nt_nb_real: int;
nt_nb_bool: int;
nt_map: (ident * bool, string * int) Hashtbl.t;
nt_output_map: (int, string * int) Hashtbl.t;
nt_prevars: t_var list;
nt_count_app: int;
}
type c_var =
| CVStored of string * int
| CVInput of ident
type i_expression =
| IEVar of c_var
| IEMonOp of monop * i_expression
| IEBinOp of binop * i_expression * i_expression
| IETriOp of triop * i_expression * i_expression * i_expression
| IEComp of compop * i_expression * i_expression
| IEWhen of i_expression * i_expression
| IEReset of i_expression * i_expression
| IEConst of const
| IETuple of (i_expression list)
(** [CApp] below represents the n-th call to an aux node *)
| IEApp of int * t_node * i_expression
and i_varlist = t_var list
and i_equation = i_varlist * i_expression
and i_eqlist = i_equation list
and i_node =
{
in_name : ident;
in_inputs: i_varlist;
in_outputs: i_varlist;
in_local_vars: i_varlist;
in_equations: i_eqlist;
}
type i_nodelist = i_node list
type node_states = (ident, node_state) Hashtbl.t

50
src/intermediate_utils.ml Normal file
View File

@@ -0,0 +1,50 @@
open Intermediate_ast
let rec find_app_opt eqs i =
let rec find_app_expr_opt i = function
| IEVar _ | IEConst _ -> None
| IEMonOp (_, e) -> find_app_expr_opt i e
| IEReset (e, e') | IEWhen (e, e') | IEComp (_, e, e') | IEBinOp (_, e, e') ->
begin
match find_app_expr_opt i e with
| None -> find_app_expr_opt i e'
| Some n -> Some n
end
| IETriOp (_, e, e', e'') ->
begin
match find_app_expr_opt i e with
| None ->
begin
match find_app_expr_opt i e' with
| None -> find_app_expr_opt i e''
| Some n -> Some n
end
| Some n -> Some n
end
| IETuple l ->
List.fold_left
(fun acc e ->
match acc, find_app_expr_opt i e with
| Some n, _ -> Some n
| None, v -> v)
None l
(** [IEApp] below represents the n-th call to an aux node *)
| IEApp (j, n, e) ->
if i = j
then Some n
else find_app_expr_opt i e
in
match eqs with
| [] -> None
| (_, expr) :: eqs ->
match find_app_expr_opt i expr with
| None -> find_app_opt eqs i
| Some n -> Some n
let find_varname h v =
Hashtbl.fold
(fun s e acc ->
match acc with
| None -> if e = v then Some s else None
| Some _ -> acc)
h None

View File

@@ -26,6 +26,7 @@
("merge", TO_merge);
("when", WHEN);
("reset", RESET);
("every", EVERY);
("pre", MO_pre);
("true", CONST_BOOL(true));
("false", CONST_BOOL(false));

View File

@@ -37,7 +37,7 @@ let rec pp_varlist fmt : t_varlist -> unit = function
Format.fprintf fmt "%s: bool, %a" h pp_varlist (tl, h' :: l)
| (TReal :: tl, RVar h :: h' :: l) ->
Format.fprintf fmt "%s: real, %a" h pp_varlist (tl, h' :: l)
| _ -> raise (MyTypeError "This exception should not have beed be raised.")
| _ -> raise (MyTypeError "(1) This exception should not have beed be raised.")
let pp_expression =
let upd_prefix s = s ^ " | " in
@@ -45,11 +45,14 @@ let pp_expression =
let rec pp_expression_list prefix fmt exprs =
match exprs with
| ETuple([], []) -> ()
| ETuple (_ :: tt, expr :: exprs) ->
| ETuple (typs, expr :: exprs) ->
let typ_h, typ_t =
Utils.list_select (List.length (Utils.type_exp expr)) typs in
Format.fprintf fmt "%a%a"
(pp_expression_aux (prefix^" |> ")) expr
(pp_expression_list prefix) (ETuple (tt, exprs))
| _ -> raise (MyTypeError "This exception should not have been raised.")
(pp_expression_list prefix) (ETuple (typ_t, exprs))
| ETuple (_, []) -> failwith "An empty tuple has a type!"
| _ -> failwith "This exception should never occur."
in
match expression with
| EWhen (_, e1, e2) ->
@@ -70,7 +73,7 @@ let pp_expression =
begin match c with
| CBool b -> Format.fprintf fmt "\t\t\t%s<%s : bool>\n" prefix (Bool.to_string b)
| CInt i -> Format.fprintf fmt "\t\t\t%s<%5d: int>\n" prefix i
| CReal r -> Format.fprintf fmt "\t\t\t%s<%5f: float>\n" prefix r
| CReal r -> Format.fprintf fmt "\t\t\t%s<%5f: real>\n" prefix r
end
| EVar (_, IVar v) -> Format.fprintf fmt "\t\t\t%s<int var %s>\n" prefix v
| EVar (_, BVar v) -> Format.fprintf fmt "\t\t\t%s<bool var %s>\n" prefix v

View File

@@ -9,24 +9,46 @@ let print_debug d s =
let print_verbose v s =
if v then Format.printf "\x1b[33;01;04mStatus:\x1b[0m %s\n" s else ()
let exec_passes ast main_fn verbose debug passes f =
(** [exec_passes] executes the passes on the parsed typed-AST.
* A pass should return [Some program] in case of a success, and [None]
* otherwise.
*
* The function [exec_passes] returns the optionnal program returned by the
* last pass.
*
* A pass should never be interrupted by an exception. Nevertheless, we make
* sure that no pass raise one. *)
let exec_passes ast verbose debug passes f =
let rec aux ast = function
| [] -> f ast
| (n, p) :: passes ->
verbose (Format.asprintf "Executing pass %s:\n" n);
match p verbose debug main_fn ast with
| None -> (exit_error ("Error while in the pass "^n^".\n"); exit 0)
| Some ast -> (
debug (Format.asprintf "Current AST (after %s):\n%a\n" n Pp.pp_ast ast);
aux ast passes)
try
begin
match p verbose debug ast with
| None -> (exit_error ("Error while in the pass "^n^".\n"); exit 0)
| Some ast -> (
debug
(Format.asprintf
"Current AST (after %s):\n%a\n" n Lustre_pp.pp_ast ast);
aux ast passes)
end with
| _ -> failwith ("The pass "^n^" should have caught me!")
in
aux ast passes
let _ =
(** Usage and argument parsing. *)
let default_passes = ["pre2vars"; "automata_validity" ;"automata_translation"; "linearization"; "equations_ordering"] in
let sanity_passes = ["chkvar_init_unicity"; "check_typing"] in
let default_passes =
["linearization_reset"; "remove_if";
"linearization_pre"; "linearization_tuples"; "linearization_app";
"ensure_assign_val";
"equations_ordering"] in
let sanity_passes = ["sanity_pass_assignment_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
@@ -34,7 +56,6 @@ let _ =
let debug = ref false in
let ppast = ref false in
let nopopt = ref false in
let simopt = ref false in
let passes = ref [] in
let source_file = ref "" in
let testopt = ref false in
@@ -51,7 +72,6 @@ let _ =
("-debug", Arg.Set debug, "Output a lot of debug information");
("-p", Arg.String (fun s -> passes := s :: !passes),
"Add a pass to the compilation process");
("-sim", Arg.Set simopt, "Simulate the main node");
("-o", Arg.Set_string output_file, "Output file (defaults to [out.c])");
] in
Arg.parse speclist anon_fun usage_msg ;
@@ -59,19 +79,23 @@ let _ =
if !passes = [] then passes := default_passes;
let print_verbose = print_verbose !verbose in
let print_debug = print_debug !debug in
let main_fn = "main" in
(** Definition of the passes table *)
let passes_table = Hashtbl.create 100 in
List.iter (fun (s, k) -> Hashtbl.add passes_table s k)
[
("pre2vars", Passes.pre2vars);
("chkvar_init_unicity", Passes.chkvar_init_unicity);
("remove_if", Passes.pass_if_removal);
("linearization_tuples", Passes.pass_linearization_tuples);
("linearization_app", Passes.pass_linearization_app);
("linearization_pre", Passes.pass_linearization_pre);
("ensure_assign_val", Passes.pass_ensure_assignment_value);
("linearization_reset", Passes.pass_linearization_reset);
("sanity_pass_assignment_unicity", Passes.sanity_pass_assignment_unicity);
("automata_translation", Passes.automata_translation_pass);
("automata_validity", Passes.check_automata_validity);
("linearization", Passes.pass_linearization);
("automata_validity", Passes.check_automata_validity);
("equations_ordering", Passes.pass_eq_reordering);
("check_typing", Passes.pass_typing);
("clock_unification", Passes.clock_unification_pass);
];
(** Main functionality below *)
@@ -92,7 +116,7 @@ let _ =
begin
close_in_noerr inchan;
Format.printf "Syntax error at %a: %s\n\n"
Pp.pp_loc (l, !source_file) s;
Lustre_pp.pp_loc (l, !source_file) s;
exit 0
end
| Parsing.Parse_error ->
@@ -100,11 +124,16 @@ let _ =
close_in_noerr inchan;
Parsing.(
Format.printf "Syntax error at %a\n\n"
Pp.pp_loc ((symbol_start_pos (), symbol_end_pos()), !source_file));
Lustre_pp.pp_loc ((symbol_start_pos (), symbol_end_pos()), !source_file));
exit 0
end
in
(** Computes the list of passes to execute. If the [-test] flag is set, all
* sanity passes (ie. passes which do not modify the AST, but ensure its
* validity) are re-run after any other pass.
*
* Note: the sanity passes are always executed before any other. *)
let passes =
List.map
(fun (pass: string) -> (pass,
@@ -120,19 +149,14 @@ let _ =
in
print_debug (Format.asprintf "Initial AST (before executing any passes):\n%a"
Pp.pp_ast ast) ;
exec_passes ast main_fn print_verbose print_debug passes
begin
if !simopt
then Simulation.simulate main_fn
else
begin
if !ppast
then (Format.printf "%a" Pp.pp_ast)
else (
if !nopopt
then (fun _ -> ())
else Format.printf "%a" Ast_to_c.ast_to_c)
end
end
Lustre_pp.pp_ast ast) ;
exec_passes ast print_verbose print_debug passes
begin
if !ppast
then (Format.printf "%a" Lustre_pp.pp_ast)
else (
if !nopopt
then (fun _ -> ())
else Ast_to_c.ast_to_c print_verbose print_debug)
end

View File

@@ -63,7 +63,7 @@
let make_binop_nonbool e1 e2 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in
(** e1 and e2 should be nunmbers here.*)
(** e1 and e2 should be numbers here.*)
if list_chk t1 [[TInt]; [TReal]] && list_chk t2 [[TInt]; [TReal]]
then
begin
@@ -88,7 +88,7 @@
let make_comp_nonbool e1 e2 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in
(** e1 and e2 should be nunmbers here.*)
(** e1 and e2 should be numbers here.*)
if list_chk t1 [[TInt]; [TReal]] && list_chk t2 [[TInt]; [TReal]]
then
begin
@@ -144,6 +144,7 @@
%token WHEN
%token RESET
%token EVERY
%token IF
%token THEN
@@ -215,8 +216,8 @@ node_content:
if vars_distinct e_in e_out (snd $10)
then (Hashtbl.add defined_nodes node_name n; n)
else raise (MyParsingError
("There is a conflict between the names of local, input \
or output variables.",
("There is a conflict between the names of local,\
input or output variables.",
current_location()))
end};
@@ -276,6 +277,7 @@ equations:
| /* empty */ { [] }
| equation SEMICOL equations
{ $1 :: $3 }
| equation OPTIONAL_SEMICOL { [$1] }
;
equation:
@@ -311,33 +313,33 @@ expr:
| MO_pre expr { EMonOp (type_exp $2, MOp_pre, $2) }
| MINUS expr
{ monop_neg_condition $2 [TBool]
"You cannot take the opposite of a boolean expression."
"You cannot take the opposite of an expression that is not a number."
(EMonOp (type_exp $2, MOp_minus, $2)) }
| PLUS expr
{ monop_neg_condition $2 [TBool]
"You cannot take the plus of a boolean expression." $2 }
"(+) expects its argument to be a number." $2 }
/* Binary operators */
| expr PLUS expr
{ make_binop_nonbool $1 $3 BOp_add
"You should know better; addition hates booleans" }
"Addition expects both arguments to be (the same kind of) numbers." }
| expr MINUS expr
{ make_binop_nonbool $1 $3 BOp_sub
"You should know better; subtraction hates booleans" }
"Substraction expects both arguments to be (the same kind of) numbers." }
| expr BO_mul expr
{ make_binop_nonbool $1 $3 BOp_mul
"You should know better; multiplication hates booleans" }
"Multiplication expects both arguments to be (the same kind of) numbers." }
| expr BO_div expr
{ make_binop_nonbool $1 $3 BOp_div
"You should know better; division hates booleans" }
"Division expects both arguments to be (the same kind of) numbers." }
| expr BO_mod expr
{ make_binop_nonbool $1 $3 BOp_mod
"You should know better; modulo hates booleans" }
"Modulo expects both arguments to be numbers." }
| expr BO_and expr
{ make_binop_bool $1 $3 BOp_and
"You should know better; conjunction hates numbers" }
"Conjunction expects both arguments to be booleans." }
| expr BO_or expr
{ make_binop_bool $1 $3 BOp_or
"You should know better; disjunction hates numbers" }
"Disjunction expects both arguments to be booleans." }
| expr BO_arrow expr
{ let e1 = $1 in let t1 = type_exp e1 in
let e2 = $3 in let t2 = type_exp e2 in
@@ -380,9 +382,9 @@ expr:
then EWhen (t1, e1, e2)
else raise (MyParsingError ("The when does not type-check!",
current_location())) }
| expr RESET expr
{ let e1 = $1 in let t1 = type_exp e1 in
let e2 = $3 in let t2 = type_exp e2 in
| RESET expr EVERY expr
{ let e1 = $2 in let t1 = type_exp e1 in
let e2 = $4 in let t2 = type_exp e2 in
if t2 = [TBool]
then EReset (t1, e1, e2)
else raise (MyParsingError ("The reset does not type-check!",

View File

@@ -4,92 +4,544 @@ open Ast
open Passes_utils
open Utils
let pre2vars verbose debug main_fn =
let rec all_pre expr =
match expr with
| EMonOp (ty, MOp_pre, expr) -> all_pre expr
| EMonOp _ -> false
| EVar _ -> true
| _ -> false
in
let rec pre_push expr : t_expression =
match expr with
| EVar _ -> EMonOp (type_exp expr, MOp_pre, expr)
| EConst _ -> expr (** pre(c) = c for any constant c *)
| EMonOp (ty, mop, expr) ->
begin
match mop with
| MOp_pre ->
if all_pre expr
then EMonOp (ty, mop, EMonOp (ty, mop, expr))
else pre_push (pre_push expr)
| _ -> EMonOp (ty, mop, pre_push expr)
end
| EBinOp (ty, bop, expr, expr') ->
let expr = pre_push expr in let expr' = pre_push expr' in
EBinOp (ty, bop, expr, expr')
| ETriOp (ty, top, expr, expr', expr'') ->
let expr = pre_push expr in let expr' = pre_push expr' in
let expr'' = pre_push expr'' in
ETriOp (ty, top, expr, expr', expr'')
| EComp (ty, cop, expr, expr') ->
let expr = pre_push expr in let expr' = pre_push expr' in
EComp (ty, cop, expr, expr')
| EWhen (ty, expr, expr') ->
let expr = pre_push expr in let expr' = pre_push expr' in
EWhen (ty, expr, expr')
| EReset (ty, expr, expr') ->
let expr = pre_push expr in let expr' = pre_push expr' in
EReset (ty, expr, expr')
| ETuple (ty, elist) ->
let elist =
List.fold_right (fun expr acc -> (pre_push expr) :: acc) elist [] in
ETuple (ty, elist)
| EApp (ty, node, arg) ->
let arg = pre_push arg in
EApp (ty, node, arg)
in
let rec aux (expr: t_expression) =
match expr with
| EVar _ -> expr
| EMonOp (ty, mop, expr) ->
begin
match mop with
| MOp_pre -> pre_push expr
| _ -> let expr = aux expr in EMonOp (ty, mop, expr)
end
| EBinOp (ty, bop, expr, expr') ->
let expr = aux expr in let expr' = aux expr' in
EBinOp (ty, bop, expr, expr')
| ETriOp (ty, top, expr, expr', expr'') ->
let expr = aux expr in let expr' = aux expr' in
let expr'' = aux expr'' in
ETriOp (ty, top, expr, expr', expr'')
| EComp (ty, cop, expr, expr') ->
let expr = aux expr in let expr' = aux expr' in
EComp (ty, cop, expr, expr')
| EWhen (ty, expr, expr') ->
let expr = aux expr in let expr' = aux expr' in
EWhen (ty, expr, expr')
| EReset (ty, expr, expr') ->
let expr = aux expr in let expr' = aux expr' in
EReset (ty, expr, expr')
| EConst (ty, c) -> EConst (ty, c)
| ETuple (ty, elist) ->
let elist =
List.fold_right (fun expr acc -> (aux expr) :: acc) elist [] in
ETuple (ty, elist)
| EApp (ty, node, arg) ->
let arg = aux arg in
EApp (ty, node, arg)
in
expression_pass (somify aux)
let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option =
(** [pass_if_removal] replaces the `if` construct with `when` and `merge` ones.
*
* [x1, ..., xn = if c then e_l else e_r;]
* is replaced by:
* (t1, ..., tn) = e_l;
* (u1, ..., un) = e_r;
* (v1, ..., vn) = (t1, ..., tn) when c;
* (w1, ..., wn) = (u1, ..., un) when (not c);
* (x1, ..., xn) = merge c (v1, ..., vn) (w1, ..., wn);
*
* Note that the first two equations (before the use of when) is required in
* order to have the expressions active at each step.
*)
let pass_if_removal verbose debug =
let varcount = ref 0 in (** new variables are called «_ifrem[varcount]» *)
(** Makes a pattern (t_varlist) of fresh variables matching the type t *)
let make_patt t: t_varlist =
(t, List.fold_right
(fun ty acc ->
let nvar: ident = Format.sprintf "_ifrem%d" !varcount in
let nvar =
match ty with
| TInt -> IVar nvar
| TReal -> RVar nvar
| TBool -> BVar nvar
in
incr varcount;
nvar :: acc)
t [])
in
(** If a tuple contains a single element, it should not be. *)
let simplify_tuple t =
match t with
| ETuple (t, [elt]) -> elt
| _ -> t
in
(** For each equation, build a list of equations and a new list of local
* variables as well as an updated version of the original equation. *)
let rec aux_eq vars eq: t_eqlist * t_varlist * t_equation =
let patt, expr = eq in
match expr with
| EConst _ | EVar _ -> [], vars, eq
| EMonOp (t, op, e) ->
let eqs, vars, (patt, e) = aux_eq vars (patt, e) in
eqs, vars, (patt, EMonOp (t, op, e))
| EBinOp (t, op, e, e') ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
let eqs', vars, (_, e') = aux_eq vars (patt, e') in
eqs @ eqs', vars, (patt, EBinOp (t, op, e, e'))
| ETriOp (t, TOp_if, e, e', e'') ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
let eqs', vars, (_, e') = aux_eq vars (patt, e') in
let eqs'', vars, (_, e'') = aux_eq vars (patt, e'') in
let patt_l: t_varlist = make_patt t in
let patt_r: t_varlist = make_patt t in
let patt_l_when: t_varlist = make_patt t in
let patt_r_when: t_varlist = make_patt t in
let expr_l: t_expression =
simplify_tuple
(ETuple
(fst patt_l, List.map (fun v -> EVar (type_var v, v)) (snd patt_l)))
in
let expr_r: t_expression =
simplify_tuple
(ETuple
(fst patt_r, List.map (fun v -> EVar (type_var v, v)) (snd patt_r)))
in
let expr_l_when: t_expression =
simplify_tuple
(ETuple
(fst patt_l_when, List.map (fun v -> EVar (type_var v, v))
(snd patt_l_when)))
in
let expr_r_when: t_expression =
simplify_tuple
(ETuple
(fst patt_r_when, List.map (fun v -> EVar (type_var v, v))
(snd patt_r_when)))
in
let equations: t_eqlist =
[(patt_l, e');
(patt_r, e'');
(patt_l_when,
EWhen (t, expr_l, e));
(patt_r_when,
EWhen (t,
expr_r,
(EMonOp (type_exp e, MOp_not, e))))]
@ eqs @ eqs' @eqs'' in
let vars: t_varlist =
varlist_concat
vars
(varlist_concat patt_l_when (varlist_concat patt_r_when
(varlist_concat patt_r patt_l))) in
let expr =
ETriOp (t, TOp_merge, e, expr_l_when, expr_r_when) in
equations, vars, (patt, expr)
| ETriOp (t, op, e, e', e'') ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
let eqs', vars, (_, e') = aux_eq vars (patt, e') in
let eqs'', vars, (_, e'') = aux_eq vars (patt, e'') in
eqs @ eqs' @ eqs'', vars, (patt, ETriOp (t, op, e, e', e''))
| EComp (t, op, e, e') ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
let eqs', vars, (_, e') = aux_eq vars (patt, e') in
eqs @ eqs', vars, (patt, EComp (t, op, e, e'))
| EWhen (t, e, e') ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
let eqs', vars, (_, e') = aux_eq vars (patt, e') in
eqs @ eqs', vars, (patt, EWhen (t, e, e'))
| EReset (t, e, e') ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
let eqs', vars, (_, e') = aux_eq vars (patt, e') in
eqs @ eqs', vars, (patt, EReset (t, e, e'))
| ETuple (t, l) ->
let eqs, vars, l, _ =
List.fold_right
(fun e (eqs, vars, l, remaining_patt) ->
let patt_l, patt_r = split_patt remaining_patt e in
let eqs', vars, (_, e) = aux_eq vars (patt_l, e) in
eqs' @ eqs, vars, (e :: l), patt_r)
l ([], vars, [], patt) in
eqs, vars, (patt, ETuple (t, l))
| EApp (t, n, e) ->
let eqs, vars, (_, e) = aux_eq vars (patt, e) in
eqs, vars, (patt, EApp (t, n, e))
in
(** For each node, apply the previous function to all equations. *)
let aux_if_removal node =
let new_equations, new_locvars =
List.fold_left
(fun (eqs, vars) eq ->
let eqs', vars, eq = aux_eq vars eq in
eq :: eqs' @ eqs, vars)
([], node.n_local_vars) node.n_equations
in
Some { node with n_equations = new_equations; n_local_vars = new_locvars }
in
node_pass aux_if_removal
(** [pass_linearization_reset] makes sure that all reset constructs in the program
* are applied to functions.
* This is required, since the reset construct is translated into resetting the
* function state in the final C code. *)
let pass_linearization_reset verbose debug =
(** [node_lin] linearizes a single node. *)
let node_lin (node: t_node): t_node option =
(** [reset_aux_expression] takes an expression and returns:
* - a list of additional equations
* - the new list of local variables
* - an updated version of the original expression *)
let rec reset_aux_expression vars expr: t_eqlist * t_varlist * t_expression =
match expr with
| EVar _ -> [], vars, expr
| EMonOp (t, op, e) ->
let eqs, vars, e = reset_aux_expression vars e in
eqs, vars, EMonOp (t, op, e)
| EBinOp (t, op, e, e') ->
let eqs, vars, e = reset_aux_expression vars e in
let eqs', vars, e' = reset_aux_expression vars e' in
eqs @ eqs', vars, EBinOp (t, op, e, e')
| ETriOp (t, op, e, e', e'') ->
let eqs, vars, e = reset_aux_expression vars e in
let eqs', vars, e' = reset_aux_expression vars e' in
let eqs'', vars, e'' = reset_aux_expression vars e'' in
eqs @ eqs' @ eqs'', vars, ETriOp (t, op, e, e', e'')
| EComp (t, op, e, e') ->
let eqs, vars, e = reset_aux_expression vars e in
let eqs', vars, e' = reset_aux_expression vars e' in
eqs @ eqs', vars, EComp (t, op, e, e')
| EWhen (t, e, e') ->
let eqs, vars, e = reset_aux_expression vars e in
let eqs', vars, e' = reset_aux_expression vars e' in
eqs @ eqs', vars, EWhen (t, e, e')
| EReset (t, e, e') ->
(
match e with
| EApp (t_app, n_app, e_app) ->
let eqs, vars, e = reset_aux_expression vars e in
eqs, vars, EReset (t, e, e')
| e -> reset_aux_expression vars e
)
| EConst _ -> [], vars, expr
| ETuple (t, l) ->
let eqs, vars, l = List.fold_right
(fun e (eqs, vars, l) ->
let eqs', vars, e = reset_aux_expression vars e in
eqs' @ eqs, vars, (e :: l))
l ([], vars, []) in
eqs, vars, ETuple (t, l)
| EApp (t, n, e) ->
let eqs, vars, e = reset_aux_expression vars e in
eqs, vars, EApp (t, n, e)
in
(** Applies the previous function to the expressions of every equation. *)
let new_equations, new_locvars =
List.fold_left
(fun (eqs, vars) (patt, expr) ->
let eqs', vars, expr = reset_aux_expression vars expr in
(patt, expr)::eqs' @ eqs, vars)
([], node.n_local_vars)
node.n_equations
in
Some { node with n_local_vars = new_locvars; n_equations = new_equations }
in
node_pass node_lin
(** [pass_linearization_pre] makes sure that all pre constructs in the program
* are applied to variables.
* This is required, since the pre construct is translated into a variable in
* the final C code. *)
let pass_linearization_pre verbose debug =
(** [node_lin] linearizes a single node. *)
let node_lin (node: t_node): t_node option =
(** [pre_aux_expression] takes an expression and returns:
* - a list of additional equations
* - the new list of local variables
* - an updated version of the original expression *)
let rec pre_aux_expression vars expr: t_eqlist * t_varlist * t_expression =
match expr with
| EVar _ -> [], vars, expr
| EMonOp (t, op, e) ->
begin
match op, e with
| MOp_pre, EVar _ ->
let eqs, vars, e = pre_aux_expression vars e in
eqs, vars, EMonOp (t, op, e)
| MOp_pre, _ ->
let eqs, vars, e = pre_aux_expression vars e in
let nvar: string = fresh_var_name vars 6 in
let nvar = match t with
| [TInt] -> IVar nvar
| [TBool] -> BVar nvar
| [TReal] -> RVar nvar
| _ -> failwith "Should not happened." in
let neq_patt: t_varlist = (t, [nvar]) in
let neq_expr: t_expression = e in
let vars = varlist_concat (t, [nvar]) vars in
(neq_patt, neq_expr) :: eqs, vars, EMonOp (t, MOp_pre, EVar (t, nvar))
| _, _ ->
let eqs, vars, e = pre_aux_expression vars e in
eqs, vars, EMonOp (t, op, e)
end
| EBinOp (t, op, e, e') ->
let eqs, vars, e = pre_aux_expression vars e in
let eqs', vars, e' = pre_aux_expression vars e' in
eqs @ eqs', vars, EBinOp (t, op, e, e')
| ETriOp (t, op, e, e', e'') -> (** Do we always want a new var here? *)
let eqs, vars, e = pre_aux_expression vars e in
let nvar: string = fresh_var_name vars 6 in
let nvar: t_var = BVar nvar in
let neq_patt: t_varlist = ([TBool], [nvar]) in
let neq_expr: t_expression = e in
let vars = varlist_concat vars (neq_patt) in
let eqs', vars, e' = pre_aux_expression vars e' in
let eqs'', vars, e'' = pre_aux_expression vars e'' in
(neq_patt, neq_expr) :: eqs @ eqs' @ eqs'', vars, ETriOp (t, op, e, e', e'')
| EComp (t, op, e, e') ->
let eqs, vars, e = pre_aux_expression vars e in
let eqs', vars, e' = pre_aux_expression vars e' in
eqs @ eqs', vars, EComp (t, op, e, e')
| EWhen (t, e, e') ->
let eqs, vars, e = pre_aux_expression vars e in
let eqs', vars, e' = pre_aux_expression vars e' in
eqs @ eqs', vars, EWhen (t, e, e')
| EReset (t, e, e') ->
let eqs, vars, e = pre_aux_expression vars e in
let eqs', vars, e' = pre_aux_expression vars e' in
eqs @ eqs', vars, EReset (t, e, e')
| EConst _ -> [], vars, expr
| ETuple (t, l) ->
let eqs, vars, l = List.fold_right
(fun e (eqs, vars, l) ->
let eqs', vars, e = pre_aux_expression vars e in
eqs' @ eqs, vars, (e :: l))
l ([], vars, []) in
eqs, vars, ETuple (t, l)
| EApp (t, n, e) ->
let eqs, vars, e = pre_aux_expression vars e in
eqs, vars, EApp (t, n, e)
in
(** Applies the previous function to the expressions of every equation. *)
let new_equations, new_locvars =
List.fold_left
(fun (eqs, vars) (patt, expr) ->
let eqs', vars, expr = pre_aux_expression vars expr in
(patt, expr)::eqs' @ eqs, vars)
([], node.n_local_vars)
node.n_equations
in
Some { node with n_local_vars = new_locvars; n_equations = new_equations }
in
node_pass node_lin
(** [pass_linearization_tuples] transforms expressions of the form
* (x1, ..., xn) = (e1, ..., em);
* into:
* p1 = e1;
* ...
* pm = em;
* where flatten (p1, ..., pm) = x1, ..., xn
*
* Idem for tuples hidden behind merges and when:
* patt = (...) when c;
* patt = merge c (...) (...);
*)
let pass_linearization_tuples verbose debug ast =
(** [split_tuple] takes an equation and produces an equation list
* corresponding to the [pi = ei;] above. *)
let rec split_tuple (eq: t_equation): t_eqlist =
let patt, expr = eq in
match expr with
| ETuple (_, expr_h :: expr_t) ->
begin
let t_l = type_exp expr_h in
let patt_l, patt_r = list_select (List.length t_l) (snd patt) in
let t_r = List.flatten (List.map type_var patt_r) in
((t_l, patt_l), expr_h) ::
split_tuple ((t_r, patt_r), ETuple (t_r, expr_t))
end
| ETuple (_, []) -> []
| _ -> [eq]
in
(** For each node, apply the previous function to all equations.
* It builds fake equations in order to take care of tuples behind
* merge/when. *)
let aux_linearization_tuples node =
let new_equations = List.flatten
(List.map
(fun eq ->
match snd eq with
| ETuple _ -> split_tuple eq
| EWhen (t, ETuple (_, l), e') ->
List.map
(fun (patt, expr) -> (patt, EWhen (type_exp expr, expr, e')))
(split_tuple (fst eq, ETuple (t, l)))
| ETriOp (t, TOp_merge, c, ETuple (_, l), ETuple (_, l')) ->
begin
if List.length l <> List.length l'
|| List.length t <> List.length (snd (fst eq))
then raise (PassExn "Error while merging tuples.")
else
fst
(List.fold_left2
(fun (eqs, remaining_patt) el er ->
let patt, remaining_patt = split_patt remaining_patt el in
let t = type_exp el in
(patt, ETriOp (t, TOp_merge, c, el, er))
:: eqs, remaining_patt)
([], fst eq) l l')
end
| _ -> [eq])
node.n_equations) in
Some { node with n_equations = new_equations }
in
try node_pass aux_linearization_tuples ast with
| PassExn err -> (debug err; None)
(** [pass_linearization_app] makes sure that any argument to a function is
* either a variable, or of the form [pre _] (which will be translated as a
* variable in the final C code. *)
let pass_linearization_app verbose debug =
let applin_count = ref 0 in (* new variables are called «_applin[varcount]» *)
(** [aux_expr] recursively explores the AST in order to find applications, and
* adds the requires variables and equations. *)
let rec aux_expr vars expr: t_eqlist * t_varlist * t_expression =
match expr with
| EConst _ | EVar _ -> [], vars, expr
| EMonOp (t, op, expr) ->
let eqs, vars, expr = aux_expr vars expr in
eqs, vars, EMonOp (t, op, expr)
| EBinOp (t, op, e, e') ->
let eqs, vars, e = aux_expr vars e in
let eqs', vars, e' = aux_expr vars e' in
eqs @ eqs', vars, EBinOp (t, op, e, e')
| ETriOp (t, op, e, e', e'') ->
let eqs, vars, e = aux_expr vars e in
let eqs', vars, e' = aux_expr vars e' in
let eqs'', vars, e'' = aux_expr vars e'' in
eqs @ eqs' @ eqs'', vars, ETriOp (t, op, e, e', e'')
| EComp (t, op, e, e') ->
let eqs, vars, e = aux_expr vars e in
let eqs', vars, e' = aux_expr vars e' in
eqs @ eqs', vars, EComp (t, op, e, e')
| EWhen (t, e, e') ->
let eqs, vars, e = aux_expr vars e in
let eqs', vars, e' = aux_expr vars e' in
eqs @ eqs', vars, EWhen (t, e, e')
| EReset (t, e, e') ->
let eqs, vars, e = aux_expr vars e in
let eqs', vars, e' = aux_expr vars e' in
eqs @ eqs', vars, EReset (t, e, e')
| ETuple (t, l) ->
let eqs, vars, l =
List.fold_right
(fun e (eqs, vars, l) ->
let eqs', vars, e = aux_expr vars e in
eqs' @ eqs, vars, (e :: l))
l ([], vars, []) in
eqs, vars, ETuple (t, l)
| EApp (tout, n, ETuple (tin, l)) ->
let eqs, vars, l =
List.fold_right
(fun e (eqs, vars, l) ->
let eqs', vars, e = aux_expr vars e in
match e with
| EVar _ | EMonOp (_, MOp_pre, _) -> (** No need for a new var. *)
eqs' @ eqs, vars, (e :: l)
| _ -> (** Need for a new var. *)
let ty = match type_exp e with
| [ty] -> ty
| _ -> failwith "One should not provide
tuples as arguments to an auxiliary node."
in
let nvar: string = Format.sprintf "_applin%d" !applin_count in
incr applin_count;
let nvar: t_var =
match ty with
| TBool -> BVar nvar
| TInt -> IVar nvar
| TReal -> RVar nvar
in
let neq_patt: t_varlist = ([ty], [nvar]) in
let neq_expr: t_expression = e in
let vars = varlist_concat neq_patt vars in
(neq_patt, neq_expr)::eqs'@eqs, vars, EVar([ty], nvar) :: l)
l ([], vars, []) in
eqs, vars, EApp (tout, n, ETuple (tin, l))
| EApp _ -> failwith "Should not happened (parser)"
in
(** [aux_linearization_app] applies the previous function to every equation *)
let aux_linearization_app node =
let new_equations, new_locvars =
List.fold_left
(fun (eqs, vars) eq ->
let eqs', vars, expr = aux_expr vars (snd eq) in
(fst eq, expr) :: eqs' @ eqs, vars)
([], node.n_local_vars)
node.n_equations
in
Some { node with n_local_vars = new_locvars; n_equations = new_equations }
in
node_pass aux_linearization_app
let pass_ensure_assignment_value verbose debug =
let varcount = ref 0 in
let rec aux_expr should_be_value vars expr =
match expr with
| EConst _ | EVar _ -> [], vars, expr
| EMonOp (t, op, e) ->
let eqs, vars, e = aux_expr true vars e in
eqs, vars, EMonOp (t, op, e)
| EBinOp (t, op, e, e') ->
let eqs, vars, e = aux_expr true vars e in
let eqs', vars, e' = aux_expr true vars e' in
eqs @ eqs', vars, EBinOp (t, op, e, e')
| ETriOp (t, op, e, e', e'') ->
let eqs, vars, e = aux_expr should_be_value vars e in
let eqs', vars, e' = aux_expr should_be_value vars e' in
let eqs'', vars, e'' = aux_expr should_be_value vars e'' in
eqs @ eqs' @ eqs'', vars, ETriOp (t, op, e, e', e'')
| EComp (t, op, e, e') ->
let eqs, vars, e = aux_expr true vars e in
let eqs', vars, e' = aux_expr true vars e' in
eqs @ eqs', vars, EComp (t, op, e, e')
| EWhen (t, e, e') ->
let eqs, vars, e = aux_expr should_be_value vars e in
let eqs', vars, e' = aux_expr should_be_value vars e' in
eqs @ eqs', vars, EWhen (t, e, e')
| EReset (t, e, e') ->
let eqs, vars, e = aux_expr should_be_value vars e in
let eqs', vars, e' = aux_expr should_be_value vars e' in
eqs @ eqs', vars, EReset (t, e, e')
| ETuple (t, l) ->
let eqs, vars, l =
List.fold_right
(fun e (eqs, vars, l) ->
let eqs', vars, e = aux_expr true vars e in
eqs' @ eqs, vars, e :: l)
l ([], vars, []) in
eqs, vars, ETuple (t, l)
| EApp (t, n, e) ->
let eqs, vars, e = aux_expr true vars e in
if should_be_value
then
let nvar = Format.sprintf "_assignval%d" !varcount in
incr varcount;
let nvar: t_var =
match t with
| [TBool] -> BVar nvar
| [TReal] -> RVar nvar
| [TInt] -> IVar nvar
| _ ->
failwith "An application occurring here should return a single element."
in
let neq_patt: t_varlist = (t, [nvar]) in
let neq_expr: t_expression = EApp (t, n, e) in
let vars = varlist_concat neq_patt vars in
(neq_patt, neq_expr) :: eqs, vars, EVar (t, nvar)
else
eqs, vars, EApp (t, n, e)
in
let aux_ensure_assign_val node =
let new_equations, vars =
List.fold_left
(fun (eqs, vars) eq ->
let eqs', vars, expr = aux_expr false vars (snd eq) in
(fst eq, expr) :: eqs' @ eqs, vars
)
([], node.n_local_vars) node.n_equations
in
Some { node with n_equations = new_equations; n_local_vars = vars }
in
node_pass aux_ensure_assign_val
(** [sanity_pass_assignment_unicity] makes sure that there is at most one
* equation defining each variable (and that no equation tries to redefine an
* input).
*
* This is required, since the equations are not ordered in Lustre. *)
let sanity_pass_assignment_unicity verbose debug : t_nodelist -> t_nodelist option =
(** For each node, test the node. *)
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 happened."
| None -> raise (PassExn "should not happened.")
| Some num -> Hashtbl.replace h n (num + 1)
in
let incr_eq h (((_, patt), _): t_equation) =
@@ -137,9 +589,9 @@ let chkvar_init_unicity verbose debug main_fn : t_nodelist -> t_nodelist option
in
let add_var_in = add_var 1 in
let add_var_loc = add_var 0 in
List.iter add_var_in (snd node.n_inputs);
List.iter add_var_loc (snd node.n_outputs);
List.iter add_var_loc (snd node.n_local_vars);
List.iter add_var_in (snd node.n_inputs);
(** Usual Equations *)
incr_eqlist h node.n_equations;
if check_now h = false
@@ -171,27 +623,7 @@ let rec tpl debug ((pat, exp): t_equation) =
| ETuple (_, []) -> []
| _ -> [(pat, exp)]
let pass_linearization verbose debug main_fn =
let node_lin (node: t_node): t_node option =
let new_equations = List.flatten
begin
List.map
(tpl debug)
node.n_equations
end in
Some
{
n_name = node.n_name;
n_inputs = node.n_inputs;
n_outputs = node.n_outputs;
n_local_vars = node.n_local_vars;
n_equations = new_equations;
n_automata = node.n_automata;
}
in
node_pass node_lin
let pass_eq_reordering verbose debug main_fn ast =
let pass_eq_reordering verbose debug ast =
let rec pick_equations init_vars eqs remaining_equations =
match remaining_equations with
| [] -> Some eqs
@@ -225,7 +657,7 @@ let pass_eq_reordering verbose debug main_fn ast =
in
node_pass node_eq_reorganising ast
let pass_typing verbose debug main_fn ast =
let pass_typing verbose debug ast =
let htbl = Hashtbl.create (List.length ast) in
let () = debug "[typing verification]" in
let () = List.iter
@@ -295,7 +727,7 @@ let pass_typing verbose debug main_fn ast =
else None
in aux ast
let check_automata_validity verbos debug main_fn =
let check_automata_validity verbos debug =
let check_automaton_branch_vars automaton =
let (init, states) = automaton in
let left_side = Hashtbl.create 10 in
@@ -316,7 +748,7 @@ let check_automata_validity verbos debug main_fn =
match init with | State(name, eqs, cond, next) -> init_left_side eqs;
let validity = List.for_all (fun s -> (check_state s)) states in
if not validity then
failwith "Automaton branch has different variables assignment in different branches"
raise (PassExn "Automaton branch has different variables assignment in different branches")
end
in
let aux node =
@@ -392,8 +824,21 @@ let automaton_translation debug automaton =
)
in
let rec translate_var s v explist = match explist with
| [] -> EConst([TInt], CInt(0)) (* TODO *)
let default_constant ty =
let defaults ty = match ty with
| TInt -> EConst([ty], CInt(0))
| TBool -> EConst([ty], CBool(false))
| TReal -> EConst([ty], CReal(0.0))
in
match ty with
| [TInt] -> EConst(ty, CInt(0))
| [TBool] -> EConst(ty, CBool(false))
| [TReal] -> EConst(ty, CReal(0.0))
| _ -> ETuple(ty, List.map defaults ty)
in
let rec translate_var s v explist ty = match explist with
| [] -> default_constant ty
| (state, exp)::q ->
ETriOp(Utils.type_exp exp, TOp_if,
EComp([TBool], COp_eq,
@@ -401,7 +846,7 @@ let automaton_translation debug automaton =
EConst([TInt], CInt(Hashtbl.find state_to_int state))
),
exp,
translate_var s v q
translate_var s v q ty
)
in
@@ -414,7 +859,7 @@ let automaton_translation debug automaton =
init_state_translation states 1;
let exp_transition = EBinOp([TInt], BOp_arrow, EConst([TInt], CInt(1)), EMonOp([TInt], MOp_pre, transition_eq states s)) in
let new_equations = [(([TInt], [IVar(s)]), exp_transition)] in
Hashtbl.fold (fun var explist acc -> (var, translate_var s var explist)::acc) gathered new_equations, IVar(s)
Hashtbl.fold (fun var explist acc -> (var, translate_var s var explist (fst var))::acc) gathered new_equations, IVar(s)
let automata_trans_pass debug (node:t_node) : t_node option=
@@ -439,7 +884,109 @@ let automata_trans_pass debug (node:t_node) : t_node option=
n_automata = []; (* not needed anymore *)
}
let automata_translation_pass verbose debug main_fn =
let automata_translation_pass verbose debug =
node_pass (automata_trans_pass debug)
let clock_unification_pass verbose debug ast =
let failure str = raise (PassExn ("Failed to unify clocks: "^str)) in
let known_clocks = Hashtbl.create 100 in
let find_clock_var var =
match Hashtbl.find_opt known_clocks var with
| None ->
begin
match var with
| BVar(name)
| IVar(name)
| RVar(name) -> raise (PassExn ("Cannot find clock of variable "^name) )
end
| Some c -> c
in
let rec compute_clock_exp exp = match exp with
| EConst(_, _) -> [Base]
| EVar(_, var) -> find_clock_var var
| EMonOp(_, MOp_pre, _) -> [Base]
| EMonOp(_, _, e) -> compute_clock_exp e
| EComp(_, _, e1, e2)
| EReset(_, e1, e2)
| EBinOp(_, _, e1, e2) ->
begin
let c1 = compute_clock_exp e1
and c2 = compute_clock_exp e2 in
if c1 <> c2 then
failure "Binop"
else
c1
end
| EWhen(_, e1, e2) ->
begin
match compute_clock_exp e1 with
| [c1] -> [On (c1, e2)]
| _ -> failure "When"
end
| ETriOp(_, TOp_merge, e1, e2, e3) ->
begin
let c1 = compute_clock_exp e1
and c2 = compute_clock_exp e2
and c3 = compute_clock_exp e3 in
match c1, c2, c3 with
| [c1], [On(cl2, e2)], [On(cl3, e3)] ->
begin
if cl2 <> c1 || cl3 <> c1 then
failure "Triop clocks"
else match e2, e3 with
| EMonOp(_, MOp_not, e), _ when e = e3 -> [c1]
| _, EMonOp(_, MOp_not, e) when e = e2 -> [c1]
| _ -> failure "Triop condition"
end
| _ -> failure ("Merge format")
end
| ETriOp(_, TOp_if, e1, e2, e3) ->
let (* Unused: c1 = compute_clock_exp e1
and*) c2 = compute_clock_exp e2
and c3 = compute_clock_exp e3 in
if c2 <> c3 then
failure "If clocks"
else c2
| ETuple(_, explist) -> List.concat_map compute_clock_exp explist
| EApp(_, node, e) ->
let rec aux_app clk_list = match clk_list with
| [] -> raise (PassExn "Node called with no argument provided")
| [cl] -> cl
| t::q -> if t = (aux_app q) then t else failure "App diff clocks"
and mult_clk cl out_list = match out_list with
| [] -> []
| t::q -> cl::(mult_clk cl q)
in
mult_clk (aux_app (compute_clock_exp e)) (snd node.n_outputs)
in
let rec compute_eq_clock eq =
let rec step vars clks = match vars, clks with
| [], [] -> ()
| [], c::q -> raise (PassExn "Mismatch between clock size")
| v::t, c::q -> Hashtbl.replace known_clocks v [c]; step t q
| l, [] -> raise (PassExn "Mismatch between clock size")
in
let (_, vars), exp = eq in
let clk = compute_clock_exp exp in
step vars clk
in
let compute_clock_node n =
begin
Hashtbl.clear known_clocks;
List.iter (fun v -> Hashtbl.replace known_clocks v [Base]) (
snd n.n_inputs); (* Initializing inputs to base clock *)
List.iter compute_eq_clock n.n_equations;
if not (List.for_all (fun v -> (Hashtbl.find known_clocks v) = [Base]) (
snd n.n_outputs)) then failure "Outputs" (*Checking that the node's output are on base clock *)
else
Some n
end
in node_pass compute_clock_node ast

View File

@@ -1,92 +0,0 @@
open Ast
type sim_var =
| SIVar of ident * (int option)
| SBVar of ident * (bool option)
| SRVar of ident * (real option)
type sim_node_st =
{
node_outputs: sim_var list;
node_loc_vars: sim_var list;
node_inner_nodes: sim_node list;
}
and sim_node_step_fn =
sim_node_st -> sim_var list -> (sim_var list * sim_node_st)
and sim_node = sim_node_st * sim_node_step_fn
let pp_sim fmt ((sn, _): sim_node) =
let rec aux fmt vars =
match vars with
| [] -> ()
| SIVar (s, None) :: t ->
Format.fprintf fmt "\t<%s : int> uninitialized yet.\n%a" s aux t
| SBVar (s, None) :: t ->
Format.fprintf fmt "\t<%s : bool> uninitialized yet.\n%a" s aux t
| SRVar (s, None) :: t ->
Format.fprintf fmt "\t<%s : real> uninitialized yet.\n%a" s aux t
| SIVar (s, Some i) :: t ->
Format.fprintf fmt "\t<%s : int> = %d\n%a" s i aux t
| SBVar (s, Some b) :: t ->
Format.fprintf fmt "\t<%s : bool> = %s\n%a" s (Bool.to_string b) aux t
| SRVar (s, Some r) :: t ->
Format.fprintf fmt "\t<%s : real> = %f\n%a" s r aux t
in
if sn.node_loc_vars <> []
then
Format.fprintf fmt "State of the simulated node:\n\
\tOutput variables:\n%a
\tLocal variables:\n%a"
aux sn.node_outputs
aux sn.node_loc_vars
else
Format.fprintf fmt "State of the simulated node:\n\
\tOutput variables:\n%a
\tThere are no local variables:\n"
aux sn.node_outputs
exception MySimulationException of string
let fetch_node (p: t_nodelist) (s: ident) : t_node =
match List.filter (fun n -> n.n_name = s) p with
| [e] -> e
| _ -> raise (MySimulationException (Format.asprintf "Node %s undefined." s))
let fetch_var (l: sim_var list) (s: ident) =
match List.filter
(function
| SBVar (v, _) | SRVar (v, _) | SIVar (v, _) -> v = s) l with
| [v] -> v
| _ -> raise (MySimulationException
(Format.asprintf "Variable %s undefined." s))
(** TODO! *)
let make_sim (main_fn: ident) (p: t_nodelist): sim_node =
let main_n = fetch_node p main_fn in
let node_outputs =
List.map
(function
| IVar s -> SIVar (s, None)
| BVar s -> SBVar (s, None)
| RVar s -> SRVar (s, None))
(snd main_n.n_outputs) in
let node_loc_vars: sim_var list =
List.map
(function
| IVar s -> SIVar (s, None)
| BVar s -> SBVar (s, None)
| RVar s -> SRVar (s, None))
(snd main_n.n_local_vars) in
let node_inner_nodes = (* TODO! *) [] in
({node_outputs = node_outputs;
node_loc_vars = node_loc_vars;
node_inner_nodes = node_inner_nodes; },
(fun s l -> (s.node_outputs, s)))
let simulate main_fn ast =
let sim_ast = make_sim main_fn ast in
Format.printf "Initial state:\n%a" pp_sim sim_ast

View File

@@ -1,21 +1,18 @@
node diagonal_int (i: int) returns (o1, o2 : int);
node id_int (i: int) returns (o: int);
let
(o1, o2) = (i, i);
o = i -> i;
tel
node undiag_test (i: int) returns (o : bool);
var l1, l2: int; l3: int;
node aux (i, j: int) returns (o: int);
let
l3 = (pre (1)) -> 0;
(l1, l2) = diagonal_int(i);
o = (not (not (l1 = l2))) and (l1 = l2) and true;
o = id_int(i) + id_int(j);
tel
node auto (i: int) returns (o : int);
var x, y:int;
node main (i: int) returns (a, b: int);
var tmp: int;
let
automaton
| Incr -> do (o,x) = (0 fby o + 1, 2); done
| Decr -> do (o,x) = diagonal_int(0 fby o); done
a = 1;
b = aux (i, a);
tmp = aux (a+b, i);
tel

View File

@@ -1,7 +1,15 @@
node diagonal_int (i: int) returns (o1, o2 : int);
var y: int;
node aux (i: int) returns (a, b: int);
let
o2 = y;
y = i;
o1 = i;
a = 1 -> pre i;
b = 2 * i -> (3 * pre i);
tel
node n (i: int) returns (o1, o2: int);
var u1, u2, t1, t2: int; c: bool;
let
c = true -> not pre c;
(t1, t2) = aux (i) when c;
(u1, u2) = aux (i) when (not c);
o1 = merge c t1 u1;
o2 = merge c t2 u2;
tel

View File

@@ -9,6 +9,13 @@ let rec list_select n = function
let p1, p2 = list_select (n-1) t in
h :: p1, p2
let rec list_remove_duplicates l =
match l with
| [] -> []
| h :: t ->
let t = list_remove_duplicates t in
if List.mem h t then t else h :: t
let rec list_map_option (f: 'a -> 'b option) (l: 'a list) : 'b list option =
List.fold_right (fun elt acc ->
match acc, f elt with
@@ -97,3 +104,9 @@ let rec vars_of_expr (expr: t_expression) : ident list =
let rec varlist_concat (l1: t_varlist) (l2: t_varlist): t_varlist =
(fst l1 @ fst l2, snd l1 @ snd l2)
let split_patt (patt: t_varlist) (e: t_expression): t_varlist * t_varlist =
let pl, pr = list_select (List.length (type_exp e)) (snd patt) in
let tl = List.flatten (List.map type_var pl) in
let tr = List.flatten (List.map type_var pr) in
(tl, pl), (tr, pr)

21
tests/test.node Normal file
View File

@@ -0,0 +1,21 @@
node diagonal_int (i: int) returns (o1, o2 : int);
let
(o1, o2) = (i, i);
tel
node undiag_test (i: int) returns (o : bool);
var l1, l2: int; l3: int;
let
l3 = (pre (1)) -> 0;
(l1, l2) = diagonal_int(i);
o = (not (not (l1 = l2))) and (l1 = l2) and true;
tel
node auto (i: int) returns (o : int);
var x, y:int;
let
automaton
| Incr -> do (o,x) = (0 fby o + 1, 2); done
| Decr -> do (o,x) = diagonal_int(0 fby o); done
tel

11
tests/test2.node Normal file
View File

@@ -0,0 +1,11 @@
node diagonal_int (i: int) returns (o1, o2 : int);
let
(o1, o2) = (i, i);
tel
node main (i: int) returns (o1, o2, o3, o4: int);
let
(o1, o2) = diagonal_int(i);
(o3, o4) = diagonal_int(o1);
tel