source: src/ASM/Assembly.ma @ 2327

Last change on this file since 2327 was 2316, checked in by boender, 7 years ago
  • committed temporary version: true version has to wait until I recuperate my hard disk
File size: 48.2 KB
Line 
1include "ASM/ASM.ma".
2include "ASM/Arithmetic.ma".
3include "ASM/Fetch.ma".
4include "ASM/Status.ma".
5include alias "basics/logic.ma".
6include alias "arithmetics/nat.ma".
7include "utilities/extralib.ma".
8
9(**************************************** START OF POLICY ABSTRACTION ********************)
10
11(* definition of & operations on jump length *)
12inductive jump_length: Type[0] ≝
13  | short_jump: jump_length
14  | absolute_jump: jump_length
15  | long_jump: jump_length.
16 
17(* Functions that define the conditions under which jumps are possible *)
18definition short_jump_cond: Word → Word → (*pseudo_instruction →*)
19  bool × (BitVector 8) ≝
20  λpc_plus_jmp_length.λaddr.(*λinstr.*)
21  let 〈result, flags〉 ≝ sub_16_with_carry addr pc_plus_jmp_length false in
22  let 〈upper, lower〉 ≝ vsplit ? 9 7 result in
23    if get_index' ? 2 0 flags then
24      〈eq_bv 9 upper [[true;true;true;true;true;true;true;true;true]], true:::lower〉
25    else
26      〈eq_bv 9 upper (zero …), false:::lower〉.
27 
28definition absolute_jump_cond: Word → Word → (*pseudo_instruction →*)
29  bool × (BitVector 11) ≝
30  λpc_plus_jmp_length.λaddr.(*λinstr.*)
31  let 〈fst_5_addr, rest_addr〉 ≝ vsplit bool 5 11 addr in
32  let 〈fst_5_pc, rest_pc〉 ≝ vsplit bool 5 11 pc_plus_jmp_length in
33  〈eq_bv 5 fst_5_addr fst_5_pc, rest_addr〉.
34
35definition assembly_preinstruction ≝
36  λA: Type[0].
37  λaddr_of: A → Byte. (* relative *)
38  λpre: preinstruction A.
39  match pre with
40  [ ADD addr1 addr2 ⇒
41     match addr2 return λx. bool_to_Prop (is_in ? [[registr;direct;indirect;data]] x) → ? with
42      [ REGISTER r ⇒ λ_.[ ([[false;false;true;false;true]]) @@ r ]
43      | DIRECT b1 ⇒ λ_.[ ([[false;false;true;false;false;true;false;true]]); b1 ]
44      | INDIRECT i1 ⇒ λ_. [ ([[false;false;true;false;false;true;true;i1]]) ]
45      | DATA b1 ⇒ λ_. [ ([[false;false;true;false;false;true;false;false]]) ; b1 ]
46      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
47  | ADDC addr1 addr2 ⇒
48     match addr2 return λx. bool_to_Prop (is_in ? [[registr;direct;indirect;data]] x) → ? with
49      [ REGISTER r ⇒ λ_.[ ([[false;false;true;true;true]]) @@ r ]
50      | DIRECT b1 ⇒ λ_.[ ([[false;false;true;true;false;true;false;true]]); b1 ]
51      | INDIRECT i1 ⇒ λ_. [ ([[false;false;true;true;false;true;true;i1]]) ]
52      | DATA b1 ⇒ λ_. [ ([[false;false;true;true;false;true;false;false]]) ; b1 ]
53      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
54  | ANL addrs ⇒
55     match addrs with
56      [ inl addrs ⇒ match addrs with
57         [ inl addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
58           match addr2 return λx. bool_to_Prop (is_in ? [[registr;direct;indirect;data]] x) → ? with
59            [ REGISTER r ⇒ λ_.[ ([[false;true;false;true;true]]) @@ r ]
60            | DIRECT b1 ⇒ λ_.[ ([[false;true;false;true;false;true;false;true]]); b1 ]
61            | INDIRECT i1 ⇒ λ_. [ ([[false;true;false;true;false;true;true;i1]]) ]
62            | DATA b1 ⇒ λ_. [ ([[false;true;false;true;false;true;false;false]]) ; b1 ]
63            | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
64         | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
65            let b1 ≝
66             match addr1 return λx. bool_to_Prop (is_in ? [[direct]] x) → ? with
67              [ DIRECT b1 ⇒ λ_.b1
68              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1) in
69            match addr2 return λx. bool_to_Prop (is_in ? [[acc_a;data]] x) → ? with
70             [ ACC_A ⇒ λ_.[ ([[false;true;false;true;false;false;true;false]]) ; b1 ]
71             | DATA b2 ⇒ λ_. [ ([[false;true;false;true;false;false;true;true]]) ; b1 ; b2 ]
72             | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
73         ]
74      | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
75         match addr2 return λx. bool_to_Prop (is_in ? [[bit_addr;n_bit_addr]] x) → ? with
76          [ BIT_ADDR b1 ⇒ λ_.[ ([[true;false;false;false;false;false;true;false]]) ; b1 ]
77          | N_BIT_ADDR b1 ⇒ λ_. [ ([[true;false;true;true;false;false;false;false]]) ; b1 ]
78          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
79  | CLR addr ⇒
80     match addr return λx. bool_to_Prop (is_in ? [[acc_a;carry;bit_addr]] x) → ? with
81      [ ACC_A ⇒ λ_.
82         [ ([[true; true; true; false; false; true; false; false]]) ]
83      | CARRY ⇒ λ_.
84         [ ([[true; true; false; false; false; false; true; true]]) ]
85      | BIT_ADDR b1 ⇒ λ_.
86         [ ([[true; true; false; false; false; false; true; false]]) ; b1 ]
87      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
88  | CPL addr ⇒
89     match addr return λx. bool_to_Prop (is_in ? [[acc_a;carry;bit_addr]] x) → ? with
90      [ ACC_A ⇒ λ_.
91         [ ([[true; true; true; true; false; true; false; false]]) ]
92      | CARRY ⇒ λ_.
93         [ ([[true; false; true; true; false; false; true; true]]) ]
94      | BIT_ADDR b1 ⇒ λ_.
95         [ ([[true; false; true; true; false; false; true; false]]) ; b1 ]
96      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
97  | DA addr ⇒
98     [ ([[true; true; false; true; false; true; false; false]]) ]
99  | DEC addr ⇒
100     match addr return λx. bool_to_Prop (is_in ? [[acc_a;registr;direct;indirect]] x) → ? with
101      [ ACC_A ⇒ λ_.
102         [ ([[false; false; false; true; false; true; false; false]]) ]
103      | REGISTER r ⇒ λ_.
104         [ ([[false; false; false; true; true]]) @@ r ]
105      | DIRECT b1 ⇒ λ_.
106         [ ([[false; false; false; true; false; true; false; true]]); b1 ]
107      | INDIRECT i1 ⇒ λ_.
108         [ ([[false; false; false; true; false; true; true; i1]]) ]
109      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
110      | DJNZ addr1 addr2 ⇒
111         let b2 ≝ addr_of addr2 in
112         match addr1 return λx. bool_to_Prop (is_in ? [[registr;direct]] x) → ? with
113          [ REGISTER r ⇒ λ_.
114             [ ([[true; true; false; true; true]]) @@ r ; b2 ]
115          | DIRECT b1 ⇒ λ_.
116             [ ([[true; true; false; true; false; true; false; true]]); b1; b2 ]
117          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)
118      | JC addr ⇒
119        let b1 ≝ addr_of addr in
120          [ ([[false; true; false; false; false; false; false; false]]); b1 ]
121      | JNC addr ⇒
122         let b1 ≝ addr_of addr in
123           [ ([[false; true; false; true; false; false; false; false]]); b1 ]
124      | JZ addr ⇒
125         let b1 ≝ addr_of addr in
126           [ ([[false; true; true; false; false; false; false; false]]); b1 ]
127      | JNZ addr ⇒
128         let b1 ≝ addr_of addr in
129           [ ([[false; true; true; true; false; false; false; false]]); b1 ]
130      | JB addr1 addr2 ⇒
131         let b2 ≝ addr_of addr2 in
132         match addr1 return λx. bool_to_Prop (is_in ? [[bit_addr]] x) → ? with
133          [ BIT_ADDR b1 ⇒ λ_.
134             [ ([[false; false; true; false; false; false; false; false]]); b1; b2 ]
135          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)
136      | JNB addr1 addr2 ⇒
137         let b2 ≝ addr_of addr2 in
138         match addr1 return λx. bool_to_Prop (is_in ? [[bit_addr]] x) → ? with
139          [ BIT_ADDR b1 ⇒ λ_.
140             [ ([[false; false; true; true; false; false; false; false]]); b1; b2 ]
141          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)
142      | JBC addr1 addr2 ⇒
143         let b2 ≝ addr_of addr2 in
144         match addr1 return λx. bool_to_Prop (is_in ? [[bit_addr]] x) → ? with
145          [ BIT_ADDR b1 ⇒ λ_.
146             [ ([[false; false; false; true; false; false; false; false]]); b1; b2 ]
147          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)
148      | CJNE addrs addr3 ⇒
149         let b3 ≝ addr_of addr3 in
150         match addrs with
151          [ inl addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
152             match addr2 return λx. bool_to_Prop (is_in ? [[direct;data]] x) → ? with
153              [ DIRECT b1 ⇒ λ_.
154                 [ ([[true; false; true; true; false; true; false; true]]); b1; b3 ]
155              | DATA b1 ⇒ λ_.
156                 [ ([[true; false; true; true; false; true; false; false]]); b1; b3 ]
157              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
158          | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
159             let b2 ≝
160              match addr2 return λx. bool_to_Prop (is_in ? [[data]] x) → ? with
161               [ DATA b2 ⇒ λ_. b2
162               | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2) in
163             match addr1 return λx. bool_to_Prop (is_in ? [[registr;indirect]] x) → list Byte with
164              [ REGISTER r ⇒ λ_.
165                 [ ([[true; false; true; true; true]]) @@ r; b2; b3 ]
166              | INDIRECT i1 ⇒ λ_.
167                 [ ([[true; false; true; true; false; true; true; i1]]); b2; b3 ]
168              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)
169         ]
170  | DIV addr1 addr2 ⇒
171     [ ([[true;false;false;false;false;true;false;false]]) ]
172  | INC addr ⇒
173     match addr return λx. bool_to_Prop (is_in ? [[acc_a;registr;direct;indirect;dptr]] x) → ? with
174      [ ACC_A ⇒ λ_.
175         [ ([[false;false;false;false;false;true;false;false]]) ]         
176      | REGISTER r ⇒ λ_.
177         [ ([[false;false;false;false;true]]) @@ r ]
178      | DIRECT b1 ⇒ λ_.
179         [ ([[false; false; false; false; false; true; false; true]]); b1 ]
180      | INDIRECT i1 ⇒ λ_.
181        [ ([[false; false; false; false; false; true; true; i1]]) ]
182      | DPTR ⇒ λ_.
183        [ ([[true;false;true;false;false;false;true;true]]) ]
184      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
185  | MOV addrs ⇒
186     match addrs with
187      [ inl addrs ⇒
188         match addrs with
189          [ inl addrs ⇒
190             match addrs with
191              [ inl addrs ⇒
192                 match addrs with
193                  [ inl addrs ⇒
194                     match addrs with
195                      [ inl addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
196                         match addr2 return λx. bool_to_Prop (is_in ? [[registr;direct;indirect;data]] x) → ? with
197                          [ REGISTER r ⇒ λ_.[ ([[true;true;true;false;true]]) @@ r ]
198                          | DIRECT b1 ⇒ λ_.[ ([[true;true;true;false;false;true;false;true]]); b1 ]
199                          | INDIRECT i1 ⇒ λ_. [ ([[true;true;true;false;false;true;true;i1]]) ]
200                          | DATA b1 ⇒ λ_. [ ([[false;true;true;true;false;true;false;false]]) ; b1 ]
201                          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
202                      | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
203                         match addr1 return λx. bool_to_Prop (is_in ? [[registr;indirect]] x) → ? with
204                          [ REGISTER r ⇒ λ_.
205                             match addr2 return λx. bool_to_Prop (is_in ? [[acc_a;direct;data]] x) → ? with
206                              [ ACC_A ⇒ λ_.[ ([[true;true;true;true;true]]) @@ r ]
207                              | DIRECT b1 ⇒ λ_.[ ([[true;false;true;false;true]]) @@ r; b1 ]
208                              | DATA b1 ⇒ λ_. [ ([[false;true;true;true;true]]) @@ r; b1 ]
209                              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
210                          | INDIRECT i1 ⇒ λ_.
211                             match addr2 return λx. bool_to_Prop (is_in ? [[acc_a;direct;data]] x) → ? with
212                              [ ACC_A ⇒ λ_.[ ([[true;true;true;true;false;true;true;i1]]) ]
213                              | DIRECT b1 ⇒ λ_.[ ([[true;false;true;false;false;true;true;i1]]); b1 ]
214                              | DATA b1 ⇒ λ_. [ ([[false;true;true;true;false;true;true;i1]]) ; b1 ]
215                              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
216                          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)]
217                  | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
218                     let b1 ≝
219                      match addr1 return λx. bool_to_Prop (is_in ? [[direct]] x) → ? with
220                       [ DIRECT b1 ⇒ λ_. b1
221                       | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1) in
222                     match addr2 return λx. bool_to_Prop (is_in ? [[acc_a;registr;direct;indirect;data]] x) → ? with
223                      [ ACC_A ⇒ λ_.[ ([[true;true;true;true;false;true;false;true]]); b1]
224                      | REGISTER r ⇒ λ_.[ ([[true;false;false;false;true]]) @@ r; b1 ]
225                      | DIRECT b2 ⇒ λ_.[ ([[true;false;false;false;false;true;false;true]]); b1; b2 ]
226                      | INDIRECT i1 ⇒ λ_. [ ([[true;false;false;false;false;true;true;i1]]); b1 ]
227                      | DATA b2 ⇒ λ_. [ ([[false;true;true;true;false;true;false;true]]); b1; b2 ]
228                      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
229              | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
230                 match addr2 return λx. bool_to_Prop (is_in ? [[data16]] x) → ? with
231                  [ DATA16 w ⇒ λ_.
232                     let b1_b2 ≝ vsplit ? 8 8 w in
233                     let b1 ≝ \fst b1_b2 in
234                     let b2 ≝ \snd b1_b2 in
235                      [ ([[true;false;false;true;false;false;false;false]]); b1; b2]
236                  | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
237          | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
238             match addr2 return λx. bool_to_Prop (is_in ? [[bit_addr]] x) → ? with
239              [ BIT_ADDR b1 ⇒ λ_.
240                 [ ([[true;false;true;false;false;false;true;false]]); b1 ]
241              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
242      | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
243         match addr1 return λx. bool_to_Prop (is_in ? [[bit_addr]] x) → ? with
244          [ BIT_ADDR b1 ⇒ λ_.
245             [ ([[true;false;false;true;false;false;true;false]]); b1 ]
246          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)]
247  | MOVX addrs ⇒
248     match addrs with
249      [ inl addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
250         match addr2 return λx. bool_to_Prop (is_in ? [[ext_indirect;ext_indirect_dptr]] x) → ? with
251          [ EXT_INDIRECT i1 ⇒ λ_.
252             [ ([[true;true;true;false;false;false;true;i1]]) ]
253          | EXT_INDIRECT_DPTR ⇒ λ_.
254             [ ([[true;true;true;false;false;false;false;false]]) ]
255          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
256      | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
257         match addr1 return λx. bool_to_Prop (is_in ? [[ext_indirect;ext_indirect_dptr]] x) → ? with
258          [ EXT_INDIRECT i1 ⇒ λ_.
259             [ ([[true;true;true;true;false;false;true;i1]]) ]
260          | EXT_INDIRECT_DPTR ⇒ λ_.
261             [ ([[true;true;true;true;false;false;false;false]]) ]
262          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1)]
263  | MUL addr1 addr2 ⇒
264     [ ([[true;false;true;false;false;true;false;false]]) ]
265  | NOP ⇒
266     [ ([[false;false;false;false;false;false;false;false]]) ]
267  | ORL addrs ⇒
268     match addrs with
269      [ inl addrs ⇒
270         match addrs with
271          [ inl addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
272             match addr2 return λx. bool_to_Prop (is_in ? [[registr;data;direct;indirect]] x) → ? with
273             [ REGISTER r ⇒ λ_.[ ([[false;true;false;false;true]]) @@ r ]
274             | DIRECT b1 ⇒ λ_.[ ([[false;true;false;false;false;true;false;true]]); b1 ]
275             | INDIRECT i1 ⇒ λ_. [ ([[false;true;false;false;false;true;true;i1]]) ]
276             | DATA b1 ⇒ λ_. [ ([[false;true;false;false;false;true;false;false]]) ; b1 ]
277             | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
278          | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
279            let b1 ≝
280              match addr1 return λx. bool_to_Prop (is_in ? [[direct]] x) → ? with
281               [ DIRECT b1 ⇒ λ_. b1
282               | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1) in
283             match addr2 return λx. bool_to_Prop (is_in ? [[acc_a;data]] x) → ? with
284              [ ACC_A ⇒ λ_.
285                 [ ([[false;true;false;false;false;false;true;false]]); b1 ]
286              | DATA b2 ⇒ λ_.
287                 [ ([[false;true;false;false;false;false;true;true]]); b1; b2 ]
288              | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
289      | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in     
290         match addr2 return λx. bool_to_Prop (is_in ? [[bit_addr;n_bit_addr]] x) → ? with
291          [ BIT_ADDR b1 ⇒ λ_.
292             [ ([[false;true;true;true;false;false;true;false]]); b1 ]
293          | N_BIT_ADDR b1 ⇒ λ_.
294             [ ([[true;false;true;false;false;false;false;false]]); b1 ]
295          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
296  | POP addr ⇒
297     match addr return λx. bool_to_Prop (is_in ? [[direct]] x) → ? with
298      [ DIRECT b1 ⇒ λ_.
299         [ ([[true;true;false;true;false;false;false;false]]) ; b1 ]
300      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
301  | PUSH addr ⇒
302     match addr return λx. bool_to_Prop (is_in ? [[direct]] x) → ? with
303      [ DIRECT b1 ⇒ λ_.
304         [ ([[true;true;false;false;false;false;false;false]]) ; b1 ]
305      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
306  | RET ⇒
307     [ ([[false;false;true;false;false;false;true;false]]) ]
308  | RETI ⇒
309     [ ([[false;false;true;true;false;false;true;false]]) ]
310  | RL addr ⇒
311     [ ([[false;false;true;false;false;false;true;true]]) ]
312  | RLC addr ⇒
313     [ ([[false;false;true;true;false;false;true;true]]) ]
314  | RR addr ⇒
315     [ ([[false;false;false;false;false;false;true;true]]) ]
316  | RRC addr ⇒
317     [ ([[false;false;false;true;false;false;true;true]]) ]
318  | SETB addr ⇒     
319     match addr return λx. bool_to_Prop (is_in ? [[carry;bit_addr]] x) → ? with
320      [ CARRY ⇒ λ_.
321         [ ([[true;true;false;true;false;false;true;true]]) ]
322      | BIT_ADDR b1 ⇒ λ_.
323         [ ([[true;true;false;true;false;false;true;false]]); b1 ]
324      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
325  | SUBB addr1 addr2 ⇒
326     match addr2 return λx. bool_to_Prop (is_in ? [[registr;direct;indirect;data]] x) → ? with
327      [ REGISTER r ⇒ λ_.
328         [ ([[true;false;false;true;true]]) @@ r ]
329      | DIRECT b1 ⇒ λ_.
330         [ ([[true;false;false;true;false;true;false;true]]); b1]
331      | INDIRECT i1 ⇒ λ_.
332         [ ([[true;false;false;true;false;true;true;i1]]) ]
333      | DATA b1 ⇒ λ_.
334         [ ([[true;false;false;true;false;true;false;false]]); b1]
335      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
336  | SWAP addr ⇒
337     [ ([[true;true;false;false;false;true;false;false]]) ]
338  | XCH addr1 addr2 ⇒
339     match addr2 return λx. bool_to_Prop (is_in ? [[registr;direct;indirect]] x) → ? with
340      [ REGISTER r ⇒ λ_.
341         [ ([[true;true;false;false;true]]) @@ r ]
342      | DIRECT b1 ⇒ λ_.
343         [ ([[true;true;false;false;false;true;false;true]]); b1]
344      | INDIRECT i1 ⇒ λ_.
345         [ ([[true;true;false;false;false;true;true;i1]]) ]
346      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
347  | XCHD addr1 addr2 ⇒
348     match addr2 return λx. bool_to_Prop (is_in ? [[indirect]] x) → ? with
349      [ INDIRECT i1 ⇒ λ_.
350         [ ([[true;true;false;true;false;true;true;i1]]) ]
351      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
352  | XRL addrs ⇒
353     match addrs with
354      [ inl addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
355         match addr2 return λx. bool_to_Prop (is_in ? [[data;registr;direct;indirect]] x) → ? with
356          [ REGISTER r ⇒ λ_.
357             [ ([[false;true;true;false;true]]) @@ r ]
358          | DIRECT b1 ⇒ λ_.
359             [ ([[false;true;true;false;false;true;false;true]]); b1]
360          | INDIRECT i1 ⇒ λ_.
361             [ ([[false;true;true;false;false;true;true;i1]]) ]
362          | DATA b1 ⇒ λ_.
363             [ ([[false;true;true;false;false;true;false;false]]); b1]
364          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
365      | inr addrs ⇒ let 〈addr1,addr2〉 ≝ addrs in
366         let b1 ≝
367          match addr1 return λx. bool_to_Prop (is_in ? [[direct]] x) → ? with
368           [ DIRECT b1 ⇒ λ_. b1
369           | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr1) in
370         match addr2 return λx. bool_to_Prop (is_in ? [[acc_a;data]] x) → ? with
371          [ ACC_A ⇒ λ_.
372             [ ([[false;true;true;false;false;false;true;false]]); b1 ]         
373          | DATA b2 ⇒ λ_.
374             [ ([[false;true;true;false;false;false;true;true]]); b1; b2 ]
375          | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)]
376       ].
377
378definition assembly1 ≝
379 λi: instruction.
380 match i with
381  [ ACALL addr ⇒
382     match addr return λx. bool_to_Prop (is_in ? [[addr11]] x) → ? with
383      [ ADDR11 w ⇒ λ_.
384         let v1_v2 ≝ vsplit ? 3 8 w in
385         let v1 ≝ \fst v1_v2 in
386         let v2 ≝ \snd v1_v2 in
387          [ (v1 @@ [[true; false; false; false; true]]) ; v2 ]
388      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
389  | AJMP addr ⇒
390     match addr return λx. bool_to_Prop (is_in ? [[addr11]] x) → ? with
391      [ ADDR11 w ⇒ λ_.
392         let v1_v2 ≝ vsplit ? 3 8 w in
393         let v1 ≝ \fst v1_v2 in
394         let v2 ≝ \snd v1_v2 in
395          [ (v1 @@ [[false; false; false; false; true]]) ; v2 ]
396      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
397  | JMP adptr ⇒
398     [ ([[false;true;true;true;false;false;true;true]]) ]
399  | LCALL addr ⇒
400     match addr return λx. bool_to_Prop (is_in ? [[addr16]] x) → ? with
401      [ ADDR16 w ⇒ λ_.
402         let b1_b2 ≝ vsplit ? 8 8 w in
403         let b1 ≝ \fst b1_b2 in
404         let b2 ≝ \snd b1_b2 in
405          [ ([[false;false;false;true;false;false;true;false]]); b1; b2 ]         
406      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
407  | LJMP addr ⇒
408     match addr return λx. bool_to_Prop (is_in ? [[addr16]] x) → ? with
409      [ ADDR16 w ⇒ λ_.
410         let b1_b2 ≝ vsplit ? 8 8 w in
411         let b1 ≝ \fst b1_b2 in
412         let b2 ≝ \snd b1_b2 in
413          [ ([[false;false;false;false;false;false;true;false]]); b1; b2 ]         
414      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
415  | MOVC addr1 addr2 ⇒
416     match addr2 return λx. bool_to_Prop (is_in ? [[acc_dptr;acc_pc]] x) → ? with
417      [ ACC_DPTR ⇒ λ_.
418         [ ([[true;false;false;true;false;false;true;true]]) ]
419      | ACC_PC ⇒ λ_.
420         [ ([[true;false;false;false;false;false;true;true]]) ]
421      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr2)
422  | SJMP addr ⇒
423     match addr return λx. bool_to_Prop (is_in ? [[relative]] x) → ? with
424      [ RELATIVE b1 ⇒ λ_.
425         [ ([[true;false;false;false;false;false;false;false]]); b1 ]
426      | _ ⇒ λK.match K in False with [ ] ] (subaddressing_modein … addr)
427  | RealInstruction instr ⇒
428    assembly_preinstruction [[ relative ]]
429      (λx.
430        match x return λs. bool_to_Prop (is_in ? [[ relative ]] s) → ? with
431        [ RELATIVE r ⇒ λ_. r
432        | _ ⇒ λabsd. ⊥
433        ] (subaddressing_modein … x)) instr
434  ].
435  cases absd
436qed.
437
438(* XXX: pc_plus_sjmp_length used to be just sigma of ppc.  This is incorrect
439        as relative lengths are computed from the *end* of the SJMP, not from
440        the beginning.
441*)
442definition expand_relative_jump_internal:
443 ∀lookup_labels:Identifier → Word.∀sigma:Word → Word.∀policy:Word → bool.
444 Identifier → Word → ([[relative]] → preinstruction [[relative]]) →
445 list instruction
446 ≝
447  λlookup_labels.λsigma.λpolicy.λlbl.λppc,i.
448   let lookup_address ≝ sigma (lookup_labels lbl) in
449   let pc_plus_jmp_length ≝ sigma (add … ppc (bitvector_of_nat … 1)) in
450   let 〈sj_possible, disp〉 ≝ short_jump_cond pc_plus_jmp_length lookup_address in
451   if sj_possible ∧ ¬(policy ppc)
452   then
453     let address ≝ RELATIVE disp in
454       [ RealInstruction (i address) ]
455   else
456    [ RealInstruction (i (RELATIVE (bitvector_of_nat ? 2)));
457      SJMP (RELATIVE (bitvector_of_nat ? 3)); (* LJMP size? *)
458      LJMP (ADDR16 lookup_address)
459    ].
460  %
461qed.
462
463definition expand_relative_jump:
464  ∀lookup_labels.∀sigma.∀policy.
465  Word → (*jump_length →*)
466  preinstruction Identifier → list instruction ≝
467  λlookup_labels: Identifier → Word.
468  λsigma:Word → Word.
469  λpolicy:Word → bool.
470  λppc: Word.
471  (*λjmp_len: jump_length.*)
472  λi: preinstruction Identifier.
473  (*let rel_jmp ≝ RELATIVE (bitvector_of_nat ? 2) in*)
474  match i with
475  [ JC jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JC ?)
476  | JNC jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JNC ?)
477  | JB baddr jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JB ? baddr)
478  | JZ jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JZ ?)
479  | JNZ jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JNZ ?)
480  | JBC baddr jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JBC ? baddr)
481  | JNB baddr jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (JNB ? baddr)
482  | CJNE addr jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (CJNE ? addr)
483  | DJNZ addr jmp ⇒ expand_relative_jump_internal lookup_labels sigma policy jmp ppc (DJNZ ? addr)
484  | ADD arg1 arg2 ⇒ [ ADD ? arg1 arg2 ]
485  | ADDC arg1 arg2 ⇒ [ ADDC ? arg1 arg2 ]
486  | SUBB arg1 arg2 ⇒ [ SUBB ? arg1 arg2 ]
487  | INC arg ⇒ [ INC ? arg ]
488  | DEC arg ⇒ [ DEC ? arg ]
489  | MUL arg1 arg2 ⇒ [ MUL ? arg1 arg2 ]
490  | DIV arg1 arg2 ⇒ [ DIV ? arg1 arg2 ]
491  | DA arg ⇒ [ DA ? arg ]
492  | ANL arg ⇒ [ ANL ? arg ]
493  | ORL arg ⇒ [ ORL ? arg ]
494  | XRL arg ⇒ [ XRL ? arg ]
495  | CLR arg ⇒ [ CLR ? arg ]
496  | CPL arg ⇒ [ CPL ? arg ]
497  | RL arg ⇒ [ RL ? arg ]
498  | RR arg ⇒ [ RR ? arg ]
499  | RLC arg ⇒ [ RLC ? arg ]
500  | RRC arg ⇒ [ RRC ? arg ]
501  | SWAP arg ⇒ [ SWAP ? arg ]
502  | MOV arg ⇒ [ MOV ? arg ]
503  | MOVX arg ⇒ [ MOVX ? arg ]
504  | SETB arg ⇒ [ SETB ? arg ]
505  | PUSH arg ⇒ [ PUSH ? arg ]
506  | POP arg ⇒ [ POP ? arg ]
507  | XCH arg1 arg2 ⇒ [ XCH ? arg1 arg2 ]
508  | XCHD arg1 arg2 ⇒ [ XCHD ? arg1 arg2 ]
509  | RET ⇒ [ RET ? ]
510  | RETI ⇒ [ RETI ? ]
511  | NOP ⇒ [ RealInstruction (NOP ?) ]
512  ].
513
514definition expand_pseudo_instruction:
515    ∀lookup_labels.
516    ∀sigma: Word → Word.
517    ∀policy: Word → bool.
518      Word → ? → pseudo_instruction → list instruction ≝
519  λlookup_labels: Identifier → Word.
520  λsigma: Word → Word.
521  λpolicy: Word → bool.
522  λppc.
523  λlookup_datalabels:Identifier → Word.
524  λi.
525  match i with
526  [ Cost cost ⇒ [ ]
527  | Comment comment ⇒ [ ]
528  | Call call ⇒
529    let pc_plus_jmp_length ≝ sigma (add … ppc (bitvector_of_nat … 1)) in
530    let lookup_address ≝ sigma (lookup_labels call) in
531    let 〈mj_possible, disp〉 ≝ absolute_jump_cond pc_plus_jmp_length lookup_address in
532    let do_a_long ≝ policy ppc in
533    if mj_possible ∧ ¬ do_a_long then
534      let address ≝ ADDR11 disp in
535        [ ACALL address ]
536    else
537      let address ≝ ADDR16 lookup_address in
538        [ LCALL address ]
539  | Mov d trgt ⇒
540    let address ≝ DATA16 (lookup_datalabels trgt) in
541      [ RealInstruction (MOV ? (inl ? ? (inl ? ? (inr ? ? 〈DPTR, address〉))))]
542  | Instruction instr ⇒ expand_relative_jump lookup_labels sigma policy ppc instr
543  | Jmp jmp ⇒
544    let pc_plus_jmp_length ≝ sigma (add … ppc (bitvector_of_nat … 1)) in
545    let do_a_long ≝ policy ppc in
546    let lookup_address ≝ sigma (lookup_labels jmp) in
547    let 〈sj_possible, disp〉 ≝ short_jump_cond pc_plus_jmp_length lookup_address in
548    if sj_possible ∧ ¬ do_a_long then
549      let address ≝ RELATIVE disp in
550        [ SJMP address ]
551    else
552      let 〈mj_possible, disp2〉 ≝ absolute_jump_cond pc_plus_jmp_length lookup_address in
553      if mj_possible ∧ ¬ do_a_long then
554        let address ≝ ADDR11 disp2 in
555          [ AJMP address ]
556      else   
557        let address ≝ ADDR16 lookup_address in
558        [ LJMP address ]
559  ].
560  %
561qed.
562 
563definition assembly_1_pseudoinstruction ≝
564  λlookup_labels.
565  λsigma: Word → Word.
566  λpolicy: Word → bool.
567  λppc: Word.
568  λlookup_datalabels.
569  λi.
570  let pseudos ≝ expand_pseudo_instruction lookup_labels sigma policy ppc lookup_datalabels i in
571  let mapped ≝ map ? ? assembly1 pseudos in
572  let flattened ≝ flatten ? mapped in
573  let pc_len ≝ length ? flattened in
574   〈pc_len, flattened〉.
575
576definition instruction_size ≝
577  λlookup_labels.
578  λlookup_datalabels.
579  λsigma: Word → Word.
580  λpolicy: Word → bool.
581  λppc.
582  λi.
583    \fst (assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels i).
584 
585(* Labels *)
586definition is_label ≝
587  λx:labelled_instruction.λl:Identifier.
588  let 〈lbl,instr〉 ≝ x in
589  match lbl with
590  [ Some l' ⇒ l' = l
591  | _       ⇒ False
592  ].
593
594lemma label_does_not_occur:
595  ∀i:ℕ.∀p:list labelled_instruction.∀l:Identifier.
596  is_label (nth i ? p 〈None ?, Comment [ ]〉) l → does_not_occur ?? l p = false.
597 #i #p #l generalize in match i; elim p
598 [ #i >nth_nil #H cases H
599 | #h #t #IH #i cases i -i
600   [ cases h #hi #hp cases hi
601     [ normalize #H cases H
602     | #l' #Heq whd in ⊢ (??%?); change with (eq_identifier ? l' l) in match (instruction_matches_identifier ????);
603       whd in Heq; >Heq
604       >eq_identifier_refl / by refl/
605     ]
606   | #i #H whd in match (does_not_occur ????);
607     whd in match (instruction_matches_identifier ????);
608     cases h #hi #hp cases hi normalize nodelta
609     [ @(IH i) @H
610     | #l' @eq_identifier_elim
611       [ normalize / by /
612       | normalize #_ @(IH i) @H
613       ]
614     ]
615   ]
616 ]
617qed.
618
619definition sigma_policy_specification ≝
620  λprogram: pseudo_assembly_program.
621  λsigma: Word → Word.
622  λpolicy: Word → bool.
623  sigma (zero …) = zero … ∧
624  let instr_list ≝ \snd program in
625  let preamble ≝ \fst program in
626  ∀ppc: Word. ∀ppc_ok: nat_of_bitvector … ppc < |instr_list|.
627    let pc ≝ sigma ppc in
628    let labels ≝ \fst (create_label_cost_map instr_list) in
629    let lookup_labels ≝ λx. bitvector_of_nat 16 (lookup_def … labels x 0) in
630    let lookup_datalabels ≝ λx. lookup_def … (construct_datalabels preamble) x (zero …) in
631    let instruction ≝ \fst (fetch_pseudo_instruction instr_list ppc ppc_ok) in
632    let next_pc ≝ sigma (add 16 ppc (bitvector_of_nat 16 1)) in
633     next_pc = add 16 pc (bitvector_of_nat … (instruction_size lookup_labels lookup_datalabels sigma policy ppc instruction))
634     ∧
635     (nat_of_bitvector … pc + instruction_size lookup_labels lookup_datalabels sigma policy ppc instruction < 2^16
636     ∨
637     (∀ppc'. ∀ppc_ok':nat_of_bitvector … ppc' < |instr_list|. nat_of_bitvector … ppc < nat_of_bitvector … ppc' →
638       let instruction' ≝ \fst (fetch_pseudo_instruction instr_list ppc' ppc_ok') in
639       instruction_size lookup_labels lookup_datalabels sigma policy ppc' instruction' = 0)
640     ∧
641     nat_of_bitvector … pc + instruction_size lookup_labels lookup_datalabels sigma policy ppc instruction = 2^16).
642
643
644lemma fst_assembly_1_pseudoinstruction_insensible_to_lookup_datalabels:
645 ∀lookup_labels,sigma,policy,ppc,pi.
646  ∀lookup_datalabels1,lookup_datalabels2.
647   \fst (assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels1 pi) =
648   \fst (assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels2 pi).
649#lookup_labels #sigma #policy #ppc #pi #lookup_datalabels1 #lookup_datalabels2
650cases pi //
651qed.
652
653lemma fst_snd_assembly_1_pseudoinstruction:
654 ∀lookup_labels,sigma,policy,ppc,pi,lookup_datalabels,len,assembled.
655   assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels pi
656   = 〈len,assembled〉 →
657    len = |assembled|.
658#lookup #sigma #policy #ppc #pi #lookup_datalabels #len #assembled
659inversion (assembly_1_pseudoinstruction ??????) #len' #assembled'
660whd in ⊢ (??%? → ?); #EQ1 #EQ2 destruct %
661qed.
662
663(* XXX: easy but tedious *)
664lemma assembly1_lt_128:
665  ∀i: instruction.
666    |(assembly1 i)| < 128.
667  cases daemon
668(* XXX: commented out as takes ages to type check
669  #i cases i
670  try (#assm1 #assm2) try #assm1
671  [8:
672    cases assm1
673    try (#assm1 #assm2) try #assm1
674    whd in match assembly1; normalize nodelta
675    whd in match assembly_preinstruction; normalize nodelta
676    try @(subaddressing_mode_elim … assm2)
677    try @(subaddressing_mode_elim … assm1) try #w try #w' normalize nodelta
678    [32:
679      cases assm1 -assm1 #assm1 normalize nodelta
680      cases assm1 #addr1 #addr2 normalize nodelta
681      [1:
682        @(subaddressing_mode_elim … addr2)
683      |2:
684        @(subaddressing_mode_elim … addr1)
685      ]
686      #w
687    |35,36,37:
688      cases assm1 -assm1 #assm1 normalize nodelta
689      [1,3:
690        cases assm1 -assm1 #assm1 normalize nodelta
691      ]
692      cases assm1 #addr1 #addr2 normalize nodelta
693      @(subaddressing_mode_elim … addr2) try #w
694    |49:
695      cases assm1 -assm1 #assm1 normalize nodelta
696      [1:
697        cases assm1 -assm1 #assm1 normalize nodelta
698        [1:
699          cases assm1 -assm1 #assm1 normalize nodelta
700          [1:
701            cases assm1 -assm1 #assm1 normalize nodelta
702            [1:
703              cases assm1 -assm1 #assm1 normalize nodelta
704            ]
705          ]
706        ]
707      ]
708      cases assm1 #addr1 #addr2 normalize nodelta
709      [1,3,4,5:
710        @(subaddressing_mode_elim … addr2) try #w
711      |*:
712        @(subaddressing_mode_elim … addr1) try #w
713        normalize nodelta
714        [1,2:
715          @(subaddressing_mode_elim … addr2) try #w
716        ]
717      ]
718    |50:
719      cases assm1 -assm1 #assm1 normalize nodelta
720      cases assm1 #addr1 #addr2 normalize nodelta
721      [1:
722        @(subaddressing_mode_elim … addr2) try #w
723      |2:
724        @(subaddressing_mode_elim … addr1) try #w
725      ]
726    ]
727    normalize repeat @le_S_S @le_O_n
728  ]
729  whd in match assembly1; normalize nodelta
730  [6:
731    normalize repeat @le_S_S @le_O_n
732  |7:
733    @(subaddressing_mode_elim … assm2) normalize repeat @le_S_S @le_O_n
734  |*:
735    @(subaddressing_mode_elim … assm1) #w normalize nodelta repeat @le_S_S @le_O_n
736  ]
737  *)
738qed.
739
740lemma assembly1_pseudoinstruction_lt_2_to_16:
741  ∀lookup_labels,sigma,policy,ppc,lookup_datalabels,pi.
742  |\snd (assembly_1_pseudoinstruction
743    lookup_labels sigma policy ppc lookup_datalabels pi)|
744   < 2^16.
745 #lookup_labels #sigma #policy #ppc #lookup_datalabels *
746[ cut (128 < 2^16) [@leb_true_to_le %] #LT
747  * whd in match (assembly_1_pseudoinstruction ??????);
748  whd in match (expand_pseudo_instruction ??????);
749  whd in match assembly_1_pseudoinstruction; normalize nodelta
750  try (#arg1 #arg2 #arg3) try (#arg1 #arg2) try #arg1
751  whd in match (expand_pseudo_instruction ??????);
752  try
753   (change with (|flatten ? [assembly1 ?]| < ?)
754    >flatten_singleton
755    @(transitive_lt … (assembly1_lt_128 ?))
756    @LT)
757  @pair_elim #x #y #_ cases x cases (policy ppc) normalize nodelta
758  try
759   (change with (|flatten ? [assembly1 ?]| < ?)
760    >flatten_singleton
761    @(transitive_lt … (assembly1_lt_128 ?))
762    @LT)
763  change with (|flatten ? [assembly1 ?; assembly1 ?; assembly1 ?]| < ?)
764  >length_flatten_cons >length_flatten_cons >length_flatten_cons <plus_n_O
765  <associative_plus @(transitive_lt … (tech_transitive_lt_3 … (2^7) ???))
766  try @assembly1_lt_128 @leb_true_to_le %
767|2,3: #msg normalize in ⊢ (?%?); //
768| #label whd in match (assembly_1_pseudoinstruction ??????);
769  whd in match (expand_pseudo_instruction ??????);
770  @pair_elim #sj_poss #disp cases (?∧?) normalize nodelta #_
771  [2: @pair_elim #x #y #_ cases (?∧?)]
772  normalize in ⊢ (?%?); //
773| #label whd in match (assembly_1_pseudoinstruction ??????);
774  whd in match (expand_pseudo_instruction ??????);
775  @pair_elim #sj_poss #disp cases (?∧?) normalize nodelta #_
776  normalize in ⊢ (?%?); //
777| #dptr #id normalize in ⊢ (?%?); //
778]
779qed.
780
781definition assembly:
782    ∀p: pseudo_assembly_program.
783    ∀sigma: Word → Word.
784    ∀policy: Word → bool.
785      Σres:list Byte × (BitVectorTrie costlabel 16).
786       sigma_policy_specification p sigma policy →
787       let 〈preamble,instr_list〉 ≝ p in
788       |instr_list| ≤ 2^16 →
789       let 〈assembled,costs〉 ≝ res in
790       |assembled| ≤ 2^16 ∧
791       (nat_of_bitvector … (sigma (bitvector_of_nat … (|instr_list|))) = |assembled| ∨
792        sigma (bitvector_of_nat … (|instr_list|)) = zero … ∧ |assembled| = 2^16) ∧
793       let 〈labels_to_ppc,ppc_to_costs〉 ≝ create_label_cost_map instr_list in
794       let datalabels ≝ construct_datalabels preamble in
795       let lookup_labels ≝ λx. bitvector_of_nat ? (lookup_def … labels_to_ppc x 0) in
796       let lookup_datalabels ≝ λx. lookup_def … datalabels x (zero ?) in
797       ∀ppc. ∀ppc_ok:nat_of_bitvector … ppc < |instr_list|.
798         let 〈pi,newppc〉 ≝ fetch_pseudo_instruction instr_list ppc ppc_ok in
799         let 〈len,assembledi〉 ≝
800          assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels pi in
801         |assembledi| ≤ |assembled| ∧
802         ∀j:nat. ∀H: j < |assembledi|. ∃K.
803          nth_safe ? j assembledi H =
804           nth_safe ? (nat_of_bitvector … (add … (sigma ppc) (bitvector_of_nat ? j)))
805            assembled K
806
807  λp.
808  λsigma.
809  λpolicy.
810  deplet 〈preamble, instr_list〉 as p_refl ≝ p in
811  deplet 〈labels_to_ppc,ppc_to_costs〉 as eq_create_label_cost_map ≝ create_label_cost_map instr_list in
812  let datalabels ≝ construct_datalabels preamble in
813  let lookup_labels ≝ λx. bitvector_of_nat ? (lookup_def … labels_to_ppc x 0) in
814  let lookup_datalabels ≝ λx. lookup_def … datalabels x (zero ?) in
815  let 〈next_pc,revcode〉 ≝ pi1 … (
816     foldl_strong
817      (option Identifier × pseudo_instruction)
818      (λpre. Σppc_code:(Word × (list Byte)).
819       sigma_policy_specification 〈preamble,instr_list〉 sigma policy →
820        |instr_list| ≤ 2^16 →
821        let 〈ppc,code〉 ≝ ppc_code in
822         ppc = bitvector_of_nat … (|pre|) ∧
823         |code| ≤ 2^16 ∧
824         (nat_of_bitvector … (sigma ppc) = |code| ∨
825          sigma ppc = zero … ∧ |code| = 2^16 ∧
826          (|pre| < 2^16 → ∀ppc'. ∀ppc_ok':nat_of_bitvector … ppc' < |instr_list|. nat_of_bitvector … ppc ≤ nat_of_bitvector … ppc' →
827            let instruction' ≝ \fst (fetch_pseudo_instruction instr_list ppc' ppc_ok') in
828            instruction_size lookup_labels lookup_datalabels sigma policy ppc' instruction' = 0)
829         ) ∧
830         ∀ppc'.∀ppc_ok'.
831          (nat_of_bitvector … ppc' < nat_of_bitvector … ppc ∨ |pre| = 2^16) →
832           let 〈pi,newppc〉 ≝ fetch_pseudo_instruction instr_list ppc' ppc_ok' in
833           let 〈len,assembledi〉 ≝
834            assembly_1_pseudoinstruction lookup_labels sigma policy ppc' lookup_datalabels pi in
835           |assembledi| ≤ |reverse … code| ∧
836           ∀j:nat. ∀H: j < |assembledi|. ∃K.
837            nth_safe ? j assembledi H =
838             nth_safe ? (nat_of_bitvector … (add … (sigma ppc') (bitvector_of_nat ? j))) (reverse … code) K)
839      instr_list
840      (λprefix,hd,tl,prf,ppc_code.
841        let 〈ppc, code〉 ≝ pi1 … ppc_code in
842        let 〈pc_delta, program〉 ≝ assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels (\snd hd) in
843        let new_ppc ≝ add ? ppc (bitvector_of_nat ? 1) in
844         〈new_ppc, (reverse … program @ code)〉)
845      〈(zero ?), [ ]〉)
846    in
847     〈reverse … revcode,
848      fold … (λppc.λcost.λpc_to_costs. insert … (sigma ppc) cost pc_to_costs) ppc_to_costs (Stub ??)〉.
849  [ cases (foldl_strong ? (λx.Σy.?) ???) in p1; #ignore_revcode #Hfold #EQignore_revcode
850    >EQignore_revcode in Hfold; #Hfold #sigma_pol_ok #instr_list_ok
851    cases (Hfold sigma_pol_ok instr_list_ok) -Hfold * * #Hfold1 #Hfold4 #Hfold5 #Hfold3 whd
852    <eq_create_label_cost_map whd %
853    [2: #ppc #LTppc @Hfold3 >Hfold1 @(eqb_elim (|instr_list|) 2^16)
854      [ #limit %2 @limit
855      | #nlimit %1 >nat_of_bitvector_bitvector_of_nat_inverse try assumption
856        @not_eq_to_le_to_lt assumption ]
857    | >length_reverse % try assumption cases Hfold5 -Hfold5
858      [ #Hfold5 <Hfold5 % >Hfold1 %
859      | * #Hfold51 #Hfold52 %2 <Hfold1 assumption ]]
860  | * #sigma_pol_ok1 #_ #instr_list_ok %
861    [ % % [%] // >sigma_pol_ok1 % ]
862    #ppc' #ppc_ok' #abs @⊥ cases abs
863     [#abs2 cases (not_le_Sn_O ?) [#H @(H abs2) | skip]
864     |#abs2 change with (0 = S ?) in abs2; destruct(abs2) ]
865  | #sigma_pol_ok cases sigma_pol_ok #sigma_pol_ok1 #sigma_pol_ok2 #instr_list_ok cases ppc_code in p1; -ppc_code #ppc_code #IH #EQppc_code >EQppc_code in IH; -EQppc_code
866    #IH cases (IH ? instr_list_ok) [2: % assumption ] -IH
867    * * #IH1 #IH2 #IH3 #IH4
868    cut (|prefix| < |instr_list|)
869    [ >prf >length_append normalize <plus_n_Sm @le_S_S // ] #LT_prefix_instr_list
870    cut (|prefix| < 2^16)
871    [ @(lt_to_le_to_lt … (|instr_list|)) assumption ] #prefix_ok
872    cut (nat_of_bitvector … ppc < |instr_list|)
873    [ >IH1 >nat_of_bitvector_bitvector_of_nat_inverse assumption ] #ppc_ok
874    cut (\snd hd = \fst (fetch_pseudo_instruction instr_list ppc ppc_ok))
875    [ >prf in ppc_ok; >IH1 >(add_zero … (bitvector_of_nat … (|prefix|)))
876      >fetch_pseudo_instruction_append
877      [ #ppc_ok whd in match fetch_pseudo_instruction; normalize nodelta
878        whd in match (nth_safe ????); [ cases hd // | normalize // ]
879      | <add_zero >nat_of_bitvector_bitvector_of_nat_inverse
880        [ <prf assumption | assumption ]
881      | skip
882      | <prf assumption
883      ]] #eq_fetch_pseudo_instruction
884    lapply (fst_snd_assembly_1_pseudoinstruction … p2) #EQpc_delta
885    cut (pc_delta < 2^16)
886    [ >EQpc_delta
887      @(eq_ind ?? (λp.λ_. |\snd p| < 2^16) ?? p2)
888      @assembly1_pseudoinstruction_lt_2_to_16 ] #pc_delta_ok
889    cut (pc_delta = instruction_size lookup_labels lookup_datalabels sigma policy ppc (\snd hd))
890    [ whd in match instruction_size; normalize nodelta
891      >fst_assembly_1_pseudoinstruction_insensible_to_lookup_datalabels [ >p2 | skip] % ]
892    #EQpc_delta2
893    cases (sigma_pol_ok2 … ppc_ok)
894    <eq_fetch_pseudo_instruction <eq_create_label_cost_map <EQpc_delta2
895    #sigma_pol3 #sigma_pol4
896    % [ % [% ] ]
897    [ >length_append normalize nodelta >IH1 @sym_eq @add_bitvector_of_nat
898    | >length_append >length_reverse <EQpc_delta
899      cases IH3 -IH3
900      [ #IH3 <IH3 >commutative_plus
901        cases sigma_pol4 [ #LT @(transitive_le … LT) // | * #_ #EQ >EQ % ]
902      | * * #IH3a #IH3b #IH3c >IH3b <EQpc_delta >EQpc_delta2 >eq_fetch_pseudo_instruction
903        >IH3c try % assumption ]
904    | >length_append >length_reverse
905      cases IH3 -IH3
906      [ #IH3 <IH3 <EQpc_delta cases sigma_pol4
907        [ #LT %1 >sigma_pol3 >nat_of_bitvector_add
908          [2: >nat_of_bitvector_bitvector_of_nat_inverse assumption]
909          >nat_of_bitvector_bitvector_of_nat_inverse try assumption //
910        | * #EQ1 #EQ2 %2 %
911          [ lapply (eq_f … (bitvector_of_nat 16) … EQ2) <add_bitvector_of_nat_plus
912            >bitvector_of_nat_inverse_nat_of_bitvector <sigma_pol3 #X >X % //
913          | #LLT_prefix
914            cut (S (nat_of_bitvector … ppc) < 2^16)
915            [ >length_append in LLT_prefix; <plus_n_Sm <plus_n_O #LLT_prefix
916              >IH1 >nat_of_bitvector_bitvector_of_nat_inverse assumption ]
917            -LLT_prefix #LLT_prefix
918            #ppc' #ppc_ok' #LEQ_newppc_ppc' whd >EQ1 try %
919            @(lt_to_le_to_lt … LEQ_newppc_ppc') normalize nodelta
920            >nat_of_bitvector_add >nat_of_bitvector_bitvector_of_nat_inverse // ]]
921      | * * #IH5 #IH6 #IH7 %2 % [% ]
922        [ normalize nodelta >sigma_pol3 >IH5
923          >add_commutative <add_zero >nat_of_bitvector_bitvector_of_nat_inverse try assumption
924          >EQpc_delta2 >eq_fetch_pseudo_instruction >IH7 try % assumption
925        | >IH6 <EQpc_delta >EQpc_delta2 >eq_fetch_pseudo_instruction >IH7 try %
926          assumption
927        | #LLT_prefix
928          cut (S (nat_of_bitvector … ppc) < 2^16)
929          [ >length_append in LLT_prefix; <plus_n_Sm <plus_n_O #LLT_prefix
930            >IH1 >nat_of_bitvector_bitvector_of_nat_inverse assumption ]
931          -LLT_prefix #LLT_prefix
932          #ppc' #ppc_ok' #LEQ_newppc_ppc' whd @IH7 try assumption
933          @(transitive_le … LEQ_newppc_ppc') normalize nodelta
934          >nat_of_bitvector_add >nat_of_bitvector_bitvector_of_nat_inverse // ]]
935  | #ppc' #LTppc' cases hd in prf p2 EQpc_delta2 eq_fetch_pseudo_instruction; #label #pi #prf #p2
936    #EQpc_delta2 #eq_fetch_pseudo_instruction #OR_lt_eq @(eq_bv_elim … ppc' ppc)
937    [ #EQppc' >EQppc' in LTppc'; -ppc' >prf
938      >IH1 #LTppc lapply LTppc
939      >(add_zero … (bitvector_of_nat 16 (|prefix|))) in ⊢ (% → match % with [_ ⇒ ?]);
940      >fetch_pseudo_instruction_append
941      [3: @le_S_S @le_O_n
942      |2: lapply LTppc; >(add_zero … (bitvector_of_nat 16 (|prefix|))) in ⊢ (% → ?); #H @H
943      |4: <prf <p_refl in instr_list_ok; #H @H ]
944      #LTppc' @pair_elim #pi' #newppc' #EQpair destruct(EQpair) <IH1 >p2 %
945      [ >length_reverse >length_append >length_reverse // ]
946      #j #LTj >nat_of_bitvector_add
947      >nat_of_bitvector_bitvector_of_nat_inverse
948      [2,4: @(lt_to_le_to_lt … LTj) <EQpc_delta @(transitive_le … pc_delta_ok) %2 %
949      |3: @(lt_to_le_to_lt … (nat_of_bitvector … (sigma ppc) + pc_delta))
950          [ >EQpc_delta @monotonic_lt_plus_r assumption
951          | cases sigma_pol4
952            [ #H @(transitive_le … H) %2 %
953            | * #_ #EQ >EQ % ]]]
954      >reverse_append >reverse_reverse
955      cases IH3 -IH3
956      [ #IH3 >IH3 <(length_reverse … code) %
957        [ >length_append @monotonic_lt_plus_r assumption
958        | @nth_safe_prepend ]
959      | * * #IH3a #IH3b #IH3c >IH3a @⊥
960        cut (|program| = 0)
961        [ <EQpc_delta >EQpc_delta2 >eq_fetch_pseudo_instruction @IH3c // ] #EQprogram
962        @(absurd ?? (not_le_Sn_O j)) <EQprogram assumption ]
963    | #NEQppc'
964      lapply (IH4 … LTppc')
965      @pair_elim #pi' #newppc' #eq_fetch_pseudoinstruction
966      @pair_elim #len' #assembledi' #eq_assembly_1_pseudoinstruction #IH
967      cases (IH ?) -IH
968      [2: %1 cases OR_lt_eq
969        [ normalize nodelta #LT lapply LT >nat_of_bitvector_add
970          [2: >nat_of_bitvector_bitvector_of_nat_inverse [2: //]
971            cases (le_to_or_lt_eq … (? : nat_of_bitvector … ppc < 2^16))
972            [ #X <plus_n_Sm <plus_n_O @X
973            | #abs @⊥
974              <(bitvector_of_nat_inverse_nat_of_bitvector … ppc) in LT;
975              >add_overflow [2: <plus_n_Sm <plus_n_O assumption ]
976              #abs' @(absurd … abs') normalize in ⊢ (? (??%));
977              @not_le_Sn_O
978            | @(lt_to_le_to_lt … ppc_ok) assumption ]]
979          >nat_of_bitvector_bitvector_of_nat_inverse [2: // ]
980          <plus_n_Sm <plus_n_O #X lapply (le_S_S_to_le … X) -X #X
981          cases (le_to_or_lt_eq … X) [//] #abs @⊥
982          lapply (eq_f … (bitvector_of_nat 16) … abs)
983          >bitvector_of_nat_inverse_nat_of_bitvector
984          >bitvector_of_nat_inverse_nat_of_bitvector #EQ
985          @(absurd … EQ NEQppc')
986        | >length_append <plus_n_Sm <plus_n_O #EQ @le_S_S_to_le >IH1
987          >nat_of_bitvector_bitvector_of_nat_inverse try assumption
988          cases (le_to_or_lt_eq … (lt_nat_of_bitvector 16 ppc')) [#X >EQ @X]
989          #abs @⊥ <EQ in abs; #X lapply (injective_S … X) #abs
990          lapply (eq_f … (bitvector_of_nat 16) … abs)
991          >bitvector_of_nat_inverse_nat_of_bitvector <IH1 #EQ
992          @(absurd … EQ NEQppc') ]]
993      #IH6 #IH
994      change with (let 〈len,assembledi〉 ≝ assembly_1_pseudoinstruction ????? pi' in ? ∧ ∀j:ℕ. ∀H:j<|assembledi|.?)
995      >eq_assembly_1_pseudoinstruction %
996      [ >reverse_append >length_append
997        >(fst_snd_assembly_1_pseudoinstruction … eq_assembly_1_pseudoinstruction)
998        @(transitive_le … IH6) //
999      | #j #LTj >reverse_append >reverse_reverse cases (IH … LTj) -IH #K #IH %
1000        [ >length_append @(lt_to_le_to_lt … K) //
1001        | >IH @shift_nth_prefix ]]]]]
1002qed.
1003
1004definition assembly_unlabelled_program:
1005    assembly_program → option (list Byte × (BitVectorTrie Identifier 16)) ≝
1006  λp.
1007    Some … (〈foldr … (λi,l. assembly1 i @ l) [ ] p, Stub …〉).
Note: See TracBrowser for help on using the repository browser.