Project

General

Profile

Revision fc886259 src/inliner.ml

View differences:

src/inliner.ml
27 27
  | Node nd -> nd.node_id = id 
28 28
  | _ -> false) 
29 29

  
30
let get_static_inputs node args =
31
  List.fold_right2 (fun vdecl arg static ->
32
    if vdecl.var_dec_const then (vdecl.var_id, Corelang.dimension_of_expr arg) :: static else static)
33
    node.node_inputs
34
    (Corelang.expr_list_of_expr args)
35
    []
36

  
37
let get_carrier_inputs node args =
38
  List.fold_right2 (fun vdecl arg carrier ->
39
    if Types.get_clock_base_type vdecl.var_type <> None then (vdecl.var_id, ident_of_expr arg) :: carrier else carrier)
40
    node.node_inputs
41
    (Corelang.expr_list_of_expr args)
42
    []
43

  
44
let is_node_var node v =
45
 try
46
   ignore (Corelang.get_node_var v node); true
47
 with Not_found -> false
30 48

  
31 49
let rename_expr rename expr = expr_replace_var rename expr
50

  
32 51
let rename_eq rename eq = 
33 52
  { eq with
34 53
    eq_lhs = List.map rename eq.eq_lhs; 
......
36 55
  }
37 56

  
38 57
(* 
39
    expr, locals', eqs = inline_call id args' reset locals nodes
58
    expr, locals', eqs = inline_call id args' reset locals node nodes
40 59

  
41 60
We select the called node equations and variables.
42 61
   renamed_inputs = args
......
47 66
TODO: convert the specification/annotation/assert and inject them
48 67
TODO: deal with reset
49 68
*)
50
let inline_call orig_expr args reset locals node =
69
let inline_call node orig_expr args reset locals caller =
51 70
  let loc = orig_expr.expr_loc in
52 71
  let uid = orig_expr.expr_tag in
53 72
  let rename v =
54
    if v = tag_true || v = tag_false then v else
55
    (Format.fprintf Format.str_formatter "%s_%i_%s" 
56
      node.node_id uid v;
57
    Format.flush_str_formatter ())
73
    if v = tag_true || v = tag_false || not (is_node_var node v) then v else
74
      Corelang.mk_new_node_name caller (Format.sprintf "%s_%i_%s" node.node_id uid v)
58 75
  in
59 76
  let eqs' = List.map (rename_eq rename) (get_node_eqs node)
60 77
  in
61
  let rename_var v = { v with var_id = rename v.var_id } in
78
  let static_inputs = get_static_inputs node args in
79
  let carrier_inputs = get_carrier_inputs node args in
80
  let rename_static v =
81
    try
82
      List.assoc v static_inputs
83
    with Not_found -> Dimension.mkdim_ident loc v
84
    (*Format.eprintf "Inliner.rename_static %s = %a@." v Dimension.pp_dimension res; res*)
85
  in
86
  let rename_carrier v =
87
    try
88
      List.assoc v carrier_inputs
89
    with Not_found -> v in
90
  let rename_var v =
91
  (*Format.eprintf "Inliner.rename_var %a@." Printers.pp_var v;*)
92
    { v with
93
      var_id = rename v.var_id;
94
      var_type = Types.rename_static rename_static v.var_type;
95
      var_clock = Clocks.rename_static rename_carrier v.var_clock;
96
    } in
62 97
  let inputs' = List.map rename_var node.node_inputs in
63 98
  let outputs' = List.map rename_var node.node_outputs in
64 99
  let locals' = List.map rename_var node.node_locals in
65

  
66 100
  (* checking we are at the appropriate (early) step: node_checks and
67 101
     node_gencalls should be empty (not yet assigned) *)
68 102
  assert (node.node_checks = []);
......
72 106
  assert (reset = None);
