comparison lab4/simp.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
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