Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 378 lines (331 sloc) 10.599 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (**
19 Checking consistency between opabsl, stdlib et opacapi.
20 @author Mathieu Barbin
21 *)
22
23 (**
24 OPA COMPILER INTERFACE:
25
26 The OPA compiler needs to insert some call to identifiers and external primitives
27 defined in the stdlib, and in the opabsl. The set of these identifers and primitives
28 is called : opa-compiler-interface.
29
30 We want to be able, by reading the definition of a bypass, or by reading the definition
31 of a identifier in the stdlib, to know if it is part of this compiler interface.
32 It is necessary to have a better control on dependency between the stdlib, and the compiler.
33 (consistency, maintenance, etc.)
34
35 For that purpose, we decorate the opa-compiler-interface in the stdlib and opabsl,
36 and we use opacapi in the compiler.
37
38 STDLIB:
39 {[
40 @opacapi myfunction()=....
41 ]}
42
43 OPABSL:
44 {[
45 ##register [opacapi] mybypass : ...
46 ]}
47
48 OPACAPI:
49 {[
50 mybypass = "mybypass"
51 myfunction = "myfunction"
52 ]}
53
54 COMPILER:
55 {[
56 let myfunction = Opacapi.myfunction in
57 ...
58 ]}
59
60 This check will ensure that :
61 -the set of all identifier defined in opacapi is strictly equal to the set of identifiers
62 decorated with the directive [@opacapi] in the stdlib,
63 -the set of all bypass defined in opacapi is strictly equal to the set of bypasses
64 decorated with the property [opacapi] in the opabsl
65
66 If a bypass is not in opacapi, nor present in the stdlib, there will be a notification.
67 Since it is not yet clear what we want to do with such cases, currently a warning
68 is printed.
69
70 A file is generated indicating for each bsl-key the list of location where it is used.
71 *)
72
73 (* depends *)
74 module Arg = Base.Arg
75 module Format = Base.Format
76
77 (* shorthand *)
78 module BPI = BslPluginInterface
79 module D = SurfaceAstDecons
80 module Q = QmlAst
81 module SA = SurfaceAst
82
83 (* -- *)
84
85 let validation_ok = ref true
86
87 (* f *)
88
89 let files = MutableList.create ()
90
91 (* t *)
92
93 let target = ref None
94
95 let (|>) = InfixOperator.(|>)
96 let (!>) = Format.sprintf
97
98 let spec = [
99
100 (* o *)
101 "-o",
102 Arg.String (fun t -> target := Some t),
103 !>
104 " specify a target for the trace file"
105
106 ]
107
108 let anon_fun file = MutableList.add files file
109
110 let usage_msg =
111 !> "@{<bright>%s@} <Opa Compiler Interface Validator> %s\nuse: %s [options] stdlib-files"
112 Sys.argv.(0) BuildInfos.version_id
113 Sys.argv.(0)
114
115 let parse () =
116 let spec = (
117 (OManager.Arg.version "checkopacapi" :: OManager.Arg.options) @
118 spec
119 )
120
121 |> Arg.add_bash_completion
122 |> Arg.sort
123 |> Arg.align
124
125 in
126 Arg.parse spec anon_fun usage_msg
127
128 (**
129 Folding input file, and applying a fold on the parsed code
130 *)
131
132 (**
133 pplib specification
134 *)
135 let pplib_spec = [
136 "OPA_VERSION", "S3" ;
137 "OPA_CPS", "" ;
138 "OPA_BADOP", "1" ;
139 ]
140
141 let pprocess =
142 let ppenv = Pprocess.fill_with_sysenv Pprocess.empty_env in
143 let ppenv = List.fold_left (fun ppenv (var, value) -> Pprocess.add_env var value ppenv) ppenv pplib_spec in
144 let ppopt = Pprocess.default_options ppenv in
145 (fun s -> Pprocess.process Pplang.opa_description ppopt s)
146
147 let fold
148 ( fold : (SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.code -> 'acc -> 'acc )
149 filename acc =
150 (* print_endline filename; *)
151 match File.content_opt filename with
152 | None ->
153 OManager.error "[!] I/O error: cannot read file @{<bright>%S@}" filename
154 | Some content ->
155 let content = pprocess content in
156 let code = OpaParser.code ~cache:true ~filename content in
157 fold code acc
158
159 (**
160 Specialized fold, for gathering opacapi directives
161 *)
162 let is_opacapi e =
163 D.Look.at
164 ~through:[
165 D.Remove.Basic.access_directive ;
166 D.Remove.Basic.expand ;
167 D.Remove.Basic.coerce ;
168 D.Remove.Basic.deprecated ;
169 D.Remove.Basic.magic_directive ;
170 D.Remove.Basic.slicer_directive ;
171 ]
172 ~at:[D.Remove.Basic.opacapi]
173 e
174
175 let stdlib acc code =
176 let fold_elt acc (elt, _) =
177 match elt with
178 | SA.NewVal (binds, _) ->
179 let fold acc ((p, _), e) =
180 match p with
181 | SA.PatVar ident | SA.PatAs (_, ident) ->
182 if is_opacapi e
183 then StringSet.add ident acc
184 else acc
185 | _ -> acc
186 in
187 List.fold_left fold acc binds
188 | SA.NewType typedefs ->
189 let fold acc (typedef, _) =
190 if typedef.SA.ty_def_options.Q.opacapi
191 then
192 let (SA.Typeident ident) = typedef.SA.ty_def_name in
193 StringSet.add ident acc
194 else
195 acc
196 in
197 List.fold_left fold acc typedefs
198 | _ -> acc
199 in
200 List.fold_left fold_elt acc code
201
202 (**
203 Check strict equality between 2 StringSet, with errors reporting.
204 *)
205 let report elt name present absent =
206 validation_ok := false ;
207 OManager.printf (
208 "[!] The %s @{<bright>%s@} is present in @{<bright>%s@} but not in @{<bright>%s@}@."
209 )
210 elt name present absent
211
212 let strict_equality elt name1 name2 set1 set2 =
213 let iter name1 name2 set1 set2 =
214 let error name = report elt name name1 name2 in
215 StringSet.iter (fun s -> if not (StringSet.mem s set2) then error s) set1
216 in
217 iter name1 name2 set1 set2;
218 iter name2 name1 set2 set1
219
220 module LocMap = ListMap.Make(BslKey)
221
222
223 let core_types =
224 [
225 "char";
226 "float";
227 "int";
228 "OPA.Init.value";
229 "string";
230 "tuple_2";
231 "void";
232 ]
233
234 let _ =
235 (* Part 1: bsl VS opacapi *)
236 OpabslgenPlugin.Self.self_store ();
237 parse ();
238 let plugins = BslPluginTable.finalize () in
239 let module B = BslLib.BSL in
240 List.iter (fun loader -> B.RegisterInterface.dynload loader.BPI.dynloader) plugins;
241 let bymap = B.RegisterTable.build_bypass_map () in
242 let opabsl =
243 let fold key bypass acc =
244 let fold acc impl =
245 let tags = B.Implementation.bsltags impl in
246 if tags.BslTags.opacapi
247 then StringSet.add (BslKey.to_string key) acc
248 else acc
249 in
250 let impls = B.ByPass.all_implementations bypass in
251 List.fold_left fold acc impls
252 in
253 B.ByPassMap.fold fold bymap StringSet.empty
254 in
255
256 let opacapi =
257 Hashtbl.fold
258 (fun key _ acc -> StringSet.add (BslKey.to_string key) acc)
259 Opacapi.Opabsl.table StringSet.empty in
260 strict_equality "bypass" "opabsl" "opacapi" opabsl opacapi;
261 (* Get the code of stdlib *)
262 let codes = MutableList.fold_right (fold (fun hd tl -> hd::tl)) files [] in
263 (* Part 2: stdlib VS opacapi *)
264 let stdlib = List.fold_left stdlib StringSet.empty codes in
265 let stdlib = List.fold_left (fun acc ident -> StringSet.add ident acc) stdlib core_types in
266 (* THIS LINE IS AN HACK - SHOW COMMIT WHERE I AM INTRODUCES*)
267 let stdlib = StringSet.add "``" stdlib in
268 let opacapi =
269 Hashtbl.fold
270 (fun ident _ acc -> StringSet.add ident acc)
271 Opacapi.table StringSet.empty in
272 strict_equality "ident" "stdlib" "opacapi" stdlib opacapi;
273 if not !validation_ok then exit 1;
274 (* Part 3: collect position where bypass are used *)
275 let opacapi_pos = FilePos.nopos "opacapi" in
276 let locmap = LocMap.empty in
277 let locmap =
278 Hashtbl.fold
279 (fun key _ acc -> LocMap.append key opacapi_pos acc)
280 Opacapi.Opabsl.table locmap in
281 let locmap =
282 let fold acc (e, annot) =
283 match e with
284 | SA.Bypass key ->
285 let pos = QmlLoc.pos annot in
286 LocMap.append key pos acc
287 | _ -> acc
288 in
289 let fold = OpaWalk.Code.fold fold in
290 List.fold_left fold locmap codes
291 in
292 (* Part 4: generate the log *)
293 let oc, close_out =
294 match !target with
295 | Some file -> (
296 try
297 Pervasives.open_out file
298 with
299 | Sys_error s ->
300 OManager.error "cannot open_out %s : %s" file s
301 ), Pervasives.close_out_noerr
302
303 | None ->
304 Pervasives.stdout, (fun _ -> ())
305 in
306 let fmt = Format.formatter_of_out_channel oc in
307 let iter key locs =
308 Format.fprintf fmt "@[<2>%a:@\n%a@]@\n"
309 BslKey.pp key (Format.pp_list "@\n" FilePos.pp_pos) locs
310 in
311 LocMap.iter iter locmap;
312 (* Part 5: notify bypass which are not used *)
313 let both_unused = ref [] in
314 let client_unused = ref [] in
315 let server_unused = ref [] in
316 let all_bypass = ref 0 in
317 let unused_bypass = ref 0 in
318 let iter key bypass =
319 incr(all_bypass);
320 match LocMap.find_opt key locmap with
321 | Some [] | None ->
322 (* This means that a bypass is registred, but never used in the stdlib. *)
323 let table =
324 if B.ByPass.implemented_in bypass ~lang:BslLanguage.js
325 then
326 if B.ByPass.implemented_in bypass ~lang:BslLanguage.ml
327 then both_unused
328 else client_unused
329 else
330 if B.ByPass.implemented_in bypass ~lang:BslLanguage.ml
331 then server_unused
332 else (
333 OManager.printf "checkopacapi: %a@\n" BslKey.pp key ;
334 assert false
335 )
336 in
337 incr(unused_bypass);
338 table := key :: !table
339 | _ -> ()
340 in
341 B.ByPassMap.iter iter bymap ;
342 let notify kind table =
343 let num = ref 0 in
344 let list = List.rev_map (fun t -> incr(num); t) !table in
345 if !num > 0
346 then (
347 Format.fprintf fmt (
348 "Warning: the %d following bypass implemented @@%s are unused:@\n"
349 ) !num kind;
350 List.iter (fun key -> Format.fprintf fmt "%a@\n" BslKey.pp key) list
351 );
352 !num
353 in
354 let num_both = notify "both" both_unused in
355 let num_client = notify "client" client_unused in
356 let num_server = notify "server" server_unused in
357 let percent =
358 (float_of_int !unused_bypass) /. (float_of_int !all_bypass) *. 100.
359 in
360 Format.pp_print_flush fmt ();
361 close_out oc;
362 if !unused_bypass > 0 then
363 OManager.printf (
364 "@{<yellow>Warning@}: opabsl contains %f %% of unused bypass: (%d / %d)@\n"^^
365 " %d both@\n"^^
366 " %d client@\n"^^
367 " %d server@\n"^^
368 "cf file @{<bright>opacapi.validation@} for details@\n"
369 )
370 percent
371 !unused_bypass
372 !all_bypass
373 num_both
374 num_client
375 num_server
376 ;
377 exit 0
Something went wrong with that request. Please try again.