1 | include "joint/semantics.ma". |
---|
2 | include "common/StructuredTraces.ma". |
---|
3 | |
---|
4 | record evaluation_params : Type[1] ≝ |
---|
5 | { globals: list ident |
---|
6 | ; sparams:> sem_params |
---|
7 | ; exit: program_counter |
---|
8 | ; ev_genv: genv sparams globals |
---|
9 | (* ; io_env : state sparams → ∀o:io_out.res (io_in o) *) |
---|
10 | }. |
---|
11 | |
---|
12 | |
---|
13 | |
---|
14 | record prog_params : Type[1] ≝ |
---|
15 | { prog_spars : sem_params |
---|
16 | ; prog : joint_program prog_spars |
---|
17 | ; stack_sizes : ident → option ℕ |
---|
18 | (* ; prog_io : state prog_spars → ∀o.res (io_in o) *) |
---|
19 | }. |
---|
20 | |
---|
21 | lemma map_Exists : ∀A,B,f,P,l.Exists B P (map A B f l) → Exists ? (λx.P (f x)) l. |
---|
22 | #A #B #f #P #l elim l -l [*] |
---|
23 | #hd #tl #IH * |
---|
24 | [ #Phd %1{Phd} |
---|
25 | | #Ptl %2{(IH Ptl)} |
---|
26 | ] |
---|
27 | qed. |
---|
28 | |
---|
29 | lemma Exists_In : ∀A,P,l.Exists A P l → ∃x.In A l x ∧ P x. |
---|
30 | #A #P #l elim l -l [*] #hd #tl #IH * |
---|
31 | [ #Phd %{hd} %{Phd} %1 % |
---|
32 | | #Ptl elim (IH Ptl) #x * #H1 #H2 %{x} %{H2} %2{H1} |
---|
33 | ] |
---|
34 | qed. |
---|
35 | |
---|
36 | lemma In_Exists : ∀A,P,l,x.In A l x → P x → Exists A P l. |
---|
37 | #A #P #l elim l -l [ #x *] #hd #tl #IH #x * |
---|
38 | [ #EQ >EQ #H %1{H} |
---|
39 | | #Intl #Px %2{(IH … Intl Px)} |
---|
40 | ] |
---|
41 | qed. |
---|
42 | |
---|
43 | lemma Exists_mp : ∀A,P,Q,l.(∀x.P x → Q x) → Exists A P l → Exists A Q l. |
---|
44 | #A #P #Q #l #H elim l -l [*] #hd #tl #IH * #G [ %1 | %2 ] /2/ qed. |
---|
45 | |
---|
46 | definition make_global : prog_params → evaluation_params |
---|
47 | ≝ |
---|
48 | λpars. |
---|
49 | (* Invariant: a -1 block is unused in common/Globalenvs *) |
---|
50 | let b ≝ mk_block Code (-1) in |
---|
51 | let ptr ≝ mk_program_counter «b, refl …» one in |
---|
52 | let p ≝ prog pars in |
---|
53 | mk_evaluation_params |
---|
54 | (prog_var_names … p) |
---|
55 | (prog_spars pars) |
---|
56 | ptr |
---|
57 | (mk_genv_gen ?? (globalenv_noinit ? p) ? (stack_sizes pars)) |
---|
58 | (* (prog_io pars) *). |
---|
59 | #s #H |
---|
60 | elim (find_symbol_exists … p s ?) |
---|
61 | [ #bl #EQ >EQ % #ABS destruct(ABS)|*:] |
---|
62 | @Exists_append_r |
---|
63 | @(Exists_mp … H) // |
---|
64 | qed. |
---|
65 | |
---|
66 | coercion prog_params_to_ev_params : ∀p : prog_params.evaluation_params |
---|
67 | ≝ make_global on _p : prog_params to evaluation_params. |
---|
68 | |
---|
69 | axiom BadMain : String. |
---|
70 | |
---|
71 | definition make_initial_state : |
---|
72 | ∀pars: prog_params.res (state_pc pars) ≝ |
---|
73 | λpars.let p ≝ prog pars in |
---|
74 | let sem_globals : evaluation_params ≝ pars in |
---|
75 | let ge ≝ ev_genv sem_globals in |
---|
76 | let m ≝ alloc_mem … p in |
---|
77 | let 〈m,spb〉 ≝ alloc … m 0 external_ram_size XData in |
---|
78 | let 〈m,ispb〉 ≝ alloc … m 0 internal_ram_size XData in |
---|
79 | let dummy_pc ≝ mk_program_counter «mk_block Code (-1), refl …» one in |
---|
80 | let spp : xpointer ≝ |
---|
81 | «mk_pointer spb (mk_offset (bitvector_of_Z ? external_ram_size)), |
---|
82 | pi2 … spb» in |
---|
83 | (* let ispp : xpointer ≝ mk_pointer ispb (mk_offset (bitvector_of_nat ? 47)) in *) |
---|
84 | let main ≝ prog_main … p in |
---|
85 | let st0 ≝ mk_state pars (empty_framesT …) empty_is (BBbit false) (empty_regsT … spp) m in |
---|
86 | (* use exit sem_globals as ra and call_dest_for_main as dest *) |
---|
87 | let st0' ≝ mk_state_pc … (set_sp … spp st0) (exit sem_globals) in |
---|
88 | ! st0'' ← save_frame ?? sem_globals (call_dest_for_main … pars) st0' ; |
---|
89 | let st_pc0 ≝ mk_state_pc ? st0'' dummy_pc in |
---|
90 | ! bl ← block_of_call … ge st_pc0 (inl … main) ; |
---|
91 | ! 〈i, fn〉 ← fetch_function … ge bl ; |
---|
92 | match fn with |
---|
93 | [ Internal ifn ⇒ |
---|
94 | ! st' ← eval_internal_call_no_pc … ge i ifn (call_args_for_main … pars) st_pc0 ; |
---|
95 | let pc' ≝ pc_of_point … bl (joint_if_entry … ifn) in |
---|
96 | return mk_state_pc … st' pc' |
---|
97 | | External _ ⇒ Error … [MSG BadMain; CTX ? main] (* External main not supported: why? *) |
---|
98 | ]. |
---|
99 | |
---|
100 | definition joint_classify_seq : |
---|
101 | ∀p : evaluation_params.state p → joint_seq p (globals … p) → status_class ≝ |
---|
102 | λp,st,stmt. |
---|
103 | match stmt with |
---|
104 | [ CALL f args dest ⇒ |
---|
105 | match (! bl ← block_of_call … (ev_genv p) st f ; |
---|
106 | fetch_function … (ev_genv p) bl) with |
---|
107 | [ OK id_fn ⇒ |
---|
108 | match \snd id_fn with |
---|
109 | [ Internal _ ⇒ cl_call |
---|
110 | | External _ ⇒ cl_other |
---|
111 | ] |
---|
112 | | Error _ ⇒ cl_other |
---|
113 | ] |
---|
114 | | _ ⇒ cl_other |
---|
115 | ]. |
---|
116 | |
---|
117 | definition joint_classify_step : |
---|
118 | ∀p : evaluation_params.state p → joint_step p (globals … p) → status_class ≝ |
---|
119 | λp,st,stmt. |
---|
120 | match stmt with |
---|
121 | [ step_seq s ⇒ joint_classify_seq p st s |
---|
122 | | COND _ _ ⇒ cl_jump |
---|
123 | ]. |
---|
124 | |
---|
125 | definition joint_classify_final : |
---|
126 | ∀p : evaluation_params.joint_fin_step p → status_class ≝ |
---|
127 | λp,stmt. |
---|
128 | match stmt with |
---|
129 | [ GOTO _ ⇒ cl_other |
---|
130 | | RETURN ⇒ cl_return |
---|
131 | | TAILCALL _ _ _ ⇒ cl_other (* this needs tailcalls implemented in structured traces *) |
---|
132 | ]. |
---|
133 | |
---|
134 | definition joint_classify : |
---|
135 | ∀p : evaluation_params.state_pc p → status_class ≝ |
---|
136 | λp,st. |
---|
137 | match fetch_statement … (ev_genv p) (pc … st) with |
---|
138 | [ OK i_f_s ⇒ |
---|
139 | match \snd i_f_s with |
---|
140 | [ sequential s _ ⇒ joint_classify_step p st s |
---|
141 | | final s ⇒ joint_classify_final p s |
---|
142 | ] |
---|
143 | | Error _ ⇒ cl_other |
---|
144 | ]. |
---|
145 | |
---|
146 | definition no_call : ∀p,g.joint_seq p g → Prop ≝ |
---|
147 | λp,g,s.match s with |
---|
148 | [ CALL _ _ _ ⇒ False |
---|
149 | | _ ⇒ True |
---|
150 | ]. |
---|
151 | |
---|
152 | definition no_cost_label : ∀p,g.joint_seq p g → Prop ≝ |
---|
153 | λp,g,s.match s with |
---|
154 | [ COST_LABEL _ ⇒ False |
---|
155 | | _ ⇒ True |
---|
156 | ]. |
---|
157 | |
---|
158 | lemma no_call_advance : ∀p : evaluation_params. |
---|
159 | ∀s,nxt.∀st : state_pc p. |
---|
160 | no_call p (globals p) s → |
---|
161 | eval_seq_advance p (globals p) (ev_genv p) s nxt st = return next … nxt st. |
---|
162 | #p * // #f #args #dest #nxt #st * |
---|
163 | qed. |
---|
164 | |
---|
165 | lemma no_call_other : ∀p : evaluation_params.∀st,s. |
---|
166 | no_call p (globals p) s → |
---|
167 | joint_classify_seq … st s = cl_other. |
---|
168 | #p #st * // #f #args #dest * |
---|
169 | qed. |
---|
170 | |
---|
171 | lemma cond_call_other : |
---|
172 | ∀p,globals.∀P : joint_step p globals → Prop. |
---|
173 | (∀a,lbltrue.P (COND … a lbltrue)) → |
---|
174 | (∀f,args,dest.P (CALL … f args dest)) → |
---|
175 | (∀s.no_call ?? s → P s) → |
---|
176 | ∀s.P s. |
---|
177 | #p #globals #P #H1 #H2 #H3 * // * /2 by / qed. |
---|
178 | |
---|
179 | lemma joint_classify_call : ∀p : evaluation_params.∀st. |
---|
180 | joint_classify p st = cl_call → |
---|
181 | ∃i_f,f',args,dest,next,bl,i',fd'. |
---|
182 | fetch_statement … (ev_genv p) (pc … st) = |
---|
183 | OK ? 〈i_f, sequential … (CALL … f' args dest) next〉 ∧ |
---|
184 | block_of_call … (ev_genv p) st f' = OK ? bl ∧ |
---|
185 | fetch_internal_function … (ev_genv p) bl = OK ? 〈i', fd'〉. |
---|
186 | #p #st |
---|
187 | whd in match joint_classify; normalize nodelta |
---|
188 | inversion (fetch_statement … (ev_genv p) (pc … st)) normalize nodelta |
---|
189 | [2: #e #_ #ABS destruct(ABS) ] |
---|
190 | * #i_f * [2: * [ #lbl | | #fl #f #args ] #_ normalize in ⊢ (%→?); #ABS destruct(ABS) ] |
---|
191 | @cond_call_other |
---|
192 | [ #a #lbl #nxt #_ normalize in ⊢ (%→?); #ABS destruct(ABS) |
---|
193 | |3: #s #no_call #nxt #_ whd in match joint_classify_step; |
---|
194 | normalize nodelta >(no_call_other … no_call) #ABS destruct(ABS) |
---|
195 | ] |
---|
196 | #f' #args #dest #nxt #fetch |
---|
197 | whd in match joint_classify_step; whd in match joint_classify_seq; |
---|
198 | normalize nodelta |
---|
199 | inversion (block_of_call ?????) |
---|
200 | [ #bl #block_of_c >m_return_bind |
---|
201 | inversion (fetch_function ???) |
---|
202 | [ * #i' * |
---|
203 | [ #fd' #fetch' #_ |
---|
204 | %{i_f} %{f'} %{args} %{dest} %{nxt} %{bl} %{i'} %{fd'} |
---|
205 | % [ %{block_of_c} % ] |
---|
206 | whd in match fetch_internal_function; normalize nodelta |
---|
207 | >fetch' % |
---|
208 | ] |
---|
209 | ] |
---|
210 | ] |
---|
211 | #x #_ normalize in ⊢ (%→?); #ABS destruct(ABS) |
---|
212 | qed. |
---|
213 | |
---|
214 | definition joint_after_ret : ∀p:evaluation_params. |
---|
215 | (Σs : state_pc p.joint_classify p s = cl_call) → state_pc p → Prop ≝ |
---|
216 | λp,s1,s2. |
---|
217 | match fetch_statement … (ev_genv p) (pc … s1) with |
---|
218 | [ OK x ⇒ |
---|
219 | match \snd x with |
---|
220 | [ sequential s next ⇒ |
---|
221 | pc … s2 = succ_pc p (pc … s1) next |
---|
222 | | _ ⇒ False (* never happens *) |
---|
223 | ] |
---|
224 | | _ ⇒ False (* never happens *) |
---|
225 | ]. |
---|
226 | |
---|
227 | definition joint_call_ident : ∀p:evaluation_params. |
---|
228 | (Σs : state_pc p.joint_classify p s = cl_call) → ident ≝ |
---|
229 | (* this is a definition without a dummy ident : |
---|
230 | λp,st. |
---|
231 | match ? |
---|
232 | return λx. |
---|
233 | !〈f, s〉 ← fetch_statement ? p … (ev_genv p) (pc … st) ; |
---|
234 | match s with |
---|
235 | [ sequential s next ⇒ |
---|
236 | match s with |
---|
237 | [ step_seq s ⇒ |
---|
238 | match s with |
---|
239 | [ CALL f' args dest ⇒ |
---|
240 | function_of_call … (ev_genv p) st f' |
---|
241 | | _ ⇒ Error … [ ] |
---|
242 | ] |
---|
243 | | _ ⇒ Error … [ ] |
---|
244 | ] |
---|
245 | | _ ⇒ Error … [ ] |
---|
246 | ] = x → ? with |
---|
247 | [ OK v ⇒ λ_.v |
---|
248 | | Error e ⇒ λABS.⊥ |
---|
249 | ] (refl …). |
---|
250 | @hide_prf |
---|
251 | elim (joint_classify_call … (pi2 … st)) |
---|
252 | #f *#f' *#args *#dest *#next *#fn *#fd ** #EQ1 #EQ2 #EQ3 |
---|
253 | lapply ABS -ABS |
---|
254 | >EQ1 >m_return_bind normalize nodelta >EQ2 #ABS destruct(ABS) |
---|
255 | qed. *) |
---|
256 | (* with a dummy ident (which is never used as seen above in the commented script) |
---|
257 | I think handling of the function is easier *) |
---|
258 | λp,st. |
---|
259 | let dummy : ident ≝ an_identifier ? one in (* used where it cannot ever happen *) |
---|
260 | match fetch_statement … (ev_genv p) (pc … st) with |
---|
261 | [ OK x ⇒ |
---|
262 | match \snd x with |
---|
263 | [ sequential s next ⇒ |
---|
264 | match s with |
---|
265 | [ step_seq s ⇒ |
---|
266 | match s with |
---|
267 | [ CALL f' args dest ⇒ |
---|
268 | match |
---|
269 | (! bl ← block_of_call … (ev_genv p) st f' ; |
---|
270 | fetch_internal_function … (ev_genv p) bl) with |
---|
271 | [ OK i_f ⇒ \fst i_f |
---|
272 | | _ ⇒ dummy |
---|
273 | ] |
---|
274 | | _ ⇒ dummy |
---|
275 | ] |
---|
276 | | _ ⇒ dummy |
---|
277 | ] |
---|
278 | | _ ⇒ dummy |
---|
279 | ] |
---|
280 | | _ ⇒ dummy |
---|
281 | ]. |
---|
282 | |
---|
283 | definition pcDeq ≝ mk_DeqSet program_counter eq_program_counter ?. |
---|
284 | *#p1 #EQ1 * #p2 #EQ2 @eq_program_counter_elim |
---|
285 | [ #EQ destruct % #H % |
---|
286 | | * #NEQ % #ABS destruct elim (NEQ ?) % |
---|
287 | ] |
---|
288 | qed. |
---|
289 | |
---|
290 | (* |
---|
291 | let rec io_evaluate O I X (env : ∀o.res (I o)) (c : IO O I X) on c : res X ≝ |
---|
292 | match c with |
---|
293 | [ Value x ⇒ OK … x |
---|
294 | | Interact o f ⇒ |
---|
295 | ! i ← env o ; |
---|
296 | io_evaluate O I X env (f i) |
---|
297 | | Wrong e ⇒ Error … e |
---|
298 | ]. |
---|
299 | *) |
---|
300 | |
---|
301 | definition cost_label_of_stmt : |
---|
302 | ∀p : evaluation_params.joint_statement p (globals p) → option costlabel ≝ |
---|
303 | λp,s.match s with |
---|
304 | [ sequential s _ ⇒ |
---|
305 | match s with |
---|
306 | [ step_seq s ⇒ |
---|
307 | match s with |
---|
308 | [ COST_LABEL lbl ⇒ Some ? lbl |
---|
309 | | _ ⇒ None ? |
---|
310 | ] |
---|
311 | | _ ⇒ None ? |
---|
312 | ] |
---|
313 | | _ ⇒ None ? |
---|
314 | ]. |
---|
315 | |
---|
316 | |
---|
317 | lemma no_label_uncosted : ∀p : evaluation_params.∀s,nxt. |
---|
318 | no_cost_label p (globals p) s → |
---|
319 | cost_label_of_stmt … (sequential … s nxt) = None ?. |
---|
320 | #p * // #lbl #next * |
---|
321 | qed. |
---|
322 | |
---|
323 | definition joint_abstract_status : |
---|
324 | ∀p : evaluation_params. |
---|
325 | abstract_status ≝ |
---|
326 | λp. |
---|
327 | mk_abstract_status |
---|
328 | (* as_status ≝ *) (state_pc p) |
---|
329 | (* as_execute ≝ *) |
---|
330 | (λs1,s2.(* io_evaluate … (io_env p s1) *) (eval_state … (ev_genv p) s1) = return s2) |
---|
331 | (* as_pc ≝ *) pcDeq |
---|
332 | (* as_pc_of ≝ *) (pc …) |
---|
333 | (* as_classify ≝ *) (joint_classify p) |
---|
334 | (* as_label_of_pc ≝ *) |
---|
335 | (λpc. |
---|
336 | match fetch_statement … (ev_genv p) pc with |
---|
337 | [ OK fn_stmt ⇒ cost_label_of_stmt … (\snd fn_stmt) |
---|
338 | | _ ⇒ None ? |
---|
339 | ]) |
---|
340 | (* as_after_return ≝ *) (joint_after_ret p) |
---|
341 | (* as_final ≝ *) (λs.is_final p (globals ?) (ev_genv p) (exit p) s ≠ None ?) |
---|
342 | (* as_call_ident ≝ *) (joint_call_ident p). |
---|
343 | |
---|