Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/checks/algebraicLoop.ml
1
(* We try to solve all algebraic loops (AL) from prog:
2
each node is mapped to its own cycles
3
each cycle is tentatively solved by inlining one of its component
1
(* We try to solve all algebraic loops (AL) from prog: each node is mapped to
2
   its own cycles each cycle is tentatively solved by inlining one of its
3
   component
4 4

  
5
When done, a report is generated.
5
   When done, a report is generated.
6 6

  
7
- for each initial AL, the cycle is presented
8
   - either it is solvable and we provide the set of inlines that solves it
9
   - or it is not and we write the AL as unsolvable by inlining
7
   - for each initial AL, the cycle is presented - either it is solvable and we
8
   provide the set of inlines that solves it - or it is not and we write the AL
9
   as unsolvable by inlining
10 10

  
11 11
   If the option solve_al is activated, the resulting partially inlined prog is
12
   propagated fur future processing Otherwise the compilation stops
13
*)
12
   propagated fur future processing Otherwise the compilation stops *)
14 13
open Lustre_types
15 14
open Corelang
16 15
open Utils
17 16

  
18 17
(* An single algebraic loop is defined (partition, node calls, inlined, status)
19
   ie 
18
   ie
20 19

  
21 20
   1. the list of variables in the loop, ident list
22
   
21

  
23 22
   2.the possible functions identifier to inline, and whether they have been
24
   inlined yet (ident * tag * bool) list and 
23
   inlined yet (ident * tag * bool) list and
24

  
25
   3. a status whether the inlining is enough bool *)
25 26

  
26
   3. a status whether the inlining is enough bool
27
*)
27
type call = ident * expr * eq
28
(* fun id, expression, and containing equation *)
28 29

  
29
type call = ident * expr * eq (* fun id, expression, and containing equation *)
30
  
31 30
type algebraic_loop = ident list * (call * bool) list * bool
31

  
32 32
type report = (node_desc * algebraic_loop list) list
33
exception Error of report
34 33

  
34
exception Error of report
35 35

  
36 36
(* Module that extract from the DataCycle the set of node that could be inlined
37 37
   to solve the problem. *)
38
module CycleResolution =
39
struct
40

  
38
module CycleResolution = struct
41 39
  (* We iter over calls in node defs. If the call defined on of the variable in
42 40
     the cycle, we store it for future possible inline. *)
43 41
  let resolve node partition : call list =
......
45 43
    (* Preprocessing calls: associate to each of them the eq.lhs associated *)
46 44
    let calls_expr = Causality.NodeDep.get_calls (fun _ -> true) node in
47 45
    let eqs, auts = get_node_eqs node in
48
    assert (auts = []); (* TODO voir si on peut acceder directement aux eqs qui font les calls *)
49
    let calls = List.map (
50
      fun expr ->
51
	let eq = List.find (fun eq ->
52
	  Corelang.expr_contains_expr expr.expr_tag eq.eq_rhs 
53
	) eqs in
54
	let fun_name = match expr.expr_desc with
55
	  | Expr_appl(fun_id, _, _) -> fun_id
56
	  | _ -> assert false
57
	in
58
	fun_name, expr, eq
59
    ) calls_expr in
60
    List.fold_left (
61
      fun accu ((_, _, eq) as call) ->
62
	let shared_vars = ISet.inter (ISet.of_list eq.eq_lhs) partition in
63
	if not (ISet.is_empty shared_vars) then
64
	  (* We have a match: keep the eq and the expr to inline *)
65
	  call::accu
66
	else
67
	  accu
68
    ) [] calls
46
    assert (auts = []);
47
    (* TODO voir si on peut acceder directement aux eqs qui font les calls *)
48
    let calls =
49
      List.map
