Skip to content
This repository
tree: acf1c6a467
Fetching contributors…

Cannot retrieve contributors at this time

file 538 lines (475 sloc) 18.399 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
(*
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/>.
*)
(* depends *)
module Format = BaseFormat
module Hashtbl = BaseHashtbl
module List = BaseList
module String = BaseString

(* alias *)

(* shorthands *)
module BPI = BslPluginInterface
module O = OpaEnv
module SA = SurfaceAst

(* -- *)

let debug fmt =
  OManager.printf ("@{<cyan>[Bsl]@}@ @[<2>"^^fmt^^"@]@.")

(*
The plugins are accumulated during the compilation, as well as the extralib and extrapaths
needed for using them.

A warning is nevertheless produced by the bypass typer when a bypass is normaly not in
the scope of the current package.
This appears only in autobuild mode, e.g. compiling a package B after a package A,
when :
-the package A imports the plugin P
-the package B does not imports the plugin P
-B uses bypass from P

This situation works because of the side effects accumulated there,
but the user is just warned that if he would try to compile the package B separatly,
it would not work, and invite him to add the import-plugin P in the package B.
*)

(*
The plugin basename, without the opp extesion
*)
type plugin_name = string

module S =
struct
  type entry = {
    plugin_name : plugin_name ;
    extralib : string ;
    extrapath : string ;
    bypass : string ;
  }
  type t = entry list
  let pass = "BslLoading"
  let pp_entry fmt e =
    Format.fprintf fmt "@[<2>Entry: {@\nplugin_name:%S@\nextralib:%S@\nextrapath:%S@\nbypass:%S@]}@]"
      e.plugin_name
      e.extralib
      e.extrapath
      e.bypass
  let pp = Format.pp_list "@\n" pp_entry

  let make plugin_name extralib extrapath bypass = {
    plugin_name ;
    extralib ;
    extrapath ;
    bypass ;
  }
end

module R = ObjectFiles.Make(S)

module Separation :
sig
  type t
  val create : unit -> t
  val add : t -> S.entry -> unit
  val get : t -> S.t
end =
struct
  type t = S.entry list ref
  let create () = ref []
  let add t s = t := s :: !t
  let get t = !t
end

let already_seen_plugin : (plugin_name, plugin_name) Hashtbl.t = Hashtbl.create 16

(*
We accumulate the extralib and extrapath implied by the seen plugins,
and add it in the topologic order of plugins (after finalization).
*)

let extralib_plugin : (plugin_name, string) Hashtbl.t = Hashtbl.create 16
let extrapath_plugin : (plugin_name, string) Hashtbl.t = Hashtbl.create 16

let reset () =
  BslDynlink.reset_cache ();
  BslPluginTable.clear ();
  Hashtbl.clear already_seen_plugin;
  Hashtbl.clear extrapath_plugin;
  Hashtbl.clear extralib_plugin

let pp_options fmt options =
  let pp = DebugPrint.pp ~depth:max_int in
  Format.fprintf fmt "cclib: %a@\n" pp options.O.cclib ;
  Format.fprintf fmt "ccopt: %a@\n" pp options.O.ccopt ;
  Format.fprintf fmt "mllopt: %a@\n" pp options.O.mllopt ;
  Format.fprintf fmt "mlcopt: %a@\n" pp options.O.mlcopt ;
  Format.fprintf fmt "extrapath: %a@\n" pp options.O.extrapath ;
  Format.fprintf fmt "extralibs: %a@\n" pp options.O.extralibs ;
  ()

