annotate lab4/simp.ml @ 1:b5139af1a420 tip basis

Fixed permissions on compile scripts
author Mike Spivey <mike@cs.ox.ac.uk>
date Fri, 13 Oct 2017 17:27:58 +0100
parents bfdcc3820b32
children
rev   line source
mike@0 1 (* lab4/simp.ml *)
mike@0 2 (* Copyright (c) 2017 J. M. Spivey *)
mike@0 3
mike@0 4 open Optree
mike@0 5
mike@0 6 (* |exact_log2| -- return log2 of argument, or raise Not_found *)
mike@0 7 let exact_log2 x =
mike@0 8 let rec loop y i =
mike@0 9 if y = 1 then i
mike@0 10 else if y mod 2 <> 0 then raise Not_found
mike@0 11 else loop (y/2) (i+1) in
mike@0 12 if x <= 0 then raise Not_found;
mike@0 13 loop x 0
mike@0 14
mike@0 15 (* |swap| -- find reverse operation or raise Not_found *)
mike@0 16 let swap =
mike@0 17 function Plus -> Plus | Times -> Times | Eq -> Eq | Lt -> Gt
mike@0 18 | Gt -> Lt | Leq -> Geq | Geq -> Leq | Neq -> Neq
mike@0 19 | And -> And | Or -> Or
mike@0 20 | _ -> raise Not_found
mike@0 21
mike@0 22 (* |is_const| -- test if expression is a constant *)
mike@0 23 let is_const = function <CONST a> -> true | _ -> false
mike@0 24
mike@0 25 (* |simp| -- simplify an expression tree at the root *)
mike@0 26 let rec simp t =
mike@0 27 match t with
mike@0 28 (* Constant folding *)
mike@0 29 <BINOP w, <CONST a>, <CONST b>> ->
mike@0 30 <CONST (do_binop w a b)>
mike@0 31 | <MONOP w, <CONST a>> ->
mike@0 32 <CONST (do_monop w a)>
mike@0 33
mike@0 34 (* Static bound checks *)
mike@0 35 | <BOUND, <CONST k>, <CONST b>> ->
mike@0 36 if 0 <= k && k < b then <CONST k> else t
mike@0 37
mike@0 38 (* Simplifications -- mainly directed at addressing calculations *)
mike@0 39 | <BINOP Plus, t1, <CONST a>> when a < 0 ->
mike@0 40 <BINOP Minus, t1, <CONST (-a)>>
mike@0 41 | <BINOP Minus, t1, <CONST a>> when a < 0 ->
mike@0 42 <BINOP Plus, t1, <CONST (-a)>>
mike@0 43
mike@0 44 | <OFFSET, <LOCAL a>, <CONST b>> ->
mike@0 45 <LOCAL (a+b)>
mike@0 46 | <OFFSET, <OFFSET, t1, <CONST a>>, <CONST b>> ->
mike@0 47 simp <OFFSET, t1, <CONST (a+b)>>
mike@0 48 | <OFFSET, t1, <CONST 0>> ->
mike@0 49 t1
mike@0 50 | <BINOP Times, <BINOP Times, t1, <CONST a>>, <CONST b>> ->
mike@0 51 simp <BINOP Times, t1, <CONST (a * b)>>
mike@0 52 | <BINOP Times, <BINOP Plus, t1, <CONST a>>, <CONST b>> ->
mike@0 53 simp <BINOP Plus,
mike@0 54 simp <BINOP Times, t1, <CONST b>>,
mike@0 55 <CONST (a*b)>>
mike@0 56 | <BINOP Times, <BINOP Minus, t1, <CONST a>>, <CONST b>> ->
mike@0 57 simp <BINOP Minus,
mike@0 58 simp <BINOP Times, t1, <CONST b>>,
mike@0 59 <CONST (a*b)>>
mike@0 60 | <OFFSET, t1, <BINOP Plus, t2, t3>> ->
mike@0 61 simp <OFFSET, simp <OFFSET, t1, t2>, t3>
mike@0 62 | <OFFSET, t1, <BINOP Minus, t2, <CONST n>>> ->
mike@0 63 simp <OFFSET, simp <OFFSET, t1, t2>, <CONST (-n)>>
mike@0 64 | <BINOP Times, t1, <CONST 1>> -> t1
mike@0 65 | <BINOP Times, t1, <CONST n>> when n > 0 ->
mike@0 66 (try
mike@0 67 let k = exact_log2 n in
mike@0 68 <BINOP Lsl, t1, <CONST k>>
mike@0 69 with Not_found -> t)
mike@0 70 | <BINOP Plus, t1, <CONST 0>> -> t1
mike@0 71 | <BINOP Minus, t1, <CONST 0>> -> t1
mike@0 72
mike@0 73 (* Swap operands to put constant on right *)
mike@0 74 | <BINOP w, <CONST a>, t2> ->
mike@0 75 if is_const t2 || not (Util.can swap w) then t else
mike@0 76 simp <BINOP (swap w), t2, <CONST a>>
mike@0 77 | <JUMPC (w, lab), <CONST a>, t2> ->
mike@0 78 if is_const t2 then t else
mike@0 79 simp <JUMPC (swap w, lab), t2, <CONST a>>
mike@0 80
mike@0 81 | _ -> t
mike@0 82
mike@0 83 (* |simplify| -- recursively simplify an expression *)
mike@0 84 let rec simplify <x, @ts> = simp <x, @(List.map simplify ts)>
mike@0 85
mike@0 86 (* |optimise| -- simplify a procedure body *)
mike@0 87 let optimise prog =
mike@0 88 List.map simplify prog
mike@0 89