Project

General

Profile

Revision 52016bbb

View differences:

include/arrow.h
17 17
  _arrow_DECLARE(attr, inst);\
18 18
  _arrow_LINK(inst)
19 19

  
20
#define _arrow_init(self) {}
21

  
22
#define _arrow_clear(self) {}
23

  
20 24
#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))
21 25

  
22 26
#define _arrow_reset(self) {(self)->_reg._first = 1;}
include/mpfr_lustre.c
1
#include <mpfr.h>
2
#include "mpfr_lustre.h"
3

  
4
const int MPFR_PREC = 15;
5

  
6
void MPFRNeq_step (mpfr_t i1, mpfr_t i2, 
7
                          _Bool (*out)
8
                          )
9
{
10
  *out = mpfr_lessgreater_p(i1, i2);
11
}
12

  
13
void MPFREq_step (mpfr_t i1, mpfr_t i2, 
14
                         _Bool (*out)
15
                         )
16
{
17
  *out = mpfr_equal_p(i1, i2);
18
}
19

  
20
void MPFRGt_step (mpfr_t i1, mpfr_t i2, 
21
                         _Bool (*out)
22
                         )
23
{
24
  *out = mpfr_greater_p(i1, i2);
25
}
26

  
27
void MPFRGe_step (mpfr_t i1, mpfr_t i2, 
28
                         _Bool (*out)
29
                         )
30
{
31
  *out = mpfr_greaterequal_p(i1, i2);
32
}
33

  
34
extern void MPFRLt_step (mpfr_t i1, mpfr_t i2, 
35
                         _Bool (*out)
36
                         )
37
{
38
  *out = mpfr_less_p(i1, i2);
39
}
40
void MPFRLe_step (mpfr_t i1, mpfr_t i2, 
41
                         _Bool (*out)
42
                         )
43
{
44
  *out = mpfr_lessequal_p(i1, i2);
45
}
46

  
47
void MPFRDiv_step (mpfr_t i1, mpfr_t i2, 
48
                          mpfr_t out
49
                          )
50
{
51
  mpfr_div(out, i1, i2, MPFR_RNDN);
52
}
53

  
54
void MPFRTimes_step (mpfr_t i1, mpfr_t i2, 
55
                            mpfr_t out
56
                            )
57
{
58
  mpfr_mul(out, i1, i2, MPFR_RNDN);
59
}
60

  
61
void MPFRMinus_step (mpfr_t i1, mpfr_t i2, 
62
                            mpfr_t out
63
                            )
64
{
65
  mpfr_sub(out, i1, i2, MPFR_RNDN);
66
}
67

  
68
void MPFRPlus_step (mpfr_t i1, mpfr_t i2, 
69
                           mpfr_t out
70
                           )
71
{
72
  mpfr_add(out, i1, i2, MPFR_RNDN);
73
}
74

  
75
void MPFRUminus_step (mpfr_t i, 
76
                             mpfr_t out
77
                             )
78
{
79
  mpfr_neg(out, i, MPFR_RNDN);
80
}
81

  
82
void MPFRInit(mpfr_t i, mpfr_prec_t prec)
83
{
84
  mpfr_init2(i, prec);
85
}
86

  
87
void MPFRClear(mpfr_t i)
88
{
89
  mpfr_clear(i);
90
}
include/mpfr_lustre.lusi
1

  
2

  
3
function MPFRUminus(i: real) returns (out: real) lib gmp lib mpfr;
4

  
5
function MPFRPlus(i1, i2: real) returns (out: real);
6

  
7
function MPFRMinus(i1, i2: real) returns (out: real);
8

  
9
function MPFRTimes(i1, i2: real) returns (out: real);
10

  
11
function MPFRDiv(i1, i2: real) returns (out: real);
12

  
13
function MPFRLe(i1, i2: real) returns (out: bool);
14

  
15
function MPFRLt(i1, i2: real) returns (out: bool);
16

  
17
function MPFRGe(i1, i2: real) returns (out: bool);
18

  
19
function MPFRGt(i1, i2: real) returns (out: bool);
20

  
21
function MPFREq(i1, i2: real) returns (out: bool);
22

  
23
function MPFRNeq(i1, i2: real) returns (out: bool);
src/mpfr.ml
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

  
12
open Utils
13
open LustreSpec
14
open Corelang
15
open Normalization
16
open Machine_code
17

  
18
let mpfr_module = mktop (Open(false, "mpfr_lustre"))
19

  
20
let mpfr_rnd () = "MPFR_RNDN"
21

  
22
let mpfr_prec () = !Options.mpfr_prec
23

  
24
let inject_id = "MPFRId"
25

  
26
let inject_copy_id = "mpfr_set"
27

  
28
let inject_real_id = "mpfr_set_flt"
29

  
30
let inject_init_id = "mpfr_init2"
31

  
32
let inject_clear_id = "mpfr_clear"
33

  
34
let mpfr_t = "mpfr_t"
35

  
36
let unfoldable_value value =
37
  not (Types.is_real_type value.value_type && is_const_value value)