(*
Add in the options the needed extralib and extrapath implies by the topologic
order of plugins given.
This add at the end of already present lib and path, if there are not already there.
*)
let upgrade_options plugins options =
  let make_tbl list =
    let tab = Hashtbl.create 16 in
    let () = List.iter (fun lib -> Hashtbl.add tab lib ()) list in
    tab
  in

  (* options implied by the dependencies of the plugins *)
  let t_cclib = make_tbl options.O.cclib in
  let t_ccopt = make_tbl options.O.ccopt in
  let t_mllopt = make_tbl options.O.mllopt in
  let t_mlcopt = make_tbl options.O.mlcopt in
  let t_extrapath = make_tbl options.O.extrapath in
  let t_extralibs = make_tbl options.O.extralibs in

  let rev_filter_append present list old = List.fold_left
    (fun rev elt -> if Hashtbl.mem present elt then rev else elt::rev)
    old list
  in

  let upgrade_from_properties (rev_cclib, rev_ccopt, rev_mllopt, rev_mlcopt, rev_extrapath, rev_extralibs) properties =
    let rev_cclib = rev_filter_append t_cclib properties.BslConf.cclib rev_cclib in
    let rev_ccopt = rev_filter_append t_ccopt properties.BslConf.ccopt rev_ccopt in
    let rev_mlcopt = rev_filter_append t_mlcopt properties.BslConf.mlcopt rev_mlcopt in
    let rev_mllopt = rev_filter_append t_mllopt properties.BslConf.mllopt rev_mllopt in
    let rev_extrapath = rev_filter_append t_extrapath properties.BslConf.mlinclude rev_extrapath in
    let rev_extralibs = rev_filter_append t_extralibs properties.BslConf.mllibs rev_extralibs in
    (rev_cclib, rev_ccopt, rev_mllopt, rev_mlcopt, rev_extrapath, rev_extralibs)
  in

  let rev_cclib, rev_ccopt, rev_mllopt, rev_mlcopt, rev_extrapath, rev_extralibs =
    List.fold_left
      (fun rev_stuffs plugin ->
         let conf = plugin.BPI.conf in
         (* All platform *)
         let properties = conf.BslConf.all_platform in
         let rev_stuffs = upgrade_from_properties rev_stuffs properties in

         (* Platform specificities *)
         let platform =
           let open Mlstate_platform in
           match mlstate_platform with
           | Unix -> conf.BslConf.linux
           | Windows -> conf.BslConf.windows
           | Cygwin -> conf.BslConf.cygwin
         in
         let rev_stuffs = Option.fold upgrade_from_properties rev_stuffs platform in
         rev_stuffs
      )
      ([], [], [], [], [], [])
      plugins
  in

  let cclib = options.O.cclib @ (List.rev rev_cclib) in
  let ccopt = options.O.ccopt @ (List.rev rev_ccopt) in
  let mllopt = options.O.mllopt @ (List.rev rev_mllopt) in
  let mlcopt = options.O.mlcopt @ (List.rev rev_mlcopt) in
  let extrapath = options.O.extrapath @ (List.rev rev_extrapath) in
  let extralibs = options.O.extralibs @ (List.rev rev_extralibs) in

  (* options implied by the plugins *)

  let t_bypass_plugins = make_tbl options.O.bypass_plugin in
  let t_extralibs = make_tbl extralibs in
  let t_extrapath = make_tbl extrapath in

  let rev_acc present to_add plugins = List.fold_left
    (fun rev plugin ->
       match plugin.BPI.basename with
       (* Bundled plugins do not need to be included *)
       | None -> rev
       | Some plugin_name ->
         let rev =
           match Hashtbl.find_opt to_add plugin_name with
           | None -> rev
           | Some add ->
             if Hashtbl.mem present add
             then rev
             else add::rev
         in
         rev) [] plugins
  in

  let server_plugins = List.filter (fun plugin ->
    plugin.BPI.has_server_code
  ) plugins in
  let rev_plugins = rev_acc t_bypass_plugins already_seen_plugin plugins in
  let rev_libs = rev_acc t_extralibs extralib_plugin server_plugins in
  let rev_path = rev_acc t_extrapath extrapath_plugin plugins in

  let bypass_plugin = options.O.bypass_plugin @ (List.rev rev_plugins) in
  let extralibs = extralibs @ (List.rev rev_libs) in
  let extrapath = extrapath @ (List.rev rev_path) in

  { options
    with OpaEnv.
      cclib ;
      ccopt ;
      mllopt ;
      mlcopt ;
      bypass_plugin ;
      extralibs ;
      extrapath ;
  }

let resolve_entry search_path entry =
  let { S.plugin_name = basename ; extralib ; extrapath ; bypass } = entry in
  match Filename.is_relative extrapath with
  | false -> entry
  | true ->
      (* Searching plugin in extra path... *)
      let candidates = List.fold_left
        (fun acc p ->
           let fullname = Filename.concat p extrapath in
           if List.mem fullname acc then
             acc
           else (
             #<If:BSL_LOADING>
             OManager.verbose "Seraching %s on %s => %s : %b" extrapath
               p fullname (File.is_directory fullname)
             #<Else>
             ()
             #<End>;
             if File.is_directory fullname then fullname :: acc else acc
           )
        ) [] search_path in
      let aux extrapath =
        OManager.verbose "Select %s" extrapath;
        {S.plugin_name = basename; extralib; extrapath;
         bypass = Filename.concat extrapath (Filename.basename bypass)} in
      match candidates with
      | [] -> entry
      | [extrapath] -> aux extrapath
      | extrapath::_ as places ->
          OManager.warning ~wclass:WarningClass.bsl_loading
            "@\nThe plugin @{<bright>%S@} is found in several places :\n(%s).@\nI will use @{<bright>%S@}"
            basename
            (String.concat "; " places)
            extrapath ;
          aux extrapath

