## lustrec / src / optimize_prog.ml @ add75bcb

History | View | Annotate | Download (3.62 KB)

1 |
open Corelang |
---|---|

2 | |

3 |
(* Consts unfoooolding *) |

4 |
let is_const i consts = |

5 |
List.exists (fun c -> c.const_id = i) consts |

6 | |

7 |
let get_const i consts = |

8 |
let c = List.find (fun c -> c.const_id = i) consts in |

9 |
c.const_value |

10 | |

11 |
let rec expr_unfold_consts consts e = |

12 |
{ e with expr_desc = expr_desc_unfold_consts consts e.expr_desc e.expr_type } |

13 | |

14 |
and expr_desc_unfold_consts consts e e_type = |

15 |
let unfold = expr_unfold_consts consts in |

16 |
match e with |

17 |
| Expr_const _ -> e |

18 |
| Expr_ident i -> if is_const i consts && not (Types.is_array_type e_type) then Expr_const (get_const i consts) else e |

19 |
| Expr_array el -> Expr_array (List.map unfold el) |

20 |
| Expr_access (e1, d) -> Expr_access (unfold e1, d) |

21 |
| Expr_power (e1, d) -> Expr_power (unfold e1, d) |

22 |
| Expr_tuple el -> Expr_tuple (List.map unfold el) |

23 |
| Expr_ite (c, t, e) -> Expr_ite (unfold c, unfold t, unfold e) |

24 |
| Expr_arrow (e1, e2)-> Expr_arrow (unfold e1, unfold e2) |

25 |
| Expr_fby (e1, e2) -> Expr_fby (unfold e1, unfold e2) |

26 |
(* | Expr_concat (e1, e2) -> Expr_concat (unfold e1, unfold e2) *) |

27 |
(* | Expr_tail e' -> Expr_tail (unfold e') *) |

28 |
| Expr_pre e' -> Expr_pre (unfold e') |

29 |
| Expr_when (e', i, l)-> Expr_when (unfold e', i, l) |

30 |
| Expr_merge (i, hl) -> Expr_merge (i, List.map (fun (t, h) -> (t, unfold h)) hl) |

31 |
| Expr_appl (i, e', i') -> Expr_appl (i, unfold e', i') |

32 |
| Expr_uclock (e', i) -> Expr_uclock (unfold e', i) |

33 |
| Expr_dclock (e', i) -> Expr_dclock (unfold e', i) |

34 |
| Expr_phclock _ -> e |

35 | |

36 |
let eq_unfold_consts consts eq = |

37 |
{ eq with eq_rhs = expr_unfold_consts consts eq.eq_rhs } |

38 | |

39 |
let node_unfold_consts consts node = |

40 |
{ node with node_eqs = List.map (eq_unfold_consts consts) node.node_eqs } |

41 | |

42 |
let prog_unfold_consts prog = |

43 |
let consts = get_consts prog in |

44 |
List.map ( |

45 |
fun decl -> match decl.top_decl_desc with |

46 |
| Node nd -> {decl with top_decl_desc = Node (node_unfold_consts consts nd)} |

47 |
| _ -> decl |

48 |
) prog |

49 | |

50 |
let apply_stack expr stack = |

51 |
List.fold_left (fun expr (v, t) -> mkexpr expr.expr_loc (Expr_when (expr, v, t))) expr stack |

52 | |

53 |
let expr_distribute_when expr = |

54 |
let rec distrib stack expr = |

55 |
match expr.expr_desc with |

56 |
| Expr_const _ |

57 |
| Expr_ident _ |

58 |
| Expr_arrow _ |

59 |
| Expr_fby _ |

60 |
| Expr_pre _ |

61 |
-> apply_stack expr stack |

62 |
| Expr_appl (id, _, _) when not (Stateless.check_node (node_from_name id)) |

63 |
-> apply_stack expr stack |

64 |
| Expr_ite (c, t, e) |

65 |
-> let cid = ident_of_expr c in |

66 |
mkexpr expr.expr_loc |

67 |
(Expr_merge (cid, |

68 |
[(tag_true , distrib ((cid,tag_true )::stack) t); |

69 |
(tag_false, distrib ((cid,tag_false)::stack) e)])) |

70 |
| Expr_array el -> { expr with expr_desc = (Expr_array (List.map (distrib stack) el)) } |

71 |
| Expr_access (e1, d) -> { expr with expr_desc = Expr_access (distrib stack e1, d) } |

72 |
| Expr_power (e1, d) -> { expr with expr_desc = Expr_power (distrib stack e1, d) } |

73 |
| Expr_tuple el -> { expr with expr_desc = Expr_tuple (List.map (distrib stack) el) } |

74 |
| Expr_when (e', i, l)-> distrib ((i, l)::stack) e' |

75 |
| Expr_merge (i, hl) -> { expr with expr_desc = Expr_merge (i, List.map (fun (t, h) -> (t, distrib stack h)) hl) } |

76 |
| Expr_appl (id, e', i') -> { expr with expr_desc = Expr_appl (id, distrib stack e', i')} |

77 |
| _ -> assert false |

78 |
in distrib [] expr |

79 | |

80 |
let eq_distribute_when eq = |

81 |
{ eq with eq_rhs = expr_distribute_when eq.eq_rhs } |

82 | |

83 |
let node_distribute_when node = |

84 |
{ node with node_eqs = List.map eq_distribute_when node.node_eqs } |

85 | |

86 |
let prog_distribute_when prog = |

87 |
List.map ( |

88 |
fun decl -> match decl.top_decl_desc with |

89 |
| Node nd -> {decl with top_decl_desc = Node (node_distribute_when nd)} |

90 |
| _ -> decl |

91 |
) prog |

92 |
(* Local Variables: *) |

93 |
(* compile-command:"make -C .." *) |

94 |
(* End: *) |