38

  
39
let inject_id_id expr =
40
  let e = mkpredef_call expr.expr_loc inject_id [expr] in
41
  { e with
42
    expr_type = Type_predef.type_real;
43
    expr_clock = expr.expr_clock;
44
  }
45

  
46
let pp_inject_real pp_var fmt var value =
47
  Format.fprintf fmt "%s(%a, %a, %s);"
48
    inject_real_id
49
    pp_var var
50
    pp_var value
51
    (mpfr_rnd ())
52

  
53
let inject_assign expr =
54
  let e = mkpredef_call expr.expr_loc inject_copy_id [expr] in
55
  { e with
56
    expr_type = Type_predef.type_real;
57
    expr_clock = expr.expr_clock;
58
  }
59

  
60
let pp_inject_copy pp_var fmt var value =
61
  Format.fprintf fmt "%s(%a, %a, %s);"
62
    inject_copy_id
63
    pp_var var
64
    pp_var value
65
    (mpfr_rnd ())
66

  
67
let rec pp_inject_assign pp_var fmt var value =
68
  if is_const_value value
69
  then
70
    pp_inject_real pp_var fmt var value
71
  else
72
    pp_inject_copy pp_var fmt var value
73

  
74
let pp_inject_init pp_var fmt var =
75
  Format.fprintf fmt "%s(%a, %i);"
76
    inject_init_id
77
    pp_var var
78
    (mpfr_prec ())
79

  
80
let pp_inject_clear pp_var fmt var =
81
  Format.fprintf fmt "%s(%a);"
82
    inject_clear_id
83
    pp_var var
84

  
85
let base_inject_op id =
86
  match id with
87
  | "+"      -> "MPFRPlus"
88
  | "-"      -> "MPFRMinus"
89
  | "*"      -> "MPFRTimes"
90
  | "/"      -> "MPFRDiv"
91
  | "uminus" -> "MPFRUminus"
92
  | "<="     -> "MPFRLe"
93
  | "<"      -> "MPFRLt"
94
  | ">="     -> "MPFRGe"
95
  | ">"      -> "MPFRGt"
96
  | "="      -> "MPFREq"
97
  | "!="     -> "MPFRNeq"
98
  | _        -> raise Not_found
99

  
100
let inject_op id =
101
  try
102
    base_inject_op id
103
  with Not_found -> id
104

  
105
let homomorphic_funs =
106
  List.fold_right (fun id res -> try base_inject_op id :: res with Not_found -> res) Basic_library.internal_funs []
107

  
108
let is_homomorphic_fun id =
109
  List.mem id homomorphic_funs
110

  
111
let inject_call expr =
112
  match expr.expr_desc with
113
  | Expr_appl (id, args, None) when not (Basic_library.is_expr_internal_fun expr) ->
114
    { expr with expr_desc = Expr_appl (inject_op id, args, None) }
115
  | _ -> expr
116

  
117
let expr_of_const_array expr =
118
  match expr.expr_desc with
119
  | Expr_const (Const_array cl) ->
120
    let typ = Types.array_element_type expr.expr_type in
121
    let expr_of_const c =
122
      { expr_desc = Expr_const c;
123
	expr_type = typ;
124
	expr_clock = expr.expr_clock;
125
	expr_loc = expr.expr_loc;
126
	expr_delay = Delay.new_var ();
127
	expr_annot = None;
128
	expr_tag = new_tag ();
129
      }
130
    in { expr with expr_desc = Expr_array (List.map expr_of_const cl) }
131
  | _                           -> assert false
132

  
133
(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
134
let rec inject_list alias node inject_element defvars elist =
135
  List.fold_right
136
    (fun t (defvars, qlist) ->
137
      let defvars, norm_t = inject_element alias node defvars t in
138
      (defvars, norm_t :: qlist)
139
    ) elist (defvars, [])
140

  
141
let rec inject_expr ?(alias=true) node defvars expr =
142
let res=
143
  match expr.expr_desc with
144
  | Expr_const (Const_real _)  -> mk_expr_alias_opt alias node defvars expr
145
  | Expr_const (Const_array _) -> inject_expr ~alias:alias node defvars (expr_of_const_array expr)
146
  | Expr_const (Const_struct _) -> assert false
147
  | Expr_ident _
148
  | Expr_const _  -> defvars, expr
149
  | Expr_array elist ->
150
    let defvars, norm_elist = inject_list alias node (fun _ -> inject_expr ~alias:true) defvars elist in
151
    let norm_expr = { expr with expr_desc = Expr_array norm_elist } in
152
    defvars, norm_expr
153
  | Expr_power (e1, d) ->
154
    let defvars, norm_e1 = inject_expr node defvars e1 in
155
    let norm_expr = { expr with expr_desc = Expr_power (norm_e1, d) } in
156
    defvars, norm_expr
157
  | Expr_access (e1, d) ->
158
    let defvars, norm_e1 = inject_expr node defvars e1 in
159
    let norm_expr = { expr with expr_desc = Expr_access (norm_e1, d) } in
160
    defvars, norm_expr
161
  | Expr_tuple elist -> 
162
    let defvars, norm_elist =
163
      inject_list alias node (fun alias -> inject_expr ~alias:alias) defvars elist in
164
    let norm_expr = { expr with expr_desc = Expr_tuple norm_elist } in
165
    defvars, norm_expr
166
  | Expr_appl (id, args, r) ->
167
    let defvars, norm_args = inject_expr node defvars args in
168
    let norm_expr = { expr with expr_desc = Expr_appl (id, norm_args, r) } in
169
    mk_expr_alias_opt alias node defvars (inject_call norm_expr)
170
  | Expr_arrow _ -> defvars, expr
171
  | Expr_pre e ->
172
    let defvars, norm_e = inject_expr node defvars e in
173
    let norm_expr = { expr with expr_desc = Expr_pre norm_e } in
174
    defvars, norm_expr
175
  | Expr_fby (e1, e2) ->
176
    let defvars, norm_e1 = inject_expr node defvars e1 in
177
    let defvars, norm_e2 = inject_expr node defvars e2 in
178
    let norm_expr = { expr with expr_desc = Expr_fby (norm_e1, norm_e2) } in
179
    defvars, norm_expr
180
  | Expr_when (e, c, l) ->
181
    let defvars, norm_e = inject_expr node defvars e in
182
    let norm_expr = { expr with expr_desc = Expr_when (norm_e, c, l) } in
183
    defvars, norm_expr
184
  | Expr_ite (c, t, e) ->
185
    let defvars, norm_c = inject_expr node defvars c in
186
    let defvars, norm_t = inject_expr node defvars t in
187
    let defvars, norm_e = inject_expr node defvars e in
188
    let norm_expr = { expr with expr_desc = Expr_ite (norm_c, norm_t, norm_e) } in
189
    defvars, norm_expr
190
  | Expr_merge (c, hl) ->
191
    let defvars, norm_hl = inject_branches node defvars hl in
192
    let norm_expr = { expr with expr_desc = Expr_merge (c, norm_hl) } in
193
    defvars, norm_expr
194
in
195
(*Format.eprintf "inject_expr %B %a = %a@." alias Printers.pp_expr expr Printers.pp_expr (snd res);*)
196
res
197

  
198
and inject_branches node defvars hl =
199
 List.fold_right
200
   (fun (t, h) (defvars, norm_q) ->
201
     let (defvars, norm_h) = inject_expr node defvars h in
202
     defvars, (t, norm_h) :: norm_q
203
   )
204
   hl (defvars, [])
205

  
206

  
207
let rec inject_eq node defvars eq =
208
  let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in
209
  let norm_eq = { eq with eq_rhs = norm_rhs } in
210
  norm_eq::defs', vars'
211

  
212
(** normalize_node node returns a normalized node, 
213
    ie. 
214
    - updated locals
215
    - new equations
216
    - 
217
*)
218
let inject_node node = 
219
  cpt_fresh := 0;
220
  let inputs_outputs = node.node_inputs@node.node_outputs in
221
  let is_local v =
222
    List.for_all ((!=) v) inputs_outputs in
223
  let orig_vars = inputs_outputs@node.node_locals in
224
  let defs, vars = 
225
    List.fold_left (inject_eq node) ([], orig_vars) (get_node_eqs node) in
226
  (* Normalize the asserts *)
227
  let vars, assert_defs, asserts = 
228
    List.fold_left (
229
    fun (vars, def_accu, assert_accu) assert_ ->
230
      let assert_expr = assert_.assert_expr in
231
      let (defs, vars'), expr = 
232
	inject_expr 
233
	  ~alias:false 
234
	  node 
235
	  ([], vars) (* defvar only contains vars *)
236
	  assert_expr
237
      in
238
      vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
239
    ) (vars, [], []) node.node_asserts in
240
  let new_locals = List.filter is_local vars in
241
  (* Compute traceability info: 
242
     - gather newly bound variables
243
     - compute the associated expression without aliases     
244
  *)
245
  (* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals)) new_locals in *)
246
  let node =
247
  { node with 
248
    node_locals = new_locals; 
249
    node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
250
  }
251
  in ((*Printers.pp_node Format.err_formatter node;*) node)
252

  
253
let inject_decl decl =
254
  match decl.top_decl_desc with
255
  | Node nd ->
256
    {decl with top_decl_desc = Node (inject_node nd)}
257
  | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl
258
  
259
let inject_prog decls = 
260
  List.map inject_decl decls
261

  
262

  
263
(* Local Variables: *)
264
(* compile-command:"make -C .." *)
265
(* End: *)

Also available in: Unified diff