## Mercurial > hg > compilers

### annotate lab4/simp.ml @ 0:bfdcc3820b32

Find changesets by keywords (author, files, the commit message), revision
number or hash, or revset expression.

Basis

author | Mike Spivey <mike@cs.ox.ac.uk> |
---|---|

date | Thu, 05 Oct 2017 08:04:15 +0100 |

parents | |

children |

rev | line source |
---|---|

0 | 1 (* lab4/simp.ml *) |

2 (* Copyright (c) 2017 J. M. Spivey *) | |

3 | |

4 open Optree | |

5 | |

6 (* |exact_log2| -- return log2 of argument, or raise Not_found *) | |

7 let exact_log2 x = | |

8 let rec loop y i = | |

9 if y = 1 then i | |

10 else if y mod 2 <> 0 then raise Not_found | |

11 else loop (y/2) (i+1) in | |

12 if x <= 0 then raise Not_found; | |

13 loop x 0 | |

14 | |

15 (* |swap| -- find reverse operation or raise Not_found *) | |

16 let swap = | |

17 function Plus -> Plus | Times -> Times | Eq -> Eq | Lt -> Gt | |

18 | Gt -> Lt | Leq -> Geq | Geq -> Leq | Neq -> Neq | |

19 | And -> And | Or -> Or | |

20 | _ -> raise Not_found | |

21 | |

22 (* |is_const| -- test if expression is a constant *) | |

23 let is_const = function <CONST a> -> true | _ -> false | |

24 | |

25 (* |simp| -- simplify an expression tree at the root *) | |

26 let rec simp t = | |

27 match t with | |

28 (* Constant folding *) | |

29 <BINOP w, <CONST a>, <CONST b>> -> | |

30 <CONST (do_binop w a b)> | |

31 | <MONOP w, <CONST a>> -> | |

32 <CONST (do_monop w a)> | |

33 | |

34 (* Static bound checks *) | |

35 | <BOUND, <CONST k>, <CONST b>> -> | |

36 if 0 <= k && k < b then <CONST k> else t | |

37 | |

38 (* Simplifications -- mainly directed at addressing calculations *) | |

39 | <BINOP Plus, t1, <CONST a>> when a < 0 -> | |

40 <BINOP Minus, t1, <CONST (-a)>> | |

41 | <BINOP Minus, t1, <CONST a>> when a < 0 -> | |

42 <BINOP Plus, t1, <CONST (-a)>> | |

43 | |

44 | <OFFSET, <LOCAL a>, <CONST b>> -> | |

45 <LOCAL (a+b)> | |

46 | <OFFSET, <OFFSET, t1, <CONST a>>, <CONST b>> -> | |

47 simp <OFFSET, t1, <CONST (a+b)>> | |

48 | <OFFSET, t1, <CONST 0>> -> | |

49 t1 | |

50 | <BINOP Times, <BINOP Times, t1, <CONST a>>, <CONST b>> -> | |

51 simp <BINOP Times, t1, <CONST (a * b)>> | |

52 | <BINOP Times, <BINOP Plus, t1, <CONST a>>, <CONST b>> -> | |

53 simp <BINOP Plus, | |

54 simp <BINOP Times, t1, <CONST b>>, | |

55 <CONST (a*b)>> | |

56 | <BINOP Times, <BINOP Minus, t1, <CONST a>>, <CONST b>> -> | |

57 simp <BINOP Minus, | |

58 simp <BINOP Times, t1, <CONST b>>, | |

59 <CONST (a*b)>> | |

60 | <OFFSET, t1, <BINOP Plus, t2, t3>> -> | |

61 simp <OFFSET, simp <OFFSET, t1, t2>, t3> | |

62 | <OFFSET, t1, <BINOP Minus, t2, <CONST n>>> -> | |

63 simp <OFFSET, simp <OFFSET, t1, t2>, <CONST (-n)>> | |

64 | <BINOP Times, t1, <CONST 1>> -> t1 | |

65 | <BINOP Times, t1, <CONST n>> when n > 0 -> | |

66 (try | |

67 let k = exact_log2 n in | |

68 <BINOP Lsl, t1, <CONST k>> | |

69 with Not_found -> t) | |

70 | <BINOP Plus, t1, <CONST 0>> -> t1 | |

71 | <BINOP Minus, t1, <CONST 0>> -> t1 | |

72 | |

73 (* Swap operands to put constant on right *) | |

74 | <BINOP w, <CONST a>, t2> -> | |

75 if is_const t2 || not (Util.can swap w) then t else | |

76 simp <BINOP (swap w), t2, <CONST a>> | |

77 | <JUMPC (w, lab), <CONST a>, t2> -> | |

78 if is_const t2 then t else | |

79 simp <JUMPC (swap w, lab), t2, <CONST a>> | |

80 | |

81 | _ -> t | |

82 | |

83 (* |simplify| -- recursively simplify an expression *) | |

84 let rec simplify <x, @ts> = simp <x, @(List.map simplify ts)> | |

85 | |

86 (* |optimise| -- simplify a procedure body *) | |

87 let optimise prog = | |

88 List.map simplify prog | |

89 |