lustrec / src / basic_library.ml @ 17abbe95
History | View | Annotate | Download (6.93 KB)
1 |
(* ---------------------------------------------------------------------------- |
---|---|
2 |
* SchedMCore - A MultiCore Scheduling Framework |
3 |
* Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE |
4 |
* Copyright (C) 2012-2013, 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 02111-1307 |
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 (a-b)) 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 (a||b)) 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 |
(* compile-command:"make -C .." *) |
166 |
(* End: *) |