73 107

  
74 108
  let assign_inputs = mkeq loc (List.map (fun v -> v.var_id) inputs', args) in
75
  let expr = expr_of_expr_list 
76
    loc 
77
    (List.map (fun v -> mkexpr loc (Expr_ident v.var_id)) outputs')
109
  let expr = expr_of_expr_list loc (List.map expr_of_vdecl outputs')
78 110
  in
79 111
  let asserts' = (* We rename variables in assert expressions *)
80 112
    List.map 
......
92 124

  
93 125

  
94 126

  
127
let inline_table = Hashtbl.create 23
95 128

  
96 129
(* 
97
   new_expr, new_locals, new_eqs = inline_expr expr locals nodes
130
   new_expr, new_locals, new_eqs = inline_expr expr locals node nodes
98 131
   
99 132
   Each occurence of a node in nodes in the expr should be replaced by fresh
100 133
   variables and the code of called node instance added to new_eqs
101 134

  
102 135
*)
103
let rec inline_expr ?(selection_on_annotation=false) expr locals nodes =
136
let rec inline_expr ?(selection_on_annotation=false) expr locals node nodes =
104 137
  let inline_expr = inline_expr ~selection_on_annotation:selection_on_annotation in
105 138
  let inline_node = inline_node ~selection_on_annotation:selection_on_annotation in
106 139
  let inline_tuple el = 
107 140
    List.fold_right (fun e (el_tail, locals, eqs, asserts) -> 
108
      let e', locals', eqs', asserts' = inline_expr e locals nodes in
141
      let e', locals', eqs', asserts' = inline_expr e locals node nodes in
109 142
      e'::el_tail, locals', eqs'@eqs, asserts@asserts'
110 143
    ) el ([], locals, [], [])
111 144
  in
......
124 157
  
125 158
  match expr.expr_desc with
126 159
  | Expr_appl (id, args, reset) ->
127
    let args', locals', eqs', asserts' = inline_expr args locals nodes in 
160
    let args', locals', eqs', asserts' = inline_expr args locals node nodes in 
128 161
    if List.exists (check_node_name id) nodes && (* the current node call is provided
129 162
						    as arguments nodes *)
130 163
      (not selection_on_annotation || is_inline_expr expr) (* and if selection on annotation is activated, 
131 164
							      it is explicitely inlined here *)
132 165
    then 
133 166
      (* The node should be inlined *)
134
       let _ =     Format.eprintf "Inlining call to %s@." id in 
135
      let node = try List.find (check_node_name id) nodes 
167
      (* let _ =     Format.eprintf "Inlining call to %s@." id in *)
168
      let called = try List.find (check_node_name id) nodes 
136 169
	with Not_found -> (assert false) in
137
      let node = node_of_top node in
138
      let node = inline_node node nodes in
170
      let called = node_of_top called in
171
      let called' = inline_node called nodes in
139 172
      let expr, locals', eqs'', asserts'' = 
140
	inline_call expr args' reset locals' node in
173
	inline_call called' expr args' reset locals' node in
141 174
      expr, locals', eqs'@eqs'', asserts'@asserts''
142 175
    else 
143 176
      (* let _ =     Format.eprintf "Not inlining call to %s@." id in *)
......
165 198
    let el', l', eqs', asserts' = inline_tuple el in
166 199
    { expr with expr_desc = Expr_array el' }, l', eqs', asserts'
167 200
  | Expr_access (e, dim) ->
168
    let e', l', eqs', asserts' = inline_expr e locals nodes in 
201
    let e', l', eqs', asserts' = inline_expr e locals node nodes in 
169 202
    { expr with expr_desc = Expr_access (e', dim) }, l', eqs', asserts'
170 203
  | Expr_power (e, dim) ->
171
    let e', l', eqs', asserts' = inline_expr e locals nodes in 
204
    let e', l', eqs', asserts' = inline_expr e locals node nodes in 
172 205
    { expr with expr_desc = Expr_power (e', dim) }, l', eqs', asserts'
173 206
  | Expr_pre e ->
174
    let e', l', eqs', asserts' = inline_expr e locals nodes in 
207
    let e', l', eqs', asserts' = inline_expr e locals node nodes in 
175 208
    { expr with expr_desc = Expr_pre e' }, l', eqs', asserts'
176 209
  | Expr_when (e, id, label) ->
177
    let e', l', eqs', asserts' = inline_expr e locals nodes in 
210
    let e', l', eqs', asserts' = inline_expr e locals node nodes in 
178 211
    { expr with expr_desc = Expr_when (e', id, label) }, l', eqs', asserts'
179 212
  | Expr_merge (id, branches) ->
180 213
    let el, l', eqs', asserts' = inline_tuple (List.map snd branches) in
181 214
    let branches' = List.map2 (fun (label, _) v -> label, v) branches el in
182 215
    { expr with expr_desc = Expr_merge (id, branches') }, l', eqs', asserts'
183
and inline_node ?(selection_on_annotation=false) nd nodes = 
216

  
217
and inline_node ?(selection_on_annotation=false) node nodes =
218
  try Hashtbl.find inline_table node.node_id
219
  with Not_found ->
184 220
  let inline_expr = inline_expr ~selection_on_annotation:selection_on_annotation in
185 221
  let new_locals, eqs, asserts = 
186 222
    List.fold_left (fun (locals, eqs, asserts) eq ->
187 223
      let eq_rhs', locals', new_eqs', asserts' = 
188
	inline_expr eq.eq_rhs locals nodes 
224
	inline_expr eq.eq_rhs locals node nodes 
189 225
      in
190 226
      locals', { eq with eq_rhs = eq_rhs' }::new_eqs'@eqs, asserts'@asserts
191
    ) (nd.node_locals, [], nd.node_asserts) (get_node_eqs nd)
227
    ) (node.node_locals, [], node.node_asserts) (get_node_eqs node)
192 228
  in
193
  { nd with
229
  let inlined = 
230
  { node with
194 231
    node_locals = new_locals;
195 232
    node_stmts = List.map (fun eq -> Eq eq) eqs;
196 233
    node_asserts = asserts;
197 234
  }
235
  in
236
  begin
237
    (*Format.eprintf "inline node:<< %a@.>>@." Printers.pp_node inlined;*)
238
    Hashtbl.add inline_table node.node_id inlined;
239
    inlined
240
  end
198 241

  
199 242
let inline_all_calls node nodes =
200 243
  let nd = match node.top_decl_desc with Node nd -> nd | _ -> assert false in
......
299 342
  in
300 343
  let main = [{ top_decl_desc = Node main_node; top_decl_loc = loc; top_decl_owner = filename; top_decl_itf = false }] in
301 344
  let new_prog = others@nodes_origs@nodes_inlined@main in
345

  
302 346
  let _ = Typing.type_prog type_env new_prog in
303 347
  let _ = Clock_calculus.clock_prog clock_env new_prog in
304 348

  

Also available in: Unified diff