module StringOptCompare : (OrderedTypeSig.S with type t = string option) =
struct
  type t = string option
  let compare a b = Option.make_compare String.compare a b
end

module StringOptSet = BaseSet.Make(StringOptCompare)

(* Return plugins listed in [plugins] that are directly mentioned by
[code]. The compiler currently outputs direct calls to opabsl, so
we must include that as well even if the code doesn't explicitely
mention it. *)
let find_used_plugins bypass_map code =
  let collect_bypasses used_bypasses (expr, _) =
    match expr with
    | SA.Bypass key -> BslKeySet.add key used_bypasses
    | _ -> used_bypasses in
  let used_bypasses = List.fold_left (fun used_bypasses (_, _, code) ->
    OpaWalk.Code.fold collect_bypasses used_bypasses code
  ) BslKeySet.empty code in
  let used_plugins_names =
    BslLib.BSL.ByPassMap.fold (fun key bypass used_plugins_names ->
      if BslKeySet.mem key used_bypasses then
        StringOptSet.add (BslLib.BSL.ByPass.plugin_name bypass) used_plugins_names
      else
        used_plugins_names
    ) bypass_map (StringOptSet.singleton (Some "opabsl")) in
  used_plugins_names

let process
    ~options
    ~code
    =
  reset ();
  (* Pass *)
  let plugins = "opabsl" :: options.O.bypass_plugin in
  let server_back_end = options.O.back_end in
  let client_back_end = options.O.js_back_end in
  let cwd = Sys.getcwd () in
  let search_path = cwd :: ObjectFiles.get_paths () in

  (* Separated compilation: loading *)
  let () =
    let iter (package_name, _) entries =
      let iter_entry entry =
        let { S.plugin_name = basename ; extralib ; extrapath ; bypass } = resolve_entry search_path entry in
        if not (Hashtbl.mem already_seen_plugin basename)
        then (
          BslLib.declare_visibility package_name basename ;
          Hashtbl.add already_seen_plugin basename basename ;
          Hashtbl.add extralib_plugin basename extralib ;
          Hashtbl.add extrapath_plugin basename extrapath ;
          BslDynlink.load_bypass_plugin_cache (BslDynlink.MarshalPlugin bypass) ;
        )
      in
      List.iter iter_entry entries
    in
    R.iter_with_name ~packages:true ~deep:true iter
  in
  let separation = Separation.create () in

  let commandline = FilePos.nopos "command line" in
  let plugins = List.map (fun p -> (p, commandline)) plugins in

  (*
Collect plugin from code and add then in the plugins list.
Resolve the found location for these plugins (using also by default
the location in the InstallDir)
*)
  let code, imported_plugins =
    let imported_plugins = ref [] in
    let filter = function
      | SA.Package (`import_plugin, name), label ->
          let pos = label.QmlLoc.pos in
          let names = [] in (* maybe give plugin from command line *)
          let targets = ObjectFiles.expand_glob ~mode:`plugin names (name, pos) in
          let () =
            #<If:BSL_LOADING $contains "import">
              debug "import-plugin: %a" (Format.pp_list " ; " (Format.pp_fst Format.pp_print_string)) targets
            #<End>
          in
          imported_plugins := List.rev_append targets !imported_plugins ;
          false
      | _ -> true
    in
    let code = List.tail_map
      (fun (filename, content, code) ->
         let code = List.filter filter code in
         (filename, content, code)) code
    in
    code, !imported_plugins
  in
  let plugins = List.rev_append imported_plugins plugins in

  (*
Normalization of plugin name: add extension if not present
*)
  let suffix = "." ^ BslConvention.Extension.plugin in
  let plugins = List.rev_map
    (fun (name, pos) ->
       let name = if String.is_suffix suffix name then name else name^suffix in
       name, pos
    ) plugins in

  let package_name = ObjectFiles.get_current_package_name () in

  (* Search additional plug-ins.*)
  List.iter (
    fun (bypass_plugin, pos) ->
      (* the bypass_plugin is containing the extension opp *)
      let basename = Filename.basename bypass_plugin in
      let basename = File.chop_extension basename in

      (*
There we can add an information of bypass visibility:
The current package is in the scope of visibility of the plugin basename.
This can be used for adding a warning about missing dependencies detected in autobuild.
*)
      BslLib.declare_visibility package_name basename ;

      if not (Hashtbl.mem already_seen_plugin basename)
      then (
        Hashtbl.add already_seen_plugin basename basename ;

        let filename =
          if Filename.is_relative bypass_plugin
          then
            (*
We should find it in the searched path
*)

            let found_files = List.filter_map
              (fun p ->
                 let fullname = Filename.concat p bypass_plugin in
                 if File.is_directory fullname then Some fullname else None
              ) search_path in
            let file = match found_files with
              | [] -> bypass_plugin
              | [fullname] -> fullname
              | fullname::_ ->
                  OManager.warning ~wclass:WarningClass.bsl_loading
                    "%a@\nThe plugin @{<bright>%S@} is found in several places.@\nI will use @{<bright>%S@}"
                    FilePos.pp pos
                    bypass_plugin
                    fullname ;
                  fullname
            in
            file
          else bypass_plugin
        in

        let () =
          if not (File.is_directory filename)
          then
            OManager.error "%a@\nI/O error: cannot find @{<bright>%S@} on %s" FilePos.pp pos filename
              (String.concat "; " search_path);
        in

        let inclusion = BslConvention.inclusion ~cwd filename in
        let extralib = inclusion.BslConvention.extralib in
        let extrapath = inclusion.BslConvention.extrapath in
        let plugin = inclusion.BslConvention.plugin in
        Hashtbl.add extralib_plugin basename extralib ;
        Hashtbl.add extrapath_plugin basename extrapath ;
        BslDynlink.load_bypass_plugin (BslDynlink.MarshalPlugin plugin) ;
        let inclusion =
          let bypass_plugin =
            if (BslArgs.get ()).BslArgs.no_absolute then
              Filename.basename bypass_plugin
            else bypass_plugin
          in
          BslConvention.inclusion ~cwd:"" bypass_plugin in
        let extralib = inclusion.BslConvention.extralib in
        let extrapath = inclusion.BslConvention.extrapath in
        let plugin = inclusion.BslConvention.plugin in
        Separation.add separation (S.make basename extralib extrapath plugin)
      )
  ) plugins ;

  (* Resolve dependencies. *)
  let all_plugins = BslPluginTable.finalize () in

  (* upgrade options *)
  let () =
    #<If:BSL_LOADING $contains "options">
      debug "@[<2>options before upgrade: @\n%a@]@\n" pp_options options
    #<End>
  in
  let options = upgrade_options all_plugins options in
  let () =
    #<If:BSL_LOADING $contains "options">
      debug "@[<2>options after upgrade: @\n%a@]@\n" pp_options options
    #<End>
  in

  (* Link with ObjectFiles *)
  let () =
    let t = List.rev_map (fun p -> p.BPI.self_module_name, p.BPI.uniq_id)
      all_plugins in
    ObjectFiles.set_bsl_plugins t
  in

  (*
Actually load plugins.
There is already a mecanism for avoiding multiple loading in the RegisterInterface.
*)
  List.iter (fun loader -> BslLib.BSL.RegisterInterface.dynload
    loader.BPI.dynloader) all_plugins;

  (*
TODO(Mathieu) : if needed only.
It is actually possible to remove this
by coding a table export in libbsl
*)
  let client_back_end_dynload, client_bsl_lang =
    let module M = (val client_back_end : Qml2jsOptions.JsBackend) in
    (M.dynloader, BslLanguage.js) in
  let server_back_end_dynload, server_bsl_lang =
    match server_back_end with
    | `qmlflat -> (Flat_Compiler.dynloader, BslLanguage.ml)
    | `qmljs -> (client_back_end_dynload, BslLanguage.nodejs)
  in
  (* Register plug-ins with actual backend.*)
  List.iter
    (fun plugin ->
       (* ML back-end *)
       server_back_end_dynload plugin ;
       (* js back-end *)
       client_back_end_dynload plugin ;
    ) all_plugins;
  (* Build bypass map *)
  let bymap =
    let lang = [client_bsl_lang; server_bsl_lang] in
    BslLib.BSL.RegisterTable.build_bypass_map
      ~filter:(fun bp -> BslLib.BSL.ByPass.implemented_in_any bp ~lang)
      ()
  in

  let used_plugins_names = find_used_plugins bymap code in

  let all_external_plugins = List.filter (fun plugin ->
    Option.is_some plugin.BPI.basename
  ) all_plugins in

  (* Only plugins that are directly used by the current unit *)
  let direct_external_plugins = List.filter (fun plugin ->
    StringOptSet.mem plugin.BPI.basename used_plugins_names
  ) all_external_plugins in

  let bundled_plugin =
    (* FIXME: Right now, inlining doesn't work well with private
module constants. Therefore, we will include the bundled plugin
in every package, even if it isn't used directly *)
    List.find_opt (fun plugin ->
      Option.is_none plugin.BPI.basename
    ) all_plugins in

  let bsl = { BslLib.
              bymap; all_plugins; all_external_plugins;
              direct_external_plugins; bundled_plugin;
            } in

  (* Separated compilation: saving *)
  let () = R.save (Separation.get separation) in

  options, code, bsl
Something went wrong with that request. Please try again.