Revision a1daa793 src/optimize_machine.ml
src/optimize_machine.ml  

16  16 
open Machine_code 
17  17 
open Dimension 
18  18  
19  
19  20 
let pp_elim fmt elim = 
20  21 
begin 
21  22 
Format.fprintf fmt "{ /* elim table: */@."; 
...  ...  
52  53 
let eliminate_dim elim dim = 
53  54 
Dimension.expr_replace_expr (fun v > try dimension_of_value (IMap.find v elim) with Not_found > mkdim_ident dim.dim_loc v) dim 
54  55  
56 
let unfold_expr_offset m offset expr = 

57 
List.fold_left (fun res > (function Index i > Access(res, value_of_dimension m i)  Field f > failwith "not yet implemented")) expr offset 

58  
59 
let rec simplify_cst_expr m offset cst = 

60 
match offset, cst with 

61 
 [] , _ 

62 
> Cst cst 

63 
 Index i :: q, Const_array cl when Dimension.is_dimension_const i 

64 
> simplify_cst_expr m q (List.nth cl (Dimension.size_const_dimension i)) 

65 
 Index i :: q, Const_array cl 

66 
> unfold_expr_offset m [Index i] (Array (List.map (simplify_cst_expr m q) cl)) 

67 
 Field f :: q, Const_struct fl 

68 
> simplify_cst_expr m q (List.assoc f fl) 

69 
 _ > (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false) 

70  
71 
let simplify_expr_offset m expr = 

72 
let rec simplify offset expr = 

73 
match offset, expr with 

74 
 Field f ::q , _ > failwith "not yet implemented" 

75 
 _ , Fun (id, vl) when Basic_library.is_internal_fun id 

76 
> Fun (id, List.map (simplify offset) vl) 

77 
 _ , Fun _ 

78 
 _ , StateVar _ 

79 
 _ , LocalVar _ > unfold_expr_offset m offset expr 

80 
 _ , Cst cst > simplify_cst_expr m offset cst 

81 
 _ , Access (expr, i) > simplify (Index (dimension_of_value i) :: offset) expr 

82 
 [] , _ > expr 

83 
 Index _ :: q, Power (expr, _) > simplify q expr 

84 
 Index i :: q, Array vl when Dimension.is_dimension_const i 

85 
> simplify q (List.nth vl (Dimension.size_const_dimension i)) 

86 
 Index i :: q, Array vl > unfold_expr_offset m [Index i] (Array (List.map (simplify q) vl)) 

87 
 _ > (Format.eprintf "internal error: Optimize_machine.simplify_expr_offset %a@." pp_val expr; assert false) 

88 
(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res) 

89 
with e > (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*) 

90 
in simplify [] expr 

91  
92 
let rec simplify_instr_offset m instr = 

93 
match instr with 

94 
 MLocalAssign (v, expr) > MLocalAssign (v, simplify_expr_offset m expr) 

95 
 MStateAssign (v, expr) > MStateAssign (v, simplify_expr_offset m expr) 

96 
 MReset id > instr 

97 
 MStep (outputs, id, inputs) > MStep (outputs, id, List.map (simplify_expr_offset m) inputs) 

98 
 MBranch (cond, brl) 

99 
> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) > l, simplify_instrs_offset m il) brl) 

100  
101 
and simplify_instrs_offset m instrs = 

102 
List.map (simplify_instr_offset m) instrs 

103  
55  104 
let is_scalar_const c = 
56  105 
match c with 
57  106 
 Const_int _ 
...  ...  
60  109 
 Const_tag _ > true 
61  110 
 _ > false 
62  111  
63 
let basic_unfoldable_expr expr = 

64 
match expr with 

65 
 Cst c when is_scalar_const c > true 

66 
 LocalVar _ 

67 
 StateVar _ > true 

68 
 _ > false 

112 
(* An instruction v = expr may (and will) be unfolded iff: 

113 
 either expr is atomic 

114 
(no complex expressions, only const, vars and array/struct accesses) 

115 
 or v has a fanin <= 1 (used at most once) 

116 
*) 

117 
let is_unfoldable_expr fanin expr = 

118 
let rec unfold_const offset cst = 

119 
match offset, cst with 

120 
 _ , Const_int _ 

121 
 _ , Const_real _ 

122 
 _ , Const_float _ 

123 
 _ , Const_tag _ > true 

124 
 Field f :: q, Const_struct fl > unfold_const q (List.assoc f fl) 

125 
 [] , Const_struct _ > false 

126 
 Index i :: q, Const_array cl when Dimension.is_dimension_const i 

127 
> unfold_const q (List.nth cl (Dimension.size_const_dimension i)) 

128 
 _ , Const_array _ > false 

129 
 _ > assert false in 

130 
let rec unfold offset expr = 

131 
match offset, expr with 

132 
 _ , Cst cst > unfold_const offset cst 

133 
 _ , LocalVar _ 

134 
 _ , StateVar _ > true 

135 
 [] , Power _ 

136 
 [] , Array _ > false 

137 
 Index i :: q, Power (v, _) > unfold q v 

138 
 Index i :: q, Array vl when Dimension.is_dimension_const i 

139 
> unfold q (List.nth vl (Dimension.size_const_dimension i)) 

140 
 _ , Array _ > false 

141 
 _ , Access (v, i) > unfold (Index (dimension_of_value i) :: offset) v 

142 
 _ , Fun (id, vl) when fanin < 2 && Basic_library.is_internal_fun id 

143 
> List.for_all (unfold offset) vl 

144 
 _ , Fun _ > false 

145 
 _ > assert false 

146 
in unfold [] expr 

69  147  
70  148 
let unfoldable_assign fanin v expr = 
71  149 
try 
72  150 
let d = Hashtbl.find fanin v.var_id 
73 
in basic_unfoldable_expr expr  

151 
in is_unfoldable_expr d expr 

152 
with Not_found > false 

153 
(* 

154 
let unfoldable_assign fanin v expr = 

155 
try 

156 
let d = Hashtbl.find fanin v.var_id 

157 
in is_basic_expr expr  

74  158 
match expr with 
75  159 
 Cst c when d < 2 > true 
76  160 
 Fun (id, _) when d < 2 && Basic_library.is_internal_fun id > true 
77  161 
 _ > false 
78  162 
with Not_found > false 
79  
163 
*) 

80  164 
let merge_elim elim1 elim2 = 
81  165 
let merge k e1 e2 = 
82  166 
match e1, e2 with 
...  ...  
141  225 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) 
142  226 
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in 
143  227 
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in 
228 
let instrs = simplify_instrs_offset machine instrs in 

229 
let checks = List.map (fun (loc, check) > loc, eliminate_expr elim_vars check) machine.mstep.step_checks in 

144  230 
let locals = List.filter (fun v > not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in 
145  231 
let minstances = List.map (static_call_unfold elim_consts) machine.minstances in 
146  232 
let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls 
...  ...  
150  236 
mstep = { 
151  237 
machine.mstep with 
152  238 
step_locals = locals; 
153 
step_instrs = instrs 

239 
step_instrs = instrs; 

240 
step_checks = checks 

154  241 
}; 
155  242 
mconst = mconst; 
156  243 
minstances = minstances; 
...  ...  
256  343 
(* Simple cases*) 
257  344 
 MStep([v], id, vl) when Basic_library.is_internal_fun id 
258  345 
> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl))) 
259 
 MLocalAssign(v, expr) when basic_unfoldable_expr expr


346 
 MLocalAssign(v, expr) when is_unfoldable_expr 2 expr


260  347 
> (IMap.add v.var_id expr subst, instr :: instrs) 
261  348 
 _ when is_assign instr 
262  349 
> subst_instr subst instrs instr 
Also available in: Unified diff