Compare commits

...

88 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
Antoine Grimod
6af9ddf394 added pass to check validity of automata and disable flattening of automaton branch because of incorrect code resulting from it 2022-12-16 01:04:09 +01:00
Antoine Grimod
1b3af051b3 adding automaton translation pass to list of executed passes 2022-12-16 00:06:51 +01:00
22 changed files with 2036 additions and 544 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"; "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,17 +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);
("linearization", Passes.pass_linearization);
("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);
("equations_ordering", Passes.pass_eq_reordering);
("check_typing", Passes.pass_typing);
("clock_unification", Passes.clock_unification_pass);
];
(** Main functionality below *)
@@ -90,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 ->
@@ -98,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,
@@ -118,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,28 +727,35 @@ let pass_typing verbose debug main_fn ast =
else None
in aux ast
let check_automaton_branch_vars automaton =
let (init, states) = automaton in
let left_side = Hashtbl.create 10 in
let check_automata_validity verbos debug =
let check_automaton_branch_vars automaton =
let (init, states) = automaton in
let left_side = Hashtbl.create 10 in
let rec init_left_side eqlist = match eqlist with
| [] -> ()
| (varlist, exp)::q ->
begin
Hashtbl.add left_side varlist true;
init_left_side q;
end
let rec init_left_side eqlist = match eqlist with
| [] -> ()
| (varlist, exp)::q ->
begin
Hashtbl.add left_side varlist true;
init_left_side q;
end
in
let check_state s = match s with
| State(name, eqs, cond, next) ->
List.for_all (fun (varlist, exp) -> (Hashtbl.mem left_side varlist)) eqs
in
begin
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
raise (PassExn "Automaton branch has different variables assignment in different branches")
end
in
let check_state s = match s with
| State(name, eqs, cond, next) ->
List.for_all (fun (varlist, exp) -> (Hashtbl.mem left_side varlist)) eqs
let aux node =
List.iter check_automaton_branch_vars node.n_automata;
Some node
in
begin
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"
end
node_pass aux
let automaton_translation debug automaton =
let gathered = Hashtbl.create 10 in
@@ -331,7 +770,7 @@ let automaton_translation debug automaton =
let rec init_state_translation states c = match states with
| [] -> ()
| State(name, _, _, _)::q ->
Hashtbl.replace state_to_int name c; (init_state_translation q c)
Hashtbl.replace state_to_int name c; (init_state_translation q (c+1))
in
let rec find_state name =
@@ -350,14 +789,20 @@ let automaton_translation debug automaton =
let flatten_state state = match state with
| State(name, eq, cond, next) ->
(* Flattening is not possible
for example a branch where x,y = 1, 2 will be unpacked
when in another branch x, y = f(z) will not be unpacked
*)
(*
let new_equations = List.flatten
begin
List.map
(tpl debug)
eq
end in
equation_pass name new_equations;
State(name, new_equations, cond, next)
*)
equation_pass name eq;
State(name, eq, cond, next)
in
let rec transition_eq states s =
@@ -379,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,
@@ -388,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
@@ -399,9 +857,9 @@ let automaton_translation debug automaton =
let (init, states) = flatten_automaton automaton in
let s = create_automaton_name () in
init_state_translation states 1;
let exp_transition = transition_eq states s in
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=
@@ -423,6 +881,112 @@ let automata_trans_pass debug (node:t_node) : t_node option=
n_outputs = node.n_outputs;
n_local_vars = (new_ty@ty, vars@loc_vars);
n_equations = eqs@node.n_equations;
n_automata = node.n_automata;
n_automata = []; (* not needed anymore *)
}
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);
var i: 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);
node main (i: int) returns (a, b: int);
var tmp: int;
let
automaton
| Incr -> do o = (pre o) + 1; done
| Decr -> do o = (pre o) - 1; 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