lustrec / src / basic_library.ml @ 0cbf0839
History  View  Annotate  Download (6.93 KB)
1 
(*  

2 
* SchedMCore  A MultiCore Scheduling Framework 
3 
* Copyright (C) 20092013, ONERA, Toulouse, FRANCE  LIFL, Lille, FRANCE 
4 
* Copyright (C) 20122013, INPT, Toulouse, FRANCE 
5 
* 
6 
* This file is part of Prelude 
7 
* 
8 
* Prelude is free software; you can redistribute it and/or 
9 
* modify it under the terms of the GNU Lesser General Public License 
10 
* as published by the Free Software Foundation ; either version 2 of 
11 
* the License, or (at your option) any later version. 
12 
* 
13 
* Prelude is distributed in the hope that it will be useful, but 
14 
* WITHOUT ANY WARRANTY ; without even the implied warranty of 
15 
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 
16 
* Lesser General Public License for more details. 
17 
* 
18 
* You should have received a copy of the GNU Lesser General Public 
19 
* License along with this program ; if not, write to the Free Software 
20 
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 021111307 
21 
* USA 
22 
* *) 
23  
24 
(* This module is used for the lustre to C compiler *) 
25  
26 
open LustreSpec 
27 
open Type_predef 
28 
open Clock_predef 
29 
open Delay_predef 
30 
open Dimension 
31  
32 
module TE = Env 
33  
34 
let static_op ty = 
35 
type_static (mkdim_var ()) ty 
36  
37 
let type_env = 
38 
let init_env = TE.initial in 
39 
let env' = TE.add_value init_env "+" (static_op type_bin_poly_op) in 
40 
let env' = TE.add_value env' "uminus" (static_op type_unary_poly_op) in 
41 
let env' = TE.add_value env' "" (static_op type_bin_poly_op) in 
42 
let env' = TE.add_value env' "*" (static_op type_bin_poly_op) in 
43 
let env' = TE.add_value env' "/" (static_op type_bin_poly_op) in 
44 
let env' = TE.add_value env' "mod" (static_op type_bin_int_op) in 
45 
let env' = TE.add_value env' "&&" (static_op type_bin_bool_op) in 
46 
let env' = TE.add_value env' "" (static_op type_bin_bool_op) in 
47 
let env' = TE.add_value env' "xor" (static_op type_bin_bool_op) in 
48 
let env' = TE.add_value env' "impl" (static_op type_bin_bool_op) in 
49 
let env' = TE.add_value env' "<" (static_op type_bin_comp_op) in 
50 
let env' = TE.add_value env' "<=" (static_op type_bin_comp_op) in 
51 
let env' = TE.add_value env' ">" (static_op type_bin_comp_op) in 
52 
let env' = TE.add_value env' ">=" (static_op type_bin_comp_op) in 
53 
let env' = TE.add_value env' "!=" (static_op type_bin_comp_op) in 
54 
let env' = TE.add_value env' "=" (static_op type_bin_comp_op) in 
55 
let env' = TE.add_value env' "not" (static_op type_unary_bool_op) in 
56 
env' 
57  
58 
module CE = Env 
59  
60 
let clock_env = 
61 
let init_env = CE.initial in 
62 
let env' = 
63 
List.fold_right (fun op env > CE.add_value env op ck_unary_univ) 
64 
["uminus"; "not"] init_env in 
65 
let env' = 
66 
List.fold_right (fun op env > CE.add_value env op ck_bin_univ) 
67 
["+"; ""; "*"; "/"; "mod"; "&&"; ""; "xor"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in 
68 
env' 
69  
70 
module DE = Env 
71  
72 
let delay_env = 
73 
let init_env = DE.initial in 
74 
let env' = 
75 
List.fold_right (fun op env > DE.add_value env op delay_unary_poly_op) 
76 
["uminus"; "not"] init_env in 
77 
let env' = 
78 
List.fold_right (fun op env > DE.add_value env op delay_binary_poly_op) 
79 
["+"; ""; "*"; "/"; "mod"; "&&"; ""; "xor"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in 
80 
let env' = 
81 
List.fold_right (fun op env > DE.add_value env op delay_ternary_poly_op) 
82 
[] env' in 
83 
env' 
84  
85 
module VE = Env 
86  
87 
let eval_env = 
88 
let init_env = VE.initial in 
89 
let env' = VE.add_value init_env "uminus" (fun [Dint a] > Dint (a)) in 
90 
let env' = VE.add_value env' "not" (fun [Dbool b] > Dbool (not b)) in 
91 
let env' = VE.add_value env' "+" (fun [Dint a; Dint b] > Dint (a+b)) in 
92 
let env' = VE.add_value env' "" (fun [Dint a; Dint b] > Dint (ab)) in 
93 
let env' = VE.add_value env' "*" (fun [Dint a; Dint b] > Dint (a*b)) in 
94 
let env' = VE.add_value env' "/" (fun [Dint a; Dint b] > Dint (a/b)) in 
95 
let env' = VE.add_value env' "mod" (fun [Dint a; Dint b] > Dint (a mod b)) in 
96 
let env' = VE.add_value env' "&&" (fun [Dbool a; Dbool b] > Dbool (a&&b)) in 
97 
let env' = VE.add_value env' "" (fun [Dbool a; Dbool b] > Dbool (ab)) in 
98 
let env' = VE.add_value env' "xor" (fun [Dbool a; Dbool b] > Dbool (a<>b)) in 
99 
let env' = VE.add_value env' "impl" (fun [Dbool a; Dbool b] > Dbool (a<=b)) in 
100 
let env' = VE.add_value env' "<" (fun [Dint a; Dint b] > Dbool (a<b)) in 
101 
let env' = VE.add_value env' ">" (fun [Dint a; Dint b] > Dbool (a>b)) in 
102 
let env' = VE.add_value env' "<=" (fun [Dint a; Dint b] > Dbool (a<=b)) in 
103 
let env' = VE.add_value env' ">=" (fun [Dint a; Dint b] > Dbool (a>=b)) in 
104 
let env' = VE.add_value env' "!=" (fun [a; b] > Dbool (a<>b)) in 
105 
let env' = VE.add_value env' "=" (fun [a; b] > Dbool (a=b)) in 
106 
env' 
107  
108 
let internal_funs = ["+";"";"*";"/";"mod";"&&";"";"xor";"impl";"<";">";"<=";">=";"!=";"=";"uminus";"not"] 
109  
110 
let is_internal_fun x = 
111 
List.mem x internal_funs 
112  
113 
(* 
114 
let imported_node name inputs outputs sl spec = 
115 
mktop_decl Location.dummy_loc 
116 
( 
117 
ImportedNode 
118 
{nodei_id = name; 
119 
nodei_type = Types.new_var (); 
120 
nodei_clock = Clocks.new_var true; 
121 
nodei_inputs = inputs; 
122 
nodei_outputs = outputs; 
123 
nodei_stateless = sl; 
124 
nodei_spec = spec}) 
125 

126 
let mk_new_var id = 
127 
let loc = Location.dummy_loc in 
128 
mkvar_decl loc (id, mktyp loc Tydec_any, mkclock loc Ckdec_any, false) 
129  
130 
let _ = 
131 
let binary_fun id = id, [mk_new_var "x"; mk_new_var "y"], [mk_new_var "z"] in 
132 
let unary_fun id = id, [mk_new_var "x"], [mk_new_var "y"] in 
133 
(* All following functions are stateless *) 
134 
let st = true in 
135 
List.iter (fun (n,i,o) > Hashtbl.add node_table n (imported_node n i o st None)) 
136 
( 
137 
(*("ite", [mk_new_var "g"; mk_new_var "x"; mk_new_var "y"], [mk_new_var "z"])::*) 
138 
(List.map binary_fun 
139 
["+";"";"*";"/";"mod";"&&";"";"xor";"impl";"<";">";"<=";">=";"!=";"="]) 
140 
@(List.map unary_fun ["uminus";"not"])) 
141 
*) 
142 
let pp_c i pp_val fmt vl = 
143 
match i, vl with 
144 
(*  "ite", [v1; v2; v3] > Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) 
145 
 "uminus", [v] > Format.fprintf fmt "( %a)" pp_val v 
146 
 "not", [v] > Format.fprintf fmt "(!%a)" pp_val v 
147 
 "impl", [v1; v2] > Format.fprintf fmt "(!%a  %a)" pp_val v1 pp_val v2 
148 
 "=", [v1; v2] > Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 
149 
 "mod", [v1; v2] > Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 
150 
 _, [v1; v2] > Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 
151 
 _ > assert false 
152  
153 
let pp_java i pp_val fmt vl = 
154 
match i, vl with 
155 
(*  "ite", [v1; v2; v3] > Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) 
156 
 "uminus", [v] > Format.fprintf fmt "( %a)" pp_val v 
157 
 "not", [v] > Format.fprintf fmt "(!%a)" pp_val v 
158 
 "impl", [v1; v2] > Format.fprintf fmt "(!%a  %a)" pp_val v1 pp_val v2 
159 
 "=", [v1; v2] > Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 
160 
 _, [v1; v2] > Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 
161 
 _ > assert false 
162  
163  
164 
(* Local Variables: *) 
165 
(* compilecommand:"make C .." *) 
166 
(* End: *) 