source: extracted/compiler.ml @ 2736

Last change on this file since 2736 was 2736, checked in by sacerdot, 8 years ago

Untrusted fixpoint computation branched in.

File size: 5.7 KB
Line 
1open Preamble
2
3open BitVectorTrie
4
5open CostLabel
6
7open Coqlib
8
9open Proper
10
11open PositiveMap
12
13open Deqsets
14
15open ErrorMessages
16
17open PreIdentifiers
18
19open Errors
20
21open Extralib
22
23open Setoids
24
25open Monad
26
27open Option
28
29open Lists
30
31open Positive
32
33open Identifiers
34
35open Exp
36
37open Arithmetic
38
39open Vector
40
41open Div_and_mod
42
43open Jmeq
44
45open Russell
46
47open List
48
49open Util
50
51open FoldStuff
52
53open BitVector
54
55open Extranat
56
57open Bool
58
59open Relations
60
61open Nat
62
63open Integers
64
65open Hints_declaration
66
67open Core_notation
68
69open Pts
70
71open Logic
72
73open Types
74
75open AST
76
77open Csyntax
78
79open Label
80
81open Sets
82
83open Listb
84
85open Star
86
87open Frontend_misc
88
89open CexecInd
90
91open CexecSound
92
93open Casts
94
95open ClassifyOp
96
97open Smallstep
98
99open Extra_bool
100
101open FrontEndVal
102
103open Hide
104
105open ByteValues
106
107open GenMem
108
109open FrontEndMem
110
111open Globalenvs
112
113open Csem
114
115open SmallstepExec
116
117open Division
118
119open Z
120
121open BitVectorZ
122
123open Pointers
124
125open Values
126
127open Events
128
129open IOMonad
130
131open IO
132
133open Cexec
134
135open TypeComparison
136
137open SimplifyCasts
138
139open MemProperties
140
141open MemoryInjections
142
143open Fresh
144
145open SwitchRemoval
146
147open FrontEndOps
148
149open Cminor_syntax
150
151open ToCminor
152
153open Initialisation
154
155open Graphs
156
157open Order
158
159open Registers
160
161open RTLabs_syntax
162
163open ToRTLabs
164
165open Deqsets_extra
166
167open CostMisc
168
169open Listb
170
171open CostSpec
172
173open CostCheck
174
175open Executions
176
177open StructuredTraces
178
179open RTLabs_semantics
180
181open RTLabs_abstract
182
183open RTLabs_traces
184
185open CostInj
186
187(** val front_end :
188    Csyntax.clight_program -> ((CostLabel.costlabel, Csyntax.clight_program)
189    Types.prod, RTLabs_syntax.rTLabs_program) Types.prod Errors.res **)
190let front_end p =
191  let p0 = SwitchRemoval.program_switch_removal p in
192  let { Types.fst = p'; Types.snd = init_cost } = Label.clight_label p0 in
193  let p3 = SimplifyCasts.simplify_program p' in
194  Obj.magic
195    (Monad.m_bind0 (Monad.max_def Errors.res0)
196      (Obj.magic (ToCminor.clight_to_cminor p3)) (fun p4 ->
197      let p5 = ToRTLabs.cminor_to_rtlabs init_cost p4 in
198      (match CostCheck.check_cost_program p5 with
199       | Bool.True ->
200         (match CostInj.check_program_cost_injectivity p5 with
201          | Bool.True ->
202            Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst =
203              { Types.fst = init_cost; Types.snd = p' }; Types.snd = p5 }
204          | Bool.False ->
205            Obj.magic (Errors.Error
206              (Errors.msg ErrorMessages.RepeatedCostLabel)))
207       | Bool.False ->
208         Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadCostLabelling)))))
209
210open State
211
212open Bind_new
213
214open BindLists
215
216open Blocks
217
218open TranslateUtils
219
220open AssocList
221
222open String
223
224open LabelledObjects
225
226open I8051
227
228open BackEndOps
229
230open Joint
231
232open RTL
233
234open RTLabsToRTL
235
236open ERTL
237
238open RegisterSet
239
240open RTLToERTL
241
242open ERTLptr
243
244open ERTLToERTLptr
245
246open Fixpoints
247
248open Set_adt
249
250open Liveness
251
252open Interference
253
254open Joint_LTL_LIN
255
256open LTL
257
258open ERTLptrToLTL
259
260open LIN
261
262open Linearise
263
264open LTLToLIN
265
266open ASM
267
268open BitVectorTrieSet
269
270open LINToASM
271
272(** val compute_fixpoint : Fixpoints.fixpoint_computer **)
273let compute_fixpoint = Compute_fixpoints.compute_fixpoint
274
275(** val colour_graph : Interference.coloured_graph_computer **)
276let colour_graph _ =
277  failwith "AXIOM TO BE REALIZED"
278
279(** val back_end :
280    RTLabs_syntax.rTLabs_program -> ASM.pseudo_assembly_program **)
281let back_end p =
282  let p0 = RTLabsToRTL.rtlabs_to_rtl p in
283  let p3 = RTLToERTL.rtl_to_ertl p0 in
284  let p4 = ERTLToERTLptr.ertl_to_ertlptr p3 in
285  let p5 = ERTLptrToLTL.ertlptr_to_ltl compute_fixpoint colour_graph p4 in
286  let p6 = LTLToLIN.ltl_to_lin p5 in LINToASM.lin_to_asm p6
287
288type object_code = BitVector.byte List.list
289
290type costlabel_map1 = CostLabel.costlabel BitVectorTrie.bitVectorTrie
291
292open Assembly
293
294open Status
295
296open Fetch
297
298open PolicyFront
299
300open PolicyStep
301
302open Policy
303
304(** val assembler :
305    ASM.pseudo_assembly_program -> (object_code, costlabel_map1) Types.prod
306    Errors.res **)
307let assembler p =
308  let { Types.fst = preamble0; Types.snd = list_instr } = p in
309  let p' = { Types.fst = preamble0; Types.snd = list_instr } in
310  Obj.magic
311    (Monad.m_bind0 (Monad.max_def Errors.res0)
312      (Obj.magic
313        (Errors.opt_to_res (Errors.msg ErrorMessages.Jump_expansion_failed)
314          (Policy.jump_expansion' (Types.coerc_pair_sigma p'))))
315      (fun sigma_pol ->
316      let sigma0 = fun ppc -> (Types.pi1 sigma_pol).Types.fst ppc in
317      let pol = fun ppc -> (Types.pi1 sigma_pol).Types.snd ppc in
318      Obj.magic (Errors.OK (Types.pi1 (Assembly.assembly p sigma0 pol)))))
319
320open AbstractStatus
321
322open StatusProofs
323
324open Interpret
325
326open ASMCosts
327
328(** val lift_cost_map_back_to_front :
329    Csyntax.clight_program -> BitVector.byte BitVectorTrie.bitVectorTrie ->
330    CostLabel.costlabel BitVectorTrie.bitVectorTrie -> (CostLabel.costlabel
331    -> (__, __) Types.sum) -> StructuredTraces.as_cost_map ->
332    Label.clight_cost_map **)
333let lift_cost_map_back_to_front clight code_memory lbls dec k asm_cost_map =
334  StructuredTraces.lift_sigma_map_id Nat.O dec k asm_cost_map
335
336open UtilBranch
337
338open ASMCostsSplit
339
340(** val compile :
341    Csyntax.clight_program -> ((object_code, costlabel_map1) Types.prod,
342    (Csyntax.clight_program, Label.clight_cost_map) Types.dPair) Types.prod
343    Errors.res **)
344let compile p =
345  Obj.magic
346    (Monad.m_bind3 (Monad.max_def Errors.res0) (Obj.magic (front_end p))
347      (fun init_cost p' p0 ->
348      let p3 = back_end p0 in
349      Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic (assembler p3))
350        (fun p4 ->
351        let k = ASMCostsSplit.aSM_cost_map p4 in
352        let k' =
353          lift_cost_map_back_to_front p'
354            (Fetch.load_code_memory p4.Types.fst) p4.Types.snd (assert false
355            (* absurd case *)) k
356        in
357        Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = p4;
358          Types.snd = { Types.dpi1 = p'; Types.dpi2 = k' } })))
359
Note: See TracBrowser for help on using the repository browser.