source: extracted/policyStep.ml @ 2773

Last change on this file since 2773 was 2773, checked in by sacerdot, 8 years ago
  1. everything extracted again after all bugs in Matita's extraction have been fixed. No more need for manual patching
  2. new extraction after file reorganization (by James)
File size: 7.0 KB
Line 
1open Preamble
2
3open Assembly
4
5open Status
6
7open Fetch
8
9open BitVectorTrie
10
11open String
12
13open Exp
14
15open Arithmetic
16
17open Vector
18
19open FoldStuff
20
21open BitVector
22
23open Extranat
24
25open Integers
26
27open AST
28
29open LabelledObjects
30
31open Proper
32
33open PositiveMap
34
35open Deqsets
36
37open ErrorMessages
38
39open PreIdentifiers
40
41open Errors
42
43open Extralib
44
45open Setoids
46
47open Monad
48
49open Option
50
51open Div_and_mod
52
53open Jmeq
54
55open Russell
56
57open Util
58
59open List
60
61open Lists
62
63open Bool
64
65open Relations
66
67open Nat
68
69open Positive
70
71open Hints_declaration
72
73open Core_notation
74
75open Pts
76
77open Logic
78
79open Types
80
81open Identifiers
82
83open CostLabel
84
85open ASM
86
87open PolicyFront
88
89(** val jump_expansion_step :
90    ASM.labelled_instruction List.list Types.sig0 -> Fetch.label_map
91    Types.sig0 -> PolicyFront.ppc_pc_map Types.sig0 -> (Bool.bool,
92    PolicyFront.ppc_pc_map Types.option) Types.prod Types.sig0 **)
93let jump_expansion_step program labels old_sigma =
94  (let { Types.fst = final_added; Types.snd = final_policy } =
95     Types.pi1
96       (FoldStuff.foldl_strong (Types.pi1 program) (fun prefix x tl _ acc ->
97         (let { Types.fst = inc_added; Types.snd = inc_pc_sigma } =
98            Types.pi1 acc
99          in
100         (fun _ ->
101         (let { Types.fst = label; Types.snd = instr } = x in
102         (fun _ ->
103         let add_instr =
104           match instr with
105           | ASM.Instruction i ->
106             PolicyFront.jump_expansion_step_instruction (Types.pi1 labels)
107               (Types.pi1 old_sigma) inc_pc_sigma (List.length prefix) i
108           | ASM.Comment x0 -> Types.None
109           | ASM.Cost x0 -> Types.None
110           | ASM.Jmp j ->
111             Types.Some
112               (PolicyFront.select_jump_length (Types.pi1 labels)
113                 (Types.pi1 old_sigma) inc_pc_sigma (List.length prefix) j)
114           | ASM.Jnz (x0, x1, x2) -> Types.None
115           | ASM.MovSuccessor (x0, x1, x2) -> Types.None
116           | ASM.Call c ->
117             Types.Some
118               (PolicyFront.select_call_length (Types.pi1 labels)
119                 (Types.pi1 old_sigma) inc_pc_sigma (List.length prefix) c)
120           | ASM.Mov (x0, x1) -> Types.None
121         in
122         let { Types.fst = inc_pc; Types.snd = inc_sigma } = inc_pc_sigma in
123         let old_length =
124           (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
125             (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
126             (Nat.S Nat.O))))))))))))))))
127             (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
128               (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
129               (Nat.S (Nat.S Nat.O)))))))))))))))) (List.length prefix))
130             (Types.pi1 old_sigma).Types.snd { Types.fst = Nat.O; Types.snd =
131             Assembly.Short_jump }).Types.snd
132         in
133         let old_size = PolicyFront.instruction_size_jmplen old_length instr
134         in
135         let { Types.fst = new_length; Types.snd = isize } =
136           match add_instr with
137           | Types.None ->
138             { Types.fst = Assembly.Short_jump; Types.snd =
139               (PolicyFront.instruction_size_jmplen Assembly.Short_jump
140                 instr) }
141           | Types.Some pl ->
142             { Types.fst = (PolicyFront.max_length old_length pl);
143               Types.snd =
144               (PolicyFront.instruction_size_jmplen
145                 (PolicyFront.max_length old_length pl) instr) }
146         in
147         let new_added =
148           match add_instr with
149           | Types.None -> inc_added
150           | Types.Some x0 -> Nat.plus inc_added (Nat.minus isize old_size)
151         in
152         let old_Slength =
153           (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
154             (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
155             (Nat.S Nat.O))))))))))))))))
156             (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
157               (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
158               (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S
159               (List.length prefix))) (Types.pi1 old_sigma).Types.snd
160             { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.snd
161         in
162         let updated_sigma =
163           BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
164             (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
165             (Nat.S Nat.O))))))))))))))))
166             (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
167               (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
168               (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S
169               (List.length prefix))) { Types.fst = (Nat.plus inc_pc isize);
170             Types.snd = old_Slength }
171             (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
172               (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
173               (Nat.S Nat.O))))))))))))))))
174               (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S
175                 (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
176                 (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))
177                 (List.length prefix)) { Types.fst = inc_pc; Types.snd =
178               new_length } inc_sigma)
179         in
180         { Types.fst = new_added; Types.snd = { Types.fst =
181         (Nat.plus inc_pc isize); Types.snd = updated_sigma } })) __)) __)
182         { Types.fst = Nat.O; Types.snd = { Types.fst = Nat.O; Types.snd =
183         (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
184           (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
185           (Nat.S Nat.O))))))))))))))))
186           (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
187             (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
188             (Nat.S (Nat.S Nat.O)))))))))))))))) Nat.O) { Types.fst = Nat.O;
189           Types.snd =
190           (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
191             (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
192             (Nat.S Nat.O))))))))))))))))
193             (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
194               (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
195               (Nat.S (Nat.S Nat.O)))))))))))))))) Nat.O)
196             (Types.pi1 old_sigma).Types.snd { Types.fst = Nat.O; Types.snd =
197             Assembly.Short_jump }).Types.snd } (BitVectorTrie.Stub (Nat.S
198           (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
199           (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))))) } })
200   in
201  (fun _ ->
202  (match Util.gtb final_policy.Types.fst
203           (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
204             (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
205             (Nat.S (Nat.S Nat.O))))))))))))))))) with
206   | Bool.True ->
207     (fun _ -> { Types.fst = (Nat.eqb final_added Nat.O); Types.snd =
208       Types.None })
209   | Bool.False ->
210     (fun _ -> { Types.fst = (Nat.eqb final_added Nat.O); Types.snd =
211       (Types.Some final_policy) })) __)) __
212
Note: See TracBrowser for help on using the repository browser.