Commit 8981cabd authored by pgaroche's avatar pgaroche
Browse files

Ongoing work

creation de la liste des scopes possibles, OK
association à un scope du chemen dans le programme qu'il represente, OK
affiche les valeurs successives, OK

TODO:
incrementer le temps
gerer les formats d'entree
parent c5cd46cf
struct real_to_int_mem {};
struct real_to_int_mem * real_to_int_alloc () {}
void real_to_int_reset (struct real_to_int_mem *self) {}
int real_to_int_step (double in1, int *out, struct real_to_int_mem *self) { *out = (int) in1; return *out;}
struct int_to_real_mem {};
struct int_to_real_mem * int_to_real_alloc () {}
void int_to_real_reset (struct int_to_real_mem *self) {}
double int_to_real_step (int in1, double *out, struct int_to_real_mem *self) { *out = (double)in1; return *out;}
struct real_to_int_mem {};
struct real_to_int_mem * real_to_int_alloc ();
void real_to_int_reset (struct real_to_int_mem *self) {}
int real_to_int_step (double in1, int *out, struct real_to_int_mem *self) { *out = (int) in1; return *out;}
struct int_to_real_mem {};
struct int_to_real_mem * int_to_real_alloc ();
void int_to_real_reset (struct int_to_real_mem *self) {}
double int_to_real_step (int in1, double *out, struct int_to_real_mem *self) { *out = (double)in1; return *out;}
#define real_to_int_DECLARE(inst)\
struct real_to_int_mem inst
#define real_to_int_LINK(inst)
#define real_to_int_ALLOC(inst)\
real_to_int_DECLARE(inst);\
real_to_int_LINK(inst);\
#define int_to_real_DECLARE(inst)\
struct int_to_real_mem inst
#define int_to_real_LINK(inst)
#define int_to_real_ALLOC(inst)\
int_to_real_DECLARE(inst);\
int_to_real_LINK(inst);\
#include <stdlib.h> /* Provides exit */
#include <stdio.h> /* Provides printf, scanf, sscanf */
#include <unistd.h> /* Provides isatty */
#include "io_frontend.h"
int ISATTY;
/* Standard Input procedures **************/
_Bool _get_bool(char* n){
......@@ -12,10 +10,8 @@ _Bool _get_bool(char* n){
int s = 1;
char c;
do {
if(ISATTY) {
if((s != 1)||(r == -1)) printf("\a");
printf("%s (1,t,T/0,f,F) ? ", n);
}
if((s != 1)||(r == -1)) printf("\a");
printf("%s (1,t,T/0,f,F) ? ", n);
if(scanf("%s", b)==EOF) exit(0);
s = sscanf(b, "%c", &c);
r = -1;
......@@ -29,10 +25,8 @@ int _get_int(char* n){
int r;
int s = 1;
do {
if(ISATTY) {
if(s != 1) printf("\a");
printf("%s (integer) ? ", n);
}
if(s != 1) printf("\a");
printf("%s (integer) ? ", n);
if(scanf("%s", b)==EOF) exit(0);
s = sscanf(b, "%d", &r);
} while(s != 1);
......@@ -43,28 +37,22 @@ double _get_double(char* n){
double r;
int s = 1;
do {
if(ISATTY) {
if(s != 1) printf("\a");
printf("%s (double) ? ", n);
}
if(scanf("%s", b)==EOF) exit(0);
if(s != 1) printf("\a");
printf("%s (double) ? ", n);
if(scanf("%s", b)==EOF) exit(0);
s = sscanf(b, "%lf", &r);
} while(s != 1);
return r;
}
/* Standard Output procedures **************/
void _put_bool(char* n, _Bool _V){
if(ISATTY) printf("%s = ", n);
printf("%i ", (_V)? 1 : 0);
if(ISATTY) printf("\n");
void _print_bool(char* n, int time, _Bool _V){
printf("%s %i %i\n", n, time, (_V)? 1 : 0);
}
void _put_int(char* n, int _V){
if(ISATTY) printf("%s = ", n);
printf("%d ", _V);
if(ISATTY) printf("\n");
void _print_int(char* n, int time, int _V){
printf("%s %i %d\n", n, time, _V);
}
void _put_double(char* n, double _V){
if(ISATTY) printf("%s = ", n);
printf("%f ", _V);
if(ISATTY) printf("\n");
void _print_double(char* n, int time, double _V){
printf("%s %i %f\n", n, time, _V);
}
......@@ -17,12 +17,12 @@ extern double _get_double(char* n);
/* Standard Output procedures **************/
/*@ assigns \nothing; */
extern void _put_bool(char* n, _Bool _V);
extern void _print_bool(char* n, int time, _Bool _V);
/*@ assigns \nothing; */
extern void _put_int(char* n, int _V);
extern void _print_int(char* n, int time, int _V);
/*@ assigns \nothing; */
extern void _put_double(char* n, double _V);
extern void _print_double(char* n, int time, double _V);
#endif
./bin/lustres -static -scopes "`./bin/lustres -show-possible-scopes -node top sandbox/NXTway/bidon_full.lus 2>/dev/null | grep ': ' | sed 's/:.*$/, /' | xargs | sed 's/,$//'`" -node top sandbox/NXTway/bidon_full.lus
......@@ -28,30 +28,10 @@ open Corelang
open Graph
open Machine_code
module IdentDepGraph = Graph.Persistent.Digraph.ConcreteBidirectional (Utils.IdentModule)
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
let compute_dep_machines machines =
let init = IdentDepGraph.empty in
let g = List.fold_left (fun g m ->
let g = IdentDepGraph.add_vertex g m.mname.node_id in
List.fold_left
(fun g' (_, instance) ->
if not (Basic_library.is_internal_fun instance) then
IdentDepGraph.add_edge g' instance m.mname.node_id
else
g') g m.minstances
) init machines in
fun f -> TopologicalDepGraph.iter
(fun machine_name ->
let machine =
try
List.find (fun m -> m.mname.node_id = machine_name) machines
with Not_found -> raise (Invalid_argument machine_name)
in
f machine
) g
(******************************************************************************)
(* Generic C printer functions *)
(******************************************************************************)
let pp_final_char_if_non_empty c l =
(fun fmt -> match l with [] -> () | _ -> fprintf fmt "%s" c)
......@@ -76,6 +56,7 @@ let pp_c_type fmt t =
| Types.Treal -> pp_print_string fmt "double"
| _ -> Types.print_ty fmt t
let pp_c_initialize fmt t =
match (Types.repr t).Types.tdesc with
| Types.Tint -> pp_print_string fmt "0"
......@@ -130,46 +111,46 @@ let pp_c_pre_var fmt m =
else
()
(******************************************************************************)
(* Compiler printer functions *)
(******************************************************************************)
let rec pp_machine_instr m fmt instr =
match instr with
| MReset i -> fprintf fmt "%a(self->%s);"
pp_machine_reset_name (List.assoc i m.minstances) i
| MLocalAssign (i,v) -> (
(* match m.mstep.step_outputs with *)
(* | [o] when o.var_id = i -> fprintf fmt "return %a;" (pp_c_val m) v *)
(* | _ -> *)
fprintf fmt "%a = %a;" (pp_c_lval m) i (pp_c_val m) v;
)
| MLocalAssign (i,v) -> fprintf fmt "%a = %a;" (pp_c_lval m) i (pp_c_val m) v;
| MStateAssign (i,v) ->
fprintf fmt "self->_reg.%s = %a;" i (pp_c_val m) v;
if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs then
fprintf fmt "@,%a = self->_reg.%s;" (pp_c_lval m) i i;
| MStep ([i0], i, vl) ->
let call fmt =
if Basic_library.is_internal_fun i then
Basic_library.pp_c i (pp_c_val m) fmt vl
else
fprintf fmt "%s_step (%a%t%a, self->%s)"
(* (Utils.fprintf_list ~sep:", " pp_print_string) il *)
(try List.assoc i m.minstances with Not_found -> failwith i)
(try List.assoc i m.minstances with Not_found -> failwith i)
(Utils.fprintf_list ~sep:", " (pp_c_val m)) vl
(pp_final_char_if_non_empty ", " vl)
(pp_c_add_val m) i0
i
in (
(* match m.mstep.step_outputs with *)
(* | [o] when o.var_id = i0 -> fprintf fmt "return %t;" call *)
(* | _ -> *)fprintf fmt "%a = %t;" (pp_c_lval m) i0 call
)
in
fprintf fmt "%a = %t;" (pp_c_lval m) i0 call
| MStep (il, i, vl) ->
fprintf fmt "%s_step (%a%t%a%tself->%s);"
(* (Utils.fprintf_list ~sep:", " pp_print_string) il *)
(try List.assoc i m.minstances with Not_found -> failwith i)
(Utils.fprintf_list ~sep:", " (pp_c_val m)) vl
(pp_final_char_if_non_empty ", " vl)
(Utils.fprintf_list ~sep:", " (pp_c_add_val m)) il
(pp_final_char_if_non_empty ", " il)
i
| MBranch (g,tl,el) ->
fprintf fmt "@[<v 2>if (%s) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
g
......@@ -178,7 +159,11 @@ let rec pp_machine_instr m fmt instr =
(pp_newline_if_non_empty el)
(Utils.fprintf_list ~sep:"@," (pp_machine_instr m)) el
let print_alloc_prototype fmt name =
| MComment s ->
fprintf fmt "//%s" s
(* Used when using malloc or to declare imported node *)
let pp_alloc_prototype fmt name =
fprintf fmt "%a * %a ()"
pp_machine_memtype_name name
pp_machine_alloc_name name
......@@ -233,7 +218,7 @@ let print_imported fmt decl =
(m.nodei_id, m.nodei_inputs, m.nodei_outputs)
else (
fprintf fmt "extern %a;@,"
print_alloc_prototype m.nodei_id;
pp_alloc_prototype m.nodei_id;
fprintf fmt "extern %a;@,"
print_reset_prototype m.nodei_id;
fprintf fmt "extern %a;@,"
......@@ -245,22 +230,20 @@ let print_imported fmt decl =
let pp_registers_struct fmt m =
if m.mmemory <> []
then
fprintf fmt "@[%a {@[%a; @]}@] _reg; "
fprintf fmt "@[%a {@[%a; @]}@] _reg;"
pp_machine_regtype_name m.mname.node_id
(Utils.fprintf_list ~sep:"; " pp_c_var) m.mmemory
else
()
let print_machine_struct fmt m =
let pp_machine_struct fmt m =
(* Define struct *)
fprintf fmt "@[%a {@[%a%a%t@]};@]@."
pp_machine_memtype_name m.mname.node_id
pp_registers_struct m
(Utils.fprintf_list ~sep:"; " pp_c_instance_var) m.minstances
(pp_final_char_if_non_empty "; " m.minstances)
(pp_final_char_if_non_empty "; " m.minstances)
let print_static_declare_instance fmt (i, m) =
fprintf fmt "%a(%s)" pp_machine_static_declare_name m i
fprintf fmt "%a(%s)" pp_machine_static_declare_name m i
let print_static_declare_macro fmt m =
if m.minstances = [] then
......@@ -315,7 +298,7 @@ let print_machine_decl fmt m =
else (
(* Dynamic allocation *)
fprintf fmt "extern %a;@.@."
print_alloc_prototype m.mname.node_id;
pp_alloc_prototype m.mname.node_id;
);
if m.mname.node_id = "_arrow" then (
(* Arrow will be defined by a #define macro because of polymorphism *)
......@@ -363,7 +346,7 @@ let print_machine fmt m =
if (not !Options.static_mem) then
(
fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
print_alloc_prototype m.mname.node_id
pp_alloc_prototype m.mname.node_id
print_alloc_code m;
);
if m.mname.node_id = "_arrow" then () else ( (* We don't print arrow function *)
......@@ -402,17 +385,18 @@ let print_get_input_flow fmt v =
v.var_id
let print_get_input_flow_fun fmt v =
fprintf fmt "@[<v 2>__input_%s_step (int *o) {@,o = 0;@]@,}@.@." v.var_id
fprintf fmt "@[<v 2>__input_%s_step (%a *o) {@,o = 0;@]@,}@.@." v.var_id pp_c_type v.var_type
let print_put_outputs fmt ol =
let po fmt o =
let print_put_output fmt o =
match o.var_type.Types.tdesc with
| Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id
| Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id
| Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id
| _ -> assert false
in
List.iter (fprintf fmt "@ %a;" po) ol
let print_put_outputs fmt ol =
List.iter (fprintf fmt "@ %a;" print_put_output) ol
let print_main_fun machines m fmt =
let mname = m.mname.node_id in
......@@ -473,11 +457,34 @@ let print_main_fun machines m fmt =
fprintf fmt "return 1;";
fprintf fmt "@]@ }@."
let print_main_header fmt =
fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@."
let print_main_simu_fun machines m fmt =
(* TODO: recuperer le type de "flow" et appeler le print correspondant
iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
par ex main_mem->n8->n9->_reg.flow
*)
let pp_scopes fmt (scopes:(Corelang.ident list *
((Corelang.ident * Corelang.node_desc) list * Corelang.var_decl))
list) =
let rec scope_path (path, flow) accu =
match path with
| [] -> accu ^ "_reg." ^ flow.var_id, flow.var_type
| (id, _)::tl -> scope_path (tl, flow) ( accu ^ id ^ "->" )
in
let scopes_vars = List.map (fun (sl, scope) -> String.concat "." sl, scope_path scope "main_mem.") scopes in
List.iter (fun (id, (var, typ)) ->
match typ.Types.tdesc with
| Types.Tint -> fprintf fmt "_print_int(\"%s\", 0, %s);@ " id var
| Types.Tbool -> fprintf fmt "_print_bool(\"%s\", 0, %s);@ " id var
| Types.Treal -> fprintf fmt "_print_double(\"%s\",0, %s);@ " id var
| _ -> assert false
) scopes_vars
let print_main_simu_fun machines m scopes fmt =
let mname = m.mname.node_id in
let main_mem = if !Options.static_mem then "&main_mem" else "main_mem" in
fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
......@@ -504,7 +511,7 @@ if cpt
fprintf fmt "@ /* Main memory allocation */@ ";
if (!Options.static_mem && !Options.main_node <> "")
then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname)
else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
else (fprintf fmt "%a *main_mem = %a(\"\");@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
fprintf fmt "@ /* Initialize the main memory */@ ";
fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
fprintf fmt "@ /* Infinite loop */@ ";
......@@ -543,14 +550,15 @@ if cpt
(* print_put_outputs m.mstep.step_outputs *)
)
);
fprintf fmt "@ ";
pp_scopes fmt scopes;
fprintf fmt "@]@ }@ ";
fprintf fmt "return 1;";
fprintf fmt "@]@ }@."
(* No external dependencies *)
let print_main_simu_header fmt =
fprintf fmt "#include <stdio.h>@.#include <unistd.h>@."
fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"basic_converters.h\"@.#include \"io_frontend.h\"@."
let generate_header header_fmt basename prog machines =
(* Generating H file *)
......@@ -569,7 +577,7 @@ let generate_header header_fmt basename prog machines =
(* Print the struct of all machines. This need to be done following the good
order. *)
fprintf header_fmt "/* Struct declarations */@.";
List.iter (print_machine_struct header_fmt) machines;
List.iter (pp_machine_struct header_fmt) machines;
pp_print_newline header_fmt ();
(* Print the prototypes of all machines *)
......@@ -609,8 +617,9 @@ let translate_to_c header_fmt source_fmt basename prog machines =
(* Print nodes one by one (in the previous order) *)
List.iter (print_machine source_fmt) machines;
main_print source_fmt
let simulate header_fmt source_fmt basename prog machines =
let simulate header_fmt source_fmt basename prog machines scopes =
(* Generating H files *)
generate_header header_fmt basename prog machines;
......@@ -638,9 +647,38 @@ let simulate header_fmt source_fmt basename prog machines =
) main_machine.mstep.step_inputs;
(* Generating main *)
print_main_simu_fun machines main_machine source_fmt
print_main_simu_fun machines main_machine scopes source_fmt
(* Not used for the moment
module IdentDepGraph = Graph.Persistent.Digraph.ConcreteBidirectional (Utils.IdentModule)
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
let compute_dep_machines machines =
let init = IdentDepGraph.empty in
let g = List.fold_left (fun g m ->
let g = IdentDepGraph.add_vertex g m.mname.node_id in
List.fold_left
(fun g' (_, instance) ->
if not (Basic_library.is_internal_fun instance) then
IdentDepGraph.add_edge g' instance m.mname.node_id
else
g') g m.minstances
) init machines in
fun f -> TopologicalDepGraph.iter
(fun machine_name ->
let machine =
try
List.find (fun m -> m.mname.node_id = machine_name) machines
with Not_found -> raise (Invalid_argument machine_name)
in
f machine
) g
*)
(* Local Variables: *)
......
......@@ -54,6 +54,7 @@ type instr_t =
| MReset of ident
| MStep of ident list * ident * value_t list
| MBranch of ident * instr_t list * instr_t list
| MComment of string
let rec pp_instr fmt i =
match i with
......@@ -68,7 +69,7 @@ let rec pp_instr fmt i =
g
(Utils.fprintf_list ~sep:"@ " pp_instr) tl
(Utils.fprintf_list ~sep:"@ " pp_instr) el
| MComment s -> Format.fprintf fmt "//%s" s
type step_t = {
step_inputs: var_decl list;
......@@ -163,7 +164,9 @@ let clock_carriers ck =
|
*)
let node_from_name id =
let node_from_name id = match (Hashtbl.find node_table id).top_decl_desc with Node id -> id | _ -> assert false
let node_id_from_name id =
try
match (Hashtbl.find node_table id).top_decl_desc with
| Node id -> id.node_id
......@@ -231,7 +234,7 @@ let rec translate_expr node ((m, si, j, d, s) as args) expr =
| Expr_whennot (e1, _) -> translate_expr node args e1
| Expr_merge (x, e1, e2) -> raise NormalizationError
| Expr_appl (id, e, _) ->
let id = node_from_name id in
let id = node_id_from_name id in
(match e.expr_desc with
| Expr_tuple el -> Fun (id, List.map (translate_expr node args) el)
| _ -> Fun (id, [translate_expr node args e]))
......@@ -290,7 +293,7 @@ let rec translate_eq node ((m, si, j, d, s) as args) eq =
in
(m,
(if is_stateless f then si else MReset o :: si),
(if is_stateless f then j else Utils.IMap.add o (node_from_name f) j),
(if is_stateless f then j else Utils.IMap.add o (node_id_from_name f) j),
d,
reset_instance o r eq.eq_rhs.expr_clock @
(control_on_clock eq.eq_rhs.expr_clock (MStep (p, o, vl))) :: s)
......@@ -350,9 +353,28 @@ let translate_decl nd =
let translate_prog decls =
let stateassign vdecl =
MStateAssign (vdecl.var_id, LocalVar vdecl.var_id)
in
let nodes = get_nodes decls in
let machine n =
let machine = translate_decl n in
let local_decls = machine.mstep.step_inputs
@ machine.mstep.step_outputs
@ machine.mstep.step_locals
in
{ machine with
mmemory = machine.mmemory @ local_decls;
mstep = {
machine.mstep with
step_instrs = machine.mstep.step_instrs
@ (MComment "Registering all flows")::(List.map stateassign local_decls)
}
}
in
(* What to do with Imported/Sensor/Actuators ? *)
arrow_machine :: List.map translate_decl nodes
arrow_machine :: List.map machine nodes
(* Local Variables: *)
......
......@@ -104,9 +104,6 @@ let rec simulate basename extension =
Scopes.print_scopes all_scopes;
exit 0;
);
(* Checking scopes *)
let scopes = !Options.scopes in
Scopes.check_scopes all_scopes scopes;
(* Normalization phase *)
report ~level:1 (fun fmt -> fprintf fmt ".. normalization@ @?");
......@@ -118,9 +115,12 @@ let rec simulate basename extension =
let machine_code = Machine_code.translate_prog normalized_prog in
report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@ "
(Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
machine_code);
(* Checking scopes *)
let scopes = !Options.scopes in
let scopes = Scopes.check_scopes !Options.main_node prog machine_code all_scopes scopes in
(* Printing to C on stdout *)
let basename = Filename.basename basename in
let header_file = basename ^ ".h" in (* Could be changed *)
......@@ -131,7 +131,7 @@ let rec simulate basename extension =
let source_out = open_out source_file in
let source_fmt = formatter_of_out_channel source_out in
report ~level:1 (fun fmt -> fprintf fmt ".. c code generation@ @?");
C_backend.simulate header_fmt source_fmt basename normalized_prog machine_code;
C_backend.simulate header_fmt source_fmt basename normalized_prog machine_code scopes;
report ~level:1 (fun fmt -> fprintf fmt "@]");
(* We stop the process here *)
......
......@@ -40,7 +40,7 @@ let scopes : string list list ref = ref []
let inputs = ref []
let register_scopes s =
let scope_list = Str.split (Str.regexp ",") s in
let scope_list = Str.split (Str.regexp ", *") s in
let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
scopes := scope_list
......
open Corelang
open Machine_code
let rec compute_scopes ?(is_first=true) prog main_node : Corelang.var_decl list list =
let node_opt = List.fold_left
let get_node name prog =
let node_opt = List.fold_left
(fun res top ->
match res, top.top_decl_desc with
| Some _, _ -> res
| None, Node nd -> if nd.node_id = main_node then Some nd else res
| None, Node nd -> if nd.node_id = name then Some nd else res
| _ -> None)
None prog
in
try
Utils.desome node_opt
with Utils.DeSome -> raise Not_found
let get_machine name machines =
try
List.find (fun m -> m.mname.node_id = name) machines
with Not_found -> raise Not_found
let rec compute_scopes ?(is_first=true) prog main_node : Corelang.var_decl list list =
try
let node = Utils.desome node_opt in
let node = get_node main_node prog in
let full_local_vars = node.node_inputs @ node.node_outputs @ node.node_locals in
let local_vars =if is_first then node.node_inputs @ node.node_outputs @ node.node_locals else node.node_locals in
let local_vars =if is_first then node.node_inputs @ node.node_outputs @ node.node_locals else node.node_inputs @node.node_locals in
let local_scopes =
List.map (fun x -> [x]) local_vars
in
......@@ -33,18 +44,9 @@ let rec compute_scopes ?(is_first=true) prog main_node : Corelang.var_decl list
) sub_nodes
in
local_scopes @ (List.flatten sub_scopes)
with Utils.DeSome -> []
with Not_found -> []
let check_scopes all_scopes scopes =
let all_scopes_as_strings = List.map (List.map (fun v -> v.var_id)) all_scopes in
List.iter
(fun sl ->
if not (List.mem sl all_scopes_as_strings) then (
Format.eprintf "%s is an invalid scope.@." (String.concat "." sl);
exit 1
)
) scopes
let print_scopes =