Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 379 lines (332 sloc) 10.717 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 =
9a4a8ee [enhance] help/manpages: global pass for improving help messages of O…
Mathieu Baudet authored
111 !> "@{<bright>%s@}: Opa Compiler Interface Validator %s\nUsage: %s [options] stdlib-files\n"
fccc685 Initial open-source release
MLstate authored
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
9a4a8ee [enhance] help/manpages: global pass for improving help messages of O…
Mathieu Baudet authored
126 Arg.parse spec anon_fun (usage_msg^"Options:")
fccc685 Initial open-source release
MLstate authored
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
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
183 then StringSet.add ident.SA.ident acc
fccc685 Initial open-source release
MLstate authored
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 *)
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
205 let report elt name present absent set =
fccc685 Initial open-source release
MLstate authored
206 validation_ok := false ;
207 OManager.printf (
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
208 "[!] The %s @{<bright>%s@} is present in @{<bright>%s@} but not in @{<bright>%s@}@\n@{<bright>%s@} set: %a@.@."
fccc685 Initial open-source release
MLstate authored
209 )
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
210 elt name present absent absent
211 (StringSet.pp "," Format.pp_print_string) set
fccc685 Initial open-source release
MLstate authored
212
213 let strict_equality elt name1 name2 set1 set2 =
214 let iter name1 name2 set1 set2 =
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
215 let error name = report elt name name1 name2 set2 in
fccc685 Initial open-source release
MLstate authored
216 StringSet.iter (fun s -> if not (StringSet.mem s set2) then error s) set1
217 in
218 iter name1 name2 set1 set2;
219 iter name2 name1 set2 set1
220
221 module LocMap = ListMap.Make(BslKey)
222
223
224 let core_types =
225 [
226 "char";
227 "float";
228 "int";
229 "OPA.Init.value";
230 "string";
231 "tuple_2";
232 "void";
233 ]
234
235 let _ =
236 (* Part 1: bsl VS opacapi *)
237 OpabslgenPlugin.Self.self_store ();
238 parse ();
239 let plugins = BslPluginTable.finalize () in
240 let module B = BslLib.BSL in
241 List.iter (fun loader -> B.RegisterInterface.dynload loader.BPI.dynloader) plugins;
242 let bymap = B.RegisterTable.build_bypass_map () in
243 let opabsl =
244 let fold key bypass acc =
245 let fold acc impl =
246 let tags = B.Implementation.bsltags impl in
247 if tags.BslTags.opacapi
248 then StringSet.add (BslKey.to_string key) acc
249 else acc
250 in
251 let impls = B.ByPass.all_implementations bypass in
252 List.fold_left fold acc impls
253 in
254 B.ByPassMap.fold fold bymap StringSet.empty
255 in
256
257 let opacapi =
258 Hashtbl.fold
259 (fun key _ acc -> StringSet.add (BslKey.to_string key) acc)
260 Opacapi.Opabsl.table StringSet.empty in
261 strict_equality "bypass" "opabsl" "opacapi" opabsl opacapi;
262 (* Get the code of stdlib *)
263 let codes = MutableList.fold_right (fold (fun hd tl -> hd::tl)) files [] in
264 (* Part 2: stdlib VS opacapi *)
265 let stdlib = List.fold_left stdlib StringSet.empty codes in
266 let stdlib = List.fold_left (fun acc ident -> StringSet.add ident acc) stdlib core_types in
267 (* THIS LINE IS AN HACK - SHOW COMMIT WHERE I AM INTRODUCES*)
268 let stdlib = StringSet.add "``" stdlib in
269 let opacapi =
270 Hashtbl.fold
271 (fun ident _ acc -> StringSet.add ident acc)
272 Opacapi.table StringSet.empty in
273 strict_equality "ident" "stdlib" "opacapi" stdlib opacapi;
274 if not !validation_ok then exit 1;
275 (* Part 3: collect position where bypass are used *)
276 let opacapi_pos = FilePos.nopos "opacapi" in
277 let locmap = LocMap.empty in
278 let locmap =
279 Hashtbl.fold
280 (fun key _ acc -> LocMap.append key opacapi_pos acc)
281 Opacapi.Opabsl.table locmap in
282 let locmap =
283 let fold acc (e, annot) =
284 match e with
285 | SA.Bypass key ->
286 let pos = QmlLoc.pos annot in
287 LocMap.append key pos acc
288 | _ -> acc
289 in
290 let fold = OpaWalk.Code.fold fold in
291 List.fold_left fold locmap codes
292 in
293 (* Part 4: generate the log *)
294 let oc, close_out =
295 match !target with
296 | Some file -> (
297 try
298 Pervasives.open_out file
299 with
300 | Sys_error s ->
301 OManager.error "cannot open_out %s : %s" file s
302 ), Pervasives.close_out_noerr
303
304 | None ->
305 Pervasives.stdout, (fun _ -> ())
306 in
307 let fmt = Format.formatter_of_out_channel oc in
308 let iter key locs =
309 Format.fprintf fmt "@[<2>%a:@\n%a@]@\n"
310 BslKey.pp key (Format.pp_list "@\n" FilePos.pp_pos) locs
311 in
312 LocMap.iter iter locmap;
313 (* Part 5: notify bypass which are not used *)
314 let both_unused = ref [] in
315 let client_unused = ref [] in
316 let server_unused = ref [] in
317 let all_bypass = ref 0 in
318 let unused_bypass = ref 0 in
319 let iter key bypass =
320 incr(all_bypass);
321 match LocMap.find_opt key locmap with
322 | Some [] | None ->
323 (* This means that a bypass is registred, but never used in the stdlib. *)
324 let table =
325 if B.ByPass.implemented_in bypass ~lang:BslLanguage.js
326 then
327 if B.ByPass.implemented_in bypass ~lang:BslLanguage.ml
328 then both_unused
329 else client_unused
330 else
331 if B.ByPass.implemented_in bypass ~lang:BslLanguage.ml
332 then server_unused
333 else (
334 OManager.printf "checkopacapi: %a@\n" BslKey.pp key ;
335 assert false
336 )
337 in
338 incr(unused_bypass);
339 table := key :: !table
340 | _ -> ()
341 in
342 B.ByPassMap.iter iter bymap ;
343 let notify kind table =
344 let num = ref 0 in
345 let list = List.rev_map (fun t -> incr(num); t) !table in
346 if !num > 0
347 then (
348 Format.fprintf fmt (
349 "Warning: the %d following bypass implemented @@%s are unused:@\n"
350 ) !num kind;
351 List.iter (fun key -> Format.fprintf fmt "%a@\n" BslKey.pp key) list
352 );
353 !num
354 in
355 let num_both = notify "both" both_unused in
356 let num_client = notify "client" client_unused in
357 let num_server = notify "server" server_unused in
358 let percent =
359 (float_of_int !unused_bypass) /. (float_of_int !all_bypass) *. 100.
360 in
361 Format.pp_print_flush fmt ();
362 close_out oc;
363 if !unused_bypass > 0 then
364 OManager.printf (
365 "@{<yellow>Warning@}: opabsl contains %f %% of unused bypass: (%d / %d)@\n"^^
366 " %d both@\n"^^
367 " %d client@\n"^^
368 " %d server@\n"^^
369 "cf file @{<bright>opacapi.validation@} for details@\n"
370 )
371 percent
372 !unused_bypass
373 !all_bypass
374 num_both
375 num_client
376 num_server
377 ;
378 exit 0
Something went wrong with that request. Please try again.