50
        (fun expr ->
51
          let eq =
52
            List.find
53
              (fun eq -> Corelang.expr_contains_expr expr.expr_tag eq.eq_rhs)
54
              eqs
55
          in
56
          let fun_name =
57
            match expr.expr_desc with
58
            | Expr_appl (fun_id, _, _) ->
59
              fun_id
60
            | _ ->
61
              assert false
62
          in
63
          fun_name, expr, eq)
64
        calls_expr
65
    in
66
    List.fold_left
67
      (fun accu ((_, _, eq) as call) ->
68
        let shared_vars = ISet.inter (ISet.of_list eq.eq_lhs) partition in
69
        if not (ISet.is_empty shared_vars) then
70
          (* We have a match: keep the eq and the expr to inline *)
71
          call :: accu
72
        else accu)
73
      [] calls
69 74
end
70 75

  
76
(* Format.fprintf fmt "@[<v 2>Possible resolution:@ %a@]" pp_resolution
77
   resolution*)
71 78

  
72
(* Format.fprintf fmt "@[<v 2>Possible resolution:@ %a@]" pp_resolution resolution*)
73

  
74
    
75 79
let pp_resolution fmt resolution =
76
  fprintf_list ~sep:"@ " (fun fmt (eq, _) ->
77
    Format.fprintf fmt "inlining: %a" Printers.pp_node_eq eq
78
  ) fmt resolution
79
  
80
  fprintf_list ~sep:"@ "
81
    (fun fmt (eq, _) ->
82
      Format.fprintf fmt "inlining: %a" Printers.pp_node_eq eq)
83
    fmt resolution
84

  
80 85
let al_is_solved (_, als) = List.for_all (fun (_, _, status) -> status) als
81
  
86

  
82 87
(**********************************************************************)
83 88
(* Functions to access or toggle the local inlining feature of a call *)
84 89
(* expression                                                         *)
85 90
(**********************************************************************)
86 91

  
87 92
let inline_annotation loc =
88
  Inliner.keyword,
89
  Corelang.mkeexpr loc
90
    (Corelang.mkexpr loc
91
       (Expr_const (Const_tag tag_true) ))
93
  ( Inliner.keyword,
94
    Corelang.mkeexpr loc (Corelang.mkexpr loc (Expr_const (Const_tag tag_true)))
95
  )
92 96

  
93 97
let is_inlining_annot (key, status) =
94
key = Inliner.keyword && (
98
  key = Inliner.keyword
99
  &&
95 100
  match status.eexpr_qfexpr.expr_desc with
96 101
  | Expr_const (Const_tag tag) when tag = tag_true ->
97
     true
102
    true
98 103
  | Expr_const (Const_tag tag) when tag = tag_false ->
99
     false
100
  | _ -> assert false (* expecting true or false value *)	 
101
)
102
  
104
    false
105
  | _ ->
106
    assert false
107
(* expecting true or false value *)
108

  
103 109
let is_expr_inlined nd expr =
104 110
  match expr.expr_annot with
105
    None -> false
111
  | None ->
112
    false
106 113
  | Some anns -> (
107
     (* Sanity check: expr should have the annotation AND the annotation should be declared *)
108
     let local_ann = List.exists is_inlining_annot anns.annots in
109
     let all_expr_inlined = Hashtbl.find_all Annotations.expr_annotations Inliner.keyword in
110
     let registered =
111
       List.exists
112
	 (fun (nd_id, expr_tag) -> nd_id = nd.node_id && expr_tag = expr.expr_tag)
113
	 all_expr_inlined
114
     in
115
     match local_ann, registered with
116
     | true, true -> true (* Everythin' all righ' ! *)
117
     | false, false -> false (* idem *)
118
     | _ -> assert false 
119
  )
114
    (* Sanity check: expr should have the annotation AND the annotation should
115
       be declared *)
116
    let local_ann = List.exists is_inlining_annot anns.annots in
117
    let all_expr_inlined =
118
      Hashtbl.find_all Annotations.expr_annotations Inliner.keyword
