forked from CakeML/cakeml
-
Notifications
You must be signed in to change notification settings - Fork 0
/
icing_rewriterScript.sml
141 lines (132 loc) · 4.5 KB
/
icing_rewriterScript.sml
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
140
141
(*
Implementation of the source to source floating-point rewriter
This file defines the basic rewriter, used by the optimisation pass later.
Correctness proofs are in icing_rewriterProofsScript.
*)
open bossLib fpValTreeTheory pureExpsTheory;
open preamble;
val _ = new_theory "icing_rewriter";
val _ = monadsyntax.enable_monadsyntax();
val _ = List.app monadsyntax.enable_monad ["option"];
(* matching function for expressions *)
Definition matchesFPexp_def:
(matchesFPexp (Word w1) e s =
case e of
| App FpFromWord [Lit (Word64 w2)] =>
if (w1 = w2) then SOME s else NONE
| _ => NONE) /\
(matchesFPexp (PatVar n) e s =
case substLookup s n of
| SOME e1 => if e1 = e then SOME s else NONE
| NONE => SOME (substAdd n e s)) /\
(matchesFPexp (Unop op1 p1) e s =
case e of
| App (FP_uop op2) [e1] =>
(if (op1 = op2)
then matchesFPexp p1 e1 s
else NONE)
| _ => NONE) /\
(matchesFPexp (Binop op1 p1 p2) e s =
case e of
| App (FP_bop op2) [e1;e2] =>
(if (op1 = op2)
then
(case matchesFPexp p1 e1 s of
| NONE => NONE
| SOME s1 => matchesFPexp p2 e2 s1)
else NONE)
| _ => NONE) /\
(matchesFPexp (Terop op1 p1 p2 p3) e s =
case e of
| App (FP_top op2) [e1;e2;e3] =>
(if (op1 = op2)
then
(case matchesFPexp p1 e1 s of
| NONE => NONE
| SOME s1 =>
(case matchesFPexp p2 e2 s1 of
| NONE => NONE
| SOME s2 => matchesFPexp p3 e3 s2))
else NONE)
| _ => NONE) ∧
(matchesFPexp (Cmp cmp1 p1 p2) e s =
case e of
| App (FP_cmp cmp2) [e1; e2] =>
(if (cmp1 = cmp2) then
(case matchesFPexp p1 e1 s of
| NONE => NONE
| SOME s1 => matchesFPexp p2 e2 s1)
else NONE)
| _ => NONE) ∧
(matchesFPexp (Optimise sc1 p1) e s = NONE)
End
(* Instantiate a given fp_pattern with a substitution into an expression *)
Definition appFPexp_def:
appFPexp (Word w) s = SOME (App FpFromWord [Lit (Word64 w)]) /\
appFPexp (PatVar n) s = substLookup s n /\
appFPexp (Unop u p) s = (do e <- appFPexp p s; return (App (FP_uop u) [e]); od) /\
appFPexp (Binop op p1 p2) s =
(case appFPexp p1 s of
| NONE => NONE
| SOME e1 =>
(case appFPexp p2 s of
| NONE => NONE
| SOME e2 => SOME (App (FP_bop op) [e1; e2]))) /\
appFPexp (Terop op p1 p2 p3) s =
(case appFPexp p1 s of
| NONE => NONE
| SOME e1 =>
(case appFPexp p2 s of
| NONE => NONE
| SOME e2 =>
(case appFPexp p3 s of
| NONE => NONE
| SOME e3 => SOME (App (FP_top op) [e1; e2; e3])))) /\
appFPexp (Cmp cmp p1 p2) s =
(case appFPexp p1 s of
| NONE => NONE
| SOME e1 =>
(case appFPexp p2 s of
| NONE => NONE
| SOME e2 => SOME (App (FP_cmp cmp) [e1; e2]))) /\
appFPexp (Optimise sc p) s = NONE
End
Definition isFpArithPat_def:
isFpArithPat (Word w) = T ∧
isFpArithPat (PatVar n) = T ∧
isFpArithPat (Unop u p) = isFpArithPat p ∧
isFpArithPat (Binop b p1 p2) = (isFpArithPat p1 ∧ isFpArithPat p2) ∧
isFpArithPat (Terop t p1 p2 p3) =
(isFpArithPat p1 ∧ isFpArithPat p2 ∧ isFpArithPat p3) ∧
isFpArithPat (Cmp _ _ _) = F ∧
isFpArithPat (Optimise _ p) = isFpArithPat p
End
Definition isFpArithExp_def:
isFpArithExp (Var x) = T ∧
isFpArithExp (App FpFromWord [Lit (Word64 w)]) = T ∧
isFpArithExp (App (FP_uop _) exps) = (LENGTH exps = 1 ∧ isFpArithExpList exps) ∧
isFpArithExp (App (FP_bop _) exps) = (LENGTH exps = 2 ∧ isFpArithExpList exps) ∧
isFpArithExp (App (FP_top _) exps) = (LENGTH exps = 3 ∧ isFpArithExpList exps) ∧
(* isFpArithExp (Let x e1 e2) = (isFpArithExp e1 ∧ isFpArithExp e2) ∧ *)
isFpArithExp _ = F ∧
isFpArithExpList [] = T ∧
isFpArithExpList (e1 :: es) = (isFpArithExp e1 ∧ isFpArithExpList es)
Termination
wf_rel_tac ‘measure (λ x. case x of |INR exps => exp6_size exps |INL e => exp_size e)’
End
(* rewriteExp: Recursive, expression rewriting function applying all rewrites that match.
A non-matching rewrite is silently ignored *)
Definition rewriteFPexp_def:
rewriteFPexp ([]:fp_rw list) (e:exp) = e /\
rewriteFPexp ((lhs,rhs)::rwtl) e =
if (isPureExp e ∧ isFpArithPat lhs ∧ isFpArithPat rhs ∧ isFpArithExp e)
then
(case matchesFPexp lhs e [] of
| SOME subst =>
(case appFPexp rhs subst of
| SOME e_opt => rewriteFPexp rwtl e_opt
| NONE => rewriteFPexp rwtl e)
| NONE => rewriteFPexp rwtl e)
else e
End
val _ = export_theory ();