-
Notifications
You must be signed in to change notification settings - Fork 1
/
reduce.ml
139 lines (131 loc) · 6.24 KB
/
reduce.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
open CAST
(* ocaml version not up to date *)
(* let rec list_assoc_opt value = function
| [] -> None
| (x, y) :: _ when x = value -> Some y
| _ :: tl -> list_assoc_opt value tl *)
let reduce_exprs = ref true
(* reverse a comparison *)
let cmp_rev = function
| C_NE -> C_EQ
| C_EQ -> C_NE
| C_GT -> C_LE
| C_LE -> C_GT
| C_GE -> C_LT
| C_LT -> C_GE
(* reduce expressions *)
let rec redexp ?force:(force=false) consts e =
if not force && not !reduce_exprs then (
e
) else (
let rec aux e =
let maxreduce e = abs e < 1000000 in
let rec result e = match snd e with
| CST c -> Some c
| _ -> None
in
match e with
| loc, VAR name -> (
(* variables can be reduced if they are constants *)
match List.assoc_opt name consts with
| None -> (loc, VAR name)
| Some k -> (loc, CST k)
)
| loc, CST c -> (loc, CST c)
| loc, STRING s -> (loc, STRING s)
| loc, SET (pos, value) -> (loc, SET (aux pos, aux value))
| loc, CALL (fn, args) -> (loc, CALL (fn, List.map (aux) args))
| loc, OPSET (op, pos, value) -> (loc, OPSET (op, aux pos, aux value))
| loc, ESEQ lst -> (loc, ESEQ (List.map (aux) lst))
| loc, CMP (op, lhs, rhs) -> (
(* comparisons can be reduced if both operands are integer constants *)
let lhs = aux lhs in
let rhs = aux rhs in
match (result lhs, result rhs) with
| Some x, Some y -> (
(loc, CST (match op with
| C_EQ -> if x = y then 1 else 0
| C_GE -> if x >= y then 1 else 0
| C_LE -> if x <= y then 1 else 0
| C_GT -> if x > y then 1 else 0
| C_LT -> if x < y then 1 else 0
| C_NE -> if x <> y then 1 else 0
))
)
| _ -> (loc, CMP (op, lhs, rhs))
)
| loc, OP1 (op, value) -> (
(* unary operators can be reduced if they have no side-effects
* and the operand is an integer constant *)
let value = aux value in
match result value with
| Some x -> (
(loc, match op with
| M_MINUS -> CST (-x)
| M_NOT -> CST (-x-1)
| _ -> OP1 (op, (loc, CST x))
)
)
| None -> (loc, (OP1 (op, value)))
)
| loc, OP2 (op, lhs, rhs) -> (
(* binary operators can be reduced if they are not S_INDEX
* and if both operands are integer constants *)
let lhs = aux lhs in
let rhs = aux rhs in
match (result lhs, result rhs) with
| Some x, Some y -> (
(loc, match op with
| S_ADD when maxreduce (x + y) -> CST (x + y)
| S_MUL when maxreduce (x * y) -> CST (x * y)
| S_SUB when maxreduce (x - y) -> CST (x - y)
| S_DIV when y = 0 -> (
Error.warning (Some loc) "division by zero detected";
OP2 (op, lhs, rhs)
)
| S_DIV -> CST (
if x >= 0 && y > 0 then x / y
else if x > 0 then -(abs x / abs y)
else if y > 0 then -(abs x / abs y)
else abs x / abs y
)
| S_MOD when y = 0 -> (
Error.warning (Some loc) "division by zero detected";
OP2 (op, lhs, rhs)
)
| S_MOD -> CST (
x mod abs y
)
| S_AND -> CST (x land y)
| S_OR -> CST (x lor y)
| S_XOR -> CST (x lxor y)
| S_SHL when y < 0 -> (
Error.warning (Some loc) "negative shift amount";
OP2 (op, lhs, rhs)
)
| S_SHL when y <= 10 && maxreduce (x lsl y) -> CST (x lsl y)
| S_SHR when y < 0 -> (
Error.warning (Some loc) "negative shift amount";
OP2 (op, lhs, rhs)
)
| S_SHR when y <= 10 && maxreduce (x lsr y) -> CST (x lsr y)
| S_SHR -> OP2 (op, lhs, rhs)
| _ -> OP2 (op, lhs, rhs)
)
)
| _ -> (loc, OP2 (op, lhs, rhs))
)
| loc, EIF (cond, etrue, efalse) -> (
(* EIF can be reduced if the condition is an integer constant *)
match (cond, etrue, efalse) with
| (_, CMP (op, lt, rt)), (_, CST 0), (_, CST 1) -> aux (loc, CMP (cmp_rev op, lt, rt))
| _ -> (
let cond = aux cond in
match result cond with
| Some 0 -> aux efalse
| Some _ -> aux etrue
| None -> loc, EIF (cond, aux etrue, aux efalse)
)
)
in aux e
)