119
    in
120
    let registered =
121
      List.exists
122
        (fun (nd_id, expr_tag) ->
123
          nd_id = nd.node_id && expr_tag = expr.expr_tag)
124
        all_expr_inlined
125
    in
126
    match local_ann, registered with
127
    | true, true ->
128
      true (* Everythin' all righ' ! *)
129
    | false, false ->
130
      false (* idem *)
131
    | _ ->
132
      assert false)
120 133

  
121
let pp_calls nd fmt calls = Format.fprintf fmt "@[<v 0>%a@]"
122
  (fprintf_list ~sep:"@ " (fun fmt (funid,expr, _) -> Format.fprintf fmt "%s: %i (inlined:%b)"
123
    funid
124
    expr.expr_tag
125
    (is_expr_inlined nd expr)
126
   ))
127
  calls
134
let pp_calls nd fmt calls =
135
  Format.fprintf fmt "@[<v 0>%a@]"
136
    (fprintf_list ~sep:"@ " (fun fmt (funid, expr, _) ->
137
         Format.fprintf fmt "%s: %i (inlined:%b)" funid expr.expr_tag
138
           (is_expr_inlined nd expr)))
139
    calls
128 140

  
129 141
(* Inline the provided expression *)
130 142
let inline_expr node expr =
131 143
  (* Format.eprintf "inlining %a@ @?" Printers.pp_expr expr; *)
132 144
  let ann = inline_annotation expr.expr_loc in
133
  let ann = {annots = [ann]; annot_loc = expr.expr_loc} in
145
  let ann = { annots = [ ann ]; annot_loc = expr.expr_loc } in
134 146
  let res = update_expr_annot node.node_id expr ann in
135 147
  (* assert (is_expr_inlined node res); *)
136 148
  (* Format.eprintf "Is expression inlined? %b@." (is_expr_inlined node res); *)
137 149
  res
138 150

  
139
(* Perform the steps of stage1/stage2 to revalidate the schedulability of the program *)
151
(* Perform the steps of stage1/stage2 to revalidate the schedulability of the
152
   program *)
140 153
let fast_stages_processing prog =
141
  Log.report ~level:3
142
    (fun fmt -> Format.fprintf fmt "@[<v 2>Fast revalidation: normalization + schedulability@ ");
154
  Log.report ~level:3 (fun fmt ->
155
      Format.fprintf fmt
156
        "@[<v 2>Fast revalidation: normalization + schedulability@ ");
143 157
  Options.verbose_level := !Options.verbose_level - 2;
144 158

  
145 159
  (* Mini stage 1 *)
......
150 164
  (* Checking stateless/stateful status *)
151 165
  if Plugins.check_force_stateful () then
152 166
    Compiler_common.force_stateful_decls prog
153
  else
154
    Compiler_common.check_stateless_decls prog;
167
  else Compiler_common.check_stateless_decls prog;
155 168
  (* Typing *)
156
  let _ (*computed_types_env*) = Compiler_common.type_decls !Global.type_env prog in
169
  let _ (*computed_types_env*) =
170
    Compiler_common.type_decls !Global.type_env prog
171
  in
157 172
  (* Clock calculus *)
158
  let _ (*computed_clocks_env*) = Compiler_common.clock_decls !Global.clock_env prog in
173
  let _ (*computed_clocks_env*) =
174
    Compiler_common.clock_decls !Global.clock_env prog
175
  in
159 176
  (* Normalization *)
160 177
  let params = Backends.get_normalization_params () in
161 178
  let prog = Normalization.normalize_prog params prog in
......
163 180
  let res = Scheduling.schedule_prog prog in
164 181
  Options.verbose_level := !Options.verbose_level + 2;
165 182

  
166
  Log.report ~level:3
167
    (fun fmt -> Format.fprintf fmt "@]@ ");
183
  Log.report ~level:3 (fun fmt -> Format.fprintf fmt "@]@ ");
