Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

390 lines (342 sloc) 11.233 kB
(*
Copyright © 2011, 2012 MLstate
This file is part of Opa.
Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
(**
Checking consistency between opabsl, stdlib et opacapi.
@author Mathieu Barbin
*)
(**
Opa COMPILER INTERFACE:
The Opa compiler needs to insert some call to identifiers and external primitives
defined in the stdlib, and in the opabsl. The set of these identifers and primitives
is called : opa-compiler-interface.
We want to be able, by reading the definition of a bypass, or by reading the definition
of a identifier in the stdlib, to know if it is part of this compiler interface.
It is necessary to have a better control on dependency between the stdlib, and the compiler.
(consistency, maintenance, etc.)
For that purpose, we decorate the opa-compiler-interface in the stdlib and opabsl,
and we use opacapi in the compiler.
STDLIB:
{[
@opacapi myfunction()=....
]}
OPABSL:
{[
##register [opacapi] mybypass : ...
]}
OPACAPI:
{[
mybypass = "mybypass"
myfunction = "myfunction"
]}
COMPILER:
{[
let myfunction = Opacapi.myfunction in
...
]}
This check will ensure that :
-the set of all identifier defined in opacapi is strictly equal to the set of identifiers
decorated with the directive [@opacapi] in the stdlib,
-the set of all bypass defined in opacapi is strictly equal to the set of bypasses
decorated with the property [opacapi] in the opabsl
If a bypass is not in opacapi, nor present in the stdlib, there will be a notification.
Since it is not yet clear what we want to do with such cases, currently a warning
is printed.
A file is generated indicating for each bsl-key the list of location where it is used.
*)
(* depends *)
module Arg = Base.Arg
module Format = Base.Format
(* shorthand *)
module BPI = BslPluginInterface
module D = SurfaceAstDecons
module Q = QmlAst
module SA = SurfaceAst
(* -- *)
let _ = OpaSyntax.Args.r := {!OpaSyntax.Args.r with OpaSyntax.Args.parser = OpaSyntax.Classic}
let validation_ok = ref true
(* f *)
let files = MutableList.create ()
let fopps = MutableList.create ()
(* t *)
let target = ref None
let (|>) = InfixOperator.(|>)
let (!>) = Format.sprintf
let spec = [
(* o *)
"-o",
Arg.String (fun t -> target := Some t),
!>
" specify a target for the trace file"
]
let anon_fun file =
let ext = File.extension file in
match ext with
| "opa" -> MutableList.add files file
| "opp" -> MutableList.add fopps file
| _ -> OManager.error "Error with @{<bright>%S@} because file extension @{<bright>%S@} is unknown" file ext
let usage_msg =
!> "@{<bright>%s@}: Opa Compiler Interface Validator %s\nUsage: %s [options] stdlib-files\n"
Sys.argv.(0) BuildInfos.version_id
Sys.argv.(0)
let parse () =
let spec = (
(OManager.Arg.version "checkopacapi" :: OManager.Arg.options) @
spec
)
|> Arg.add_bash_completion
|> Arg.sort
|> Arg.align
in
Arg.parse spec anon_fun (usage_msg^"Options:")
(**
Folding input file, and applying a fold on the parsed code
*)
(**
pplib specification
*)
let pplib_spec = [
"OPA_CPS", "" ;
"OPA_BADOP", "1" ;
]
let pprocess =
let ppenv = Pprocess.fill_with_sysenv Pprocess.empty_env in
let ppenv = List.fold_left (fun ppenv (var, value) -> Pprocess.add_env var value ppenv) ppenv pplib_spec in
let ppopt = Pprocess.default_options ppenv in
Pprocess.process Pplang.opa_description ppopt
let fold
( fold : (SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.code -> 'acc -> 'acc )
filename acc =
(* print_endline filename; *)
match File.content_opt filename with
| None ->
OManager.error "[!] I/O error: cannot read file @{<bright>%S@}" filename
| Some content ->
let content = pprocess ~name:filename content in
let code = OpaParser.code ~cache:true ~filename content in
fold code acc
(**
Specialized fold, for gathering opacapi directives
*)
let is_opacapi e =
D.Look.at
~through:[
D.Remove.Basic.access_directive ;
D.Remove.Basic.expand ;
D.Remove.Basic.coerce ;
D.Remove.Basic.deprecated ;
D.Remove.Basic.magic_directive ;
D.Remove.Basic.slicer_directive ;
]
~at:[D.Remove.Basic.opacapi]
e
let stdlib acc code =
let fold_elt acc (elt, _) =
match elt with
| SA.NewVal (binds, _) ->
let fold acc ((p, _), e) =
match p with
| SA.PatVar ident | SA.PatAs (_, ident) ->
if is_opacapi e
then StringSet.add ident.SA.ident acc
else acc
| _ -> acc
in
List.fold_left fold acc binds
| SA.NewType typedefs ->
let fold acc (typedef, _) =
if typedef.SA.ty_def_options.Q.opacapi
then
let (SA.Typeident ident) = typedef.SA.ty_def_name in
StringSet.add ident acc
else
acc
in
List.fold_left fold acc typedefs
| _ -> acc
in
List.fold_left fold_elt acc code
(**
Check strict equality between 2 StringSet, with errors reporting.
*)
let report elt name present absent set =
validation_ok := false ;
OManager.printf (
"[!] The %s @{<bright>%s@} is present in @{<bright>%s@} but not in @{<bright>%s@}@\n@{<bright>%s@} set: %a@.@."
)
elt name present absent absent
(StringSet.pp "," Format.pp_print_string) set
let strict_equality elt name1 name2 set1 set2 =
let iter name1 name2 set1 set2 =
let error name = report elt name name1 name2 set2 in
StringSet.iter (fun s -> if not (StringSet.mem s set2) then error s) set1
in
iter name1 name2 set1 set2;
iter name2 name1 set2 set1
module LocMap = ListMap.Make(BslKey)
let core_types =
[
"float";
"int";
"OPA.Init.value";
"string";
"tuple_2";
"void";
]
let _ =
(* Part 1: plugins VS opacapi *)
OpabslPlugin.Self.self_store ();
parse ();
let cwd = Sys.getcwd () in
MutableList.iter
(fun opp ->
let plugin = BslConvention.inclusion ~cwd opp in
BslDynlink.load_bypass_plugin (BslDynlink.MarshalPlugin plugin.BslConvention.plugin))
fopps;
let plugins = BslPluginTable.finalize () in
let module B = BslLib.BSL in
List.iter (fun loader -> B.RegisterInterface.dynload loader.BPI.dynloader) plugins;
let bymap = B.RegisterTable.build_bypass_map () in
let opabsl =
let fold key bypass acc =
let fold acc impl =
let tags = B.Implementation.bsltags impl in
if tags.BslTags.opacapi
then StringSet.add (BslKey.to_string key) acc
else acc
in
let impls = B.ByPass.all_implementations bypass in
List.fold_left fold acc impls
in
B.ByPassMap.fold fold bymap StringSet.empty
in
let opacapi =
Hashtbl.fold
(fun key _ acc -> StringSet.add (BslKey.to_string key) acc)
Opacapi.Opabsl.table StringSet.empty in
strict_equality "bypass" "opabsl" "opacapi" opabsl opacapi;
(* Get the code of stdlib *)
let codes = MutableList.fold_right (fold (fun hd tl -> hd::tl)) files [] in
(* Part 2: stdlib VS opacapi *)
let stdlib = List.fold_left stdlib StringSet.empty codes in
let stdlib = List.fold_left (fun acc ident -> StringSet.add ident acc) stdlib core_types in
(* THIS LINE IS AN HACK - SHOW COMMIT WHERE I AM INTRODUCES*)
let stdlib = StringSet.add "``" stdlib in
let opacapi =
Hashtbl.fold
(fun ident _ acc -> StringSet.add ident acc)
Opacapi.table StringSet.empty in
strict_equality "ident" "stdlib" "opacapi" stdlib opacapi;
if not !validation_ok then exit 1;
(* Part 3: collect position where bypass are used *)
let opacapi_pos = FilePos.nopos "opacapi" in
let locmap = LocMap.empty in
let locmap =
Hashtbl.fold
(fun key _ acc -> LocMap.append key opacapi_pos acc)
Opacapi.Opabsl.table locmap in
let locmap =
let fold acc (e, annot) =
match e with
| SA.Bypass key ->
let pos = QmlLoc.pos annot in
LocMap.append key pos acc
| _ -> acc
in
let fold = OpaWalk.Code.fold fold in
List.fold_left fold locmap codes
in
(* Part 4: generate the log *)
let oc, close_out =
match !target with
| Some file -> (
try
Pervasives.open_out file
with
| Sys_error s ->
OManager.error "cannot open_out %s : %s" file s
), Pervasives.close_out_noerr
| None ->
Pervasives.stdout, (fun _ -> ())
in
let fmt = Format.formatter_of_out_channel oc in
let iter key locs =
Format.fprintf fmt "@[<2>%a:@\n%a@]@\n"
BslKey.pp key (Format.pp_list "@\n" FilePos.pp_pos) locs
in
LocMap.iter iter locmap;
(* Part 5: notify bypass which are not used *)
let both_unused = ref [] in
let client_unused = ref [] in
let server_unused = ref [] in
let all_bypass = ref 0 in
let unused_bypass = ref 0 in
let iter key bypass =
incr(all_bypass);
match LocMap.find_opt key locmap with
| Some [] | None ->
(* This means that a bypass is registred, but never used in the stdlib. *)
let table =
if B.ByPass.implemented_in bypass ~lang:BslLanguage.js
then
if B.ByPass.implemented_in bypass ~lang:BslLanguage.ml
then both_unused
else client_unused
else
if B.ByPass.implemented_in bypass ~lang:BslLanguage.ml
then server_unused
else (
OManager.i_error "checkopacapi: %a@\n" BslKey.pp key ;
)
in
incr(unused_bypass);
table := key :: !table
| _ -> ()
in
B.ByPassMap.iter iter bymap ;
let notify kind table =
let num = ref 0 in
let list = List.rev_map (fun t -> incr(num); t) !table in
if !num > 0
then (
Format.fprintf fmt (
"Warning: the %d following bypass implemented @@%s are unused:@\n"
) !num kind;
List.iter (fun key -> Format.fprintf fmt "%a@\n" BslKey.pp key) list
);
!num
in
let num_both = notify "both" both_unused in
let num_client = notify "client" client_unused in
let num_server = notify "server" server_unused in
let percent =
(float_of_int !unused_bypass) /. (float_of_int !all_bypass) *. 100.
in
Format.pp_print_flush fmt ();
close_out oc;
if !unused_bypass > 0 then
OManager.printf (
"@{<yellow>Warning@}: opabsl contains %f %% of unused bypass: (%d / %d)@\n"^^
" %d both@\n"^^
" %d client@\n"^^
" %d server@\n"^^
"cf file @{<bright>opacapi.validation@} for details@\n"
)
percent
!unused_bypass
!all_bypass
num_both
num_client
num_server
;
exit 0
Jump to Line
Something went wrong with that request. Please try again.