168 184
  res
169 185

  
170 186
(**********************)
......
172 188
let rec solving_node max_inlines prog nd existing_al partitions =
173 189
  (* let pp_calls = pp_calls nd in *)
174 190
  (* For each partition, we identify the original one *)
175
  let rerun, max_inlines, al = List.fold_left (fun (rerun, _, _) part ->
176
    let part_vars = ISet.of_list part in 
177
    (* Useful functions to filter list of elements *)
178
    let match_al (vars, _, _) =
179
      not (ISet.is_empty (ISet.inter (ISet.of_list vars) part_vars)) in
180
    (* Identifying previous alarms that could be associated to current conflict *)
181
    let matched, non_matched = List.partition match_al existing_al in
182
    let previous_calls =
183
      match matched with
184
      | [] -> []
185
      | [_ (*vars*), calls, _ (*status*)] -> List.map fst calls (* we just keep the calls *)
186
      | _ -> (* variable should not belong to two different algrebraic loops. At least I
187
		hope so! *)
188
	 assert false
189
    in
190
    let match_previous (_, expr, _) =
191
      List.exists
192
	(fun (_, expr', _) -> expr'.expr_tag = expr.expr_tag)
193
	previous_calls
194
    in
195
    (* let match_inlined (_, expr, _) = is_expr_inlined nd expr in *)
196
    
197
    (* let previous_inlined, previous_no_inlined = List.partition match_inlined previous_calls in *)
198
    (* Format.eprintf "Previous calls: @[<v 0>inlined: {%a}@ no inlined: {%a}@ @]@ " *)
199
    (*   pp_calls previous_inlined *)
200
    (*   pp_calls previous_no_inlined *)
201

  
202
    (* ; *)
203
    
204
    let current_calls = CycleResolution.resolve nd part in
205
    (* Format.eprintf "Current calls: %a" pp_calls current_calls; *)
206
    (* Filter out calls from current_calls that were not already in previous calls *)
207
    let current_calls = List.filter (fun c -> not (match_previous c)) current_calls
208
    in
209
    (* Format.eprintf "Current new calls (no old ones): %a" pp_calls current_calls; *)
210
    let calls = previous_calls @ current_calls in
211
    (* Format.eprintf "All calls (previous + new): %a" pp_calls calls; *)
212
    
213
    (* Filter out already inlined calls: actually they should not appear
214
       ... since they were inlined. We keep it for safety. *)
215
    let _ (* already_inlined *), possible_resolution =
216
      List.partition (fun (_, expr, _) -> is_expr_inlined nd expr) calls in
217
    (* Inlining the first uninlined call *)
218
    match possible_resolution with
219
    | (fun_id, expr, _)::_ -> ((* One could inline expr *)
220
      Log.report ~level:2 (fun fmt-> Format.fprintf fmt "inlining call to %s@ " fun_id); 
221
      (* Forcing the expr to be inlined *)
222
      let _ = inline_expr nd expr in
223
      (* Format.eprintf "Making sure that the inline list evolved: inlined = {%a}" *)
224
      (* 	pp_calls  *)
225
      (* ; *)
226
      true, (* we have to rerun to see if the inlined expression solves the issue *)
227
      max_inlines - 1,
228
      (
229
	part,
230
	List.map (fun ((_, expr2, _) as call)->  call, (expr2.expr_tag = expr.expr_tag)) calls,
231
	true (* TODO was false. Should be put it true and expect a final
232
		scheduling to change it to false in case of failure ? *) (*
233
									   Status is nok, LA is unsolved yet *)
234
	  
235
      )::non_matched
236
    )	 
237
    | [] -> (* No more calls to inline: algebraic loop is not solvable *)
238
       rerun, (* we don't force rerun since the current node is not solvable *)
239
      max_inlines,
240
      (
241
	part, (* initial list of troublesogme variables *)
242
	List.map (fun call ->  call, false) calls,
243
	false (* Status is nok, LA is unsolved *)
244
      )::non_matched 
245
	
246
  ) (false, max_inlines, existing_al) partitions
191
  let rerun, max_inlines, al =
192
    List.fold_left
193
      (fun (rerun, _, _) part ->
194
        let part_vars = ISet.of_list part in
195
        (* Useful functions to filter list of elements *)
196
        let match_al (vars, _, _) =
197
          not (ISet.is_empty (ISet.inter (ISet.of_list vars) part_vars))
198
        in
199
        (* Identifying previous alarms that could be associated to current
200
           conflict *)
201
        let matched, non_matched = List.partition match_al existing_al in
202
        let previous_calls =
203
          match matched with
204
          | [] ->
205
            []
206
          | [ (_ (*vars*), calls, _) (*status*) ] ->
207
            List.map fst calls
208
          (* we just keep the calls *)
209
          | _ ->
210
            (* variable should not belong to two different algrebraic loops. At
211
               least I hope so! *)
212
            assert false
213
        in
214
        let match_previous (_, expr, _) =
215
          List.exists
216
            (fun (_, expr', _) -> expr'.expr_tag = expr.expr_tag)
217
            previous_calls
218
        in
219

  
220
        (* let match_inlined (_, expr, _) = is_expr_inlined nd expr in *)
221

  
222
        (* let previous_inlined, previous_no_inlined = List.partition
223
           match_inlined previous_calls in *)
224
        (* Format.eprintf "Previous calls: @[<v 0>inlined: {%a}@ no inlined:
225
           {%a}@ @]@ " *)
226
        (*   pp_calls previous_inlined *)
227
        (*   pp_calls previous_no_inlined *)
228

  
229
        (* ; *)
230
        let current_calls = CycleResolution.resolve nd part in
231
        (* Format.eprintf "Current calls: %a" pp_calls current_calls; *)
232
        (* Filter out calls from current_calls that were not already in previous calls *)
233
        let current_calls =
234
          List.filter (fun c -> not (match_previous c)) current_calls
235
        in
236
        (* Format.eprintf "Current new calls (no old ones): %a" pp_calls
237
           current_calls; *)
238
        let calls = previous_calls @ current_calls in
239

  
240
        (* Format.eprintf "All calls (previous + new): %a" pp_calls calls; *)
241

  
242
        (* Filter out already inlined calls: actually they should not appear ...
243
           since they were inlined. We keep it for safety. *)
244
        let _ (* already_inlined *), possible_resolution =
245
          List.partition (fun (_, expr, _) -> is_expr_inlined nd expr) calls
246
        in
247
        (* Inlining the first uninlined call *)
248
        match possible_resolution with
249
        | (fun_id, expr, _) :: _ ->
250
          (* One could inline expr *)
251
          Log.report ~level:2 (fun fmt ->
252
              Format.fprintf fmt "inlining call to %s@ " fun_id);
253
          (* Forcing the expr to be inlined *)
254
          let _ = inline_expr nd expr in
255
          (* Format.eprintf "Making sure that the inline list evolved: inlined = {%a}" *)
256
          (* 	pp_calls  *)
257
          (* ; *)
258
          ( true,
259
            (* we have to rerun to see if the inlined expression solves the
260
               issue *)
261
            max_inlines - 1,
262
            ( part,
263
              List.map
264
                (fun ((_, expr2, _) as call) ->
265
                  call, expr2.expr_tag = expr.expr_tag)
266
                calls,
267
              true
268
              (* TODO was false. Should be put it true and expect a final
269
                 scheduling to change it to false in case of failure ? *)
270
              (* Status is nok, LA is unsolved yet *) )
271
            :: non_matched )
272
        | [] ->
273
          (* No more calls to inline: algebraic loop is not solvable *)
274
          ( rerun,
275
            (* we don't force rerun since the current node is not solvable *)
276
            max_inlines,
277
            ( part,
278
              (* initial list of troublesogme variables *)
279
              List.map (fun call -> call, false) calls,
280
              false (* Status is nok, LA is unsolved *) )
281
            :: non_matched ))
282
      (false, max_inlines, existing_al)
283
      partitions
247 284
  in
248 285
  (* if partition an already identified al ? *)
249 286
  (* if ISet.of_list partition *)
250
  if rerun && max_inlines > 0 then
251
    (* At least one partition could be improved: we try to inline the calls and reschedule the node. *)
287
  if rerun && max_inlines > 0 then (
288
    (* At least one partition could be improved: we try to inline the calls and
289
       reschedule the node. *)
252 290
    try
253
      Log.report ~level:2 (fun fmt -> Format.fprintf fmt "rescheduling node with new inlined call@ ");
291
      Log.report ~level:2 (fun fmt ->
292
          Format.fprintf fmt "rescheduling node with new inlined call@ ");
254 293
      let _ = fast_stages_processing prog in
255 294
      (* If everything went up to here, the problem is solved! All associated
256
	 alarms are mapped to valid status. *)
257
      let al = List.map (fun (v,c,_) -> v,c,true) al in
295
         alarms are mapped to valid status. *)
296
      let al = List.map (fun (v, c, _) -> v, c, true) al in
258 297
      Log.report ~level:2 (fun fmt -> Format.fprintf fmt "AL solved@ ");
259
      Some(nd, al), max_inlines
260
    with Causality.Error (Causality.DataCycle partitions2) -> (
261
      Log.report ~level:3 (fun fmt -> Format.fprintf fmt "AL not solved yet. Further processing.@ ");
262
      solving_node max_inlines prog nd al partitions2
263
    )
264
  else ((* No rerun, we return the current node and computed alarms *)
265
    Log.report ~level:3 (fun fmt -> Format.fprintf fmt "AL not solved yet. Stopping.@ ");
266
    Some(nd, al), max_inlines
267
  )
268
      
269
(** This function takes a prog and returns (prog', status, alarms)
270
    where prog' is a modified prog with some locally inlined calls
271
    status is true is the final prog' is schedulable, ie no algebraic loop
272
    In case of failure, ie. inlining does not solve the problem; the status is false.
273
    Alarms contain the list of inlining performed or advised for each node. 
274
    This could be provided as a feedback to the user.
275
*)
298
      Some (nd, al), max_inlines
299
    with Causality.Error (Causality.DataCycle partitions2) ->
300
      Log.report ~level:3 (fun fmt ->
301
          Format.fprintf fmt "AL not solved yet. Further processing.@ ");
302
      solving_node max_inlines prog nd al partitions2)
303
  else (
304
    (* No rerun, we return the current node and computed alarms *)
305
    Log.report ~level:3 (fun fmt ->
306
        Format.fprintf fmt "AL not solved yet. Stopping.@ ");
307
    Some (nd, al), max_inlines)
308

  
309
(** This function takes a prog and returns (prog', status, alarms) where prog'
310
    is a modified prog with some locally inlined calls status is true is the
311
    final prog' is schedulable, ie no algebraic loop In case of failure, ie.
312
    inlining does not solve the problem; the status is false. Alarms contain the
313
    list of inlining performed or advised for each node. This could be provided
314
    as a feedback to the user. *)
276 315
let clean_al prog : program_t * bool * report =
277 316
  let max_inlines = !Options.al_nb_max in
278
(* We iterate over each node *)
317
  (* We iterate over each node *)
279 318
  let _, prog, al_list =
280
    List.fold_right (
281
      fun top (max_inlines, prog_accu, al_list) ->
282
	match top.top_decl_desc with
283
	| Node nd -> (
284
	  let error, max_inlines =
285
	    try (* without exception the node is schedulable; nothing to declare *)
286
	      let _ = Scheduling.schedule_node nd in
287
	      None, max_inlines
288
	    with Causality.Error (Causality.DataCycle partitions) -> (
289
	      Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@[<v 2>AL in node %s@ " nd.node_id);
290
	      let error, max_inlines = solving_node max_inlines prog nd [] partitions in
291
	      Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@ @]");
292
	      error, max_inlines
293
	    )
294
	  in
295
	  match error with
296
	  | None -> max_inlines, top::prog_accu, al_list (* keep it as is *)
297
	  | Some (nd, al) ->
298
	     (* returning the updated node, possible solved, as well as the
299
		generated alarms *)
300
	     max_inlines,
301
	     {top with top_decl_desc = Node nd}::prog_accu,
302
	    (nd, al)::al_list 
303
	)	   
304
	| _ -> max_inlines, top::prog_accu, al_list
305
    ) prog (max_inlines, [], []) 
319
    List.fold_right
320
      (fun top (max_inlines, prog_accu, al_list) ->
321
        match top.top_decl_desc with
322
        | Node nd -> (
323
          let error, max_inlines =
324
            try
325
              (* without exception the node is schedulable; nothing to declare *)
326
              let _ = Scheduling.schedule_node nd in
327
              None, max_inlines
328
            with Causality.Error (Causality.DataCycle partitions) ->
329
              Log.report ~level:2 (fun fmt ->
330
                  Format.fprintf fmt "@[<v 2>AL in node %s@ " nd.node_id);
331
              let error, max_inlines =
332
                solving_node max_inlines prog nd [] partitions
333
              in
334
              Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@ @]");
335
              error, max_inlines
336
          in
337
          match error with
338
          | None ->
339
            max_inlines, top :: prog_accu, al_list (* keep it as is *)
340
          | Some (nd, al) ->
341
            (* returning the updated node, possible solved, as well as the
342
               generated alarms *)
343
            ( max_inlines,
344
              { top with top_decl_desc = Node nd } :: prog_accu,
345
              (nd, al) :: al_list ))
346
        | _ ->
347
          max_inlines, top :: prog_accu, al_list)
348
      prog (max_inlines, [], [])
306 349
  in
307 350
  prog, List.for_all al_is_solved al_list, al_list
308 351

  
309

  
310 352
(* (ident list * (ident * expr* bool) list * bool) *)
311 353
let pp_al nd fmt (partition, calls, _) =
312 354
  let open Format in
313 355
  fprintf fmt "@[<v 0>";
314 356
  fprintf fmt "variables in the alg. loop: @[<hov 0>%a@]@ "
315
    (fprintf_list ~sep:",@ " pp_print_string) partition;
357
    (fprintf_list ~sep:",@ " pp_print_string)
358
    partition;
316 359
  fprintf fmt "@ involved node calls: @[<v 0>%a@]@ "
317
    (fprintf_list ~sep:",@ "
318
       (fun fmt ((funid, expr, _), status) ->
319
	 fprintf fmt "%s" funid;
320
	 if status && is_expr_inlined nd expr then fprintf fmt " (inlining it solves the alg. loop)";
321
       )
322
    ) calls;
360
    (fprintf_list ~sep:",@ " (fun fmt ((funid, expr, _), status) ->
361
         fprintf fmt "%s" funid;
362
         if status && is_expr_inlined nd expr then
363
           fprintf fmt " (inlining it solves the alg. loop)"))
364
    calls;
323 365
  fprintf fmt "@]"
324
     (* TODO ploc:
325
	First analyse the cycle and identify a list of nodes to be inlined, or node instances
326
	Then two behaviors: 
327
	- print that list instead of the unreadable cyclic dependency comment
328
	- modify the node by adding the inline information
329
	- recall the subset of stage1 but restricted to a single node:
330
	- inline locally, typing, clocking (may have to reset the tables first), normalization of the node, mpfr injection
331
        - recall stage2
332
     *)
333
    
334
    
366
(* TODO ploc: First analyse the cycle and identify a list of nodes to be
367
   inlined, or node instances Then two behaviors: - print that list instead of
368
   the unreadable cyclic dependency comment - modify the node by adding the
369
   inline information - recall the subset of stage1 but restricted to a single
370
   node: - inline locally, typing, clocking (may have to reset the tables
371
   first), normalization of the node, mpfr injection - recall stage2 *)
372

  
335 373
let pp_report fmt report =
336 374
  let open Format in
337 375
  fprintf_list ~sep:"@."
338 376
    (fun _ (nd, als) ->
339
      let top = Corelang.node_from_name (nd.node_id) in
377
      let top = Corelang.node_from_name nd.node_id in
340 378
      let pp =
341
	if not !Options.solve_al || List.exists (fun (_,_,valid) -> not valid) als then
342
	  Error.pp_error (* at least one failure: erroneous node *)
343
	else
344
	  Error.pp_warning (* solvable cases: warning only *)
379
        if
380
          (not !Options.solve_al)
381
          || List.exists (fun (_, _, valid) -> not valid) als
382
        then Error.pp_error (* at least one failure: erroneous node *)
383
        else Error.pp_warning
384
        (* solvable cases: warning only *)
345 385
      in
346
      pp top.top_decl_loc
347
	(fun fmt -> 
348
	  fprintf fmt "algebraic loop in node %s: {@[<v 0>%a@]}"
349
	    nd.node_id
350
	    (fprintf_list ~sep:"@ " (pp_al nd)) als
351
	)
352
    ) fmt report;
386
      pp top.top_decl_loc (fun fmt ->
387
          fprintf fmt "algebraic loop in node %s: {@[<v 0>%a@]}" nd.node_id
388
            (fprintf_list ~sep:"@ " (pp_al nd))
389
            als))
390
    fmt report;
353 391
  fprintf fmt "@."
354
    
355

  
356 392

  
357 393
let analyze cpt prog =
358 394
  Log.report ~level:1 (fun fmt ->
359
    Format.fprintf fmt "@[<v 2>Algebraic loop detected: ";
360
    if !Options.solve_al then Format.fprintf fmt "solving mode actived";
361
    Format.fprintf fmt "@ ";    
362
  );
395
      Format.fprintf fmt "@[<v 2>Algebraic loop detected: ";
396
      if !Options.solve_al then Format.fprintf fmt "solving mode actived";
397
      Format.fprintf fmt "@ ");
363 398
  let prog, status_ok, report = clean_al prog in
364
  
399

  
365 400
  let res =
366
    if cpt > 0 && !Options.solve_al && status_ok then (
367
      try
368
	fast_stages_processing prog
369
      with _ -> assert false (* Should not happen since the error has been
370
				catched already *)
371
    )
401
    if cpt > 0 && !Options.solve_al && status_ok then
402
      try fast_stages_processing prog with _ -> assert false
403
      (* Should not happen since the error has been catched already *)
372 404
    else (
373
      (* We stop with unresolved AL *)(* TODO create a report *)
405
      (* We stop with unresolved AL *)
406
      (* TODO create a report *)
374 407
      (* Printing the report on stderr *)
375 408
      Format.eprintf "%a" pp_report report;
376
      raise (Error.Error (Location.dummy_loc, Error.AlgebraicLoop))
377
    )
409
      raise (Error.Error (Location.dummy_loc, Error.AlgebraicLoop)))
378 410
  in
379 411
  (* Printing the report on stderr *)
380 412
  Format.eprintf "%a" pp_report report;
381 413
  res
382
    
383
let analyze prog =
384
  analyze !Options.al_nb_max prog
385
    
386
    
414

  
415
let analyze prog = analyze !Options.al_nb_max prog

Also available in: Unified diff