Skip to content
Newer
Older
100644 427 lines (369 sloc) 13.7 KB
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
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 (* depends *)
19 module Format = BaseFormat
20 module Hashtbl = BaseHashtbl
21 module List = BaseList
22 module String = BaseString
23
24 (* alias *)
25
26 (* shorthands *)
27 module BPI = BslPluginInterface
28 module O = OpaEnv
29 module SA = SurfaceAst
30
31 (* -- *)
32
33 let debug fmt =
34 OManager.printf ("@{<cyan>[Bsl]@}@ @[<2>"^^fmt^^"@]@.")
35
36 (*
37 The plugins are accumulated during the compilation, as well as the extralib and extrapaths
38 needed for using them.
39
40 A warning is nevertheless produced by the bypass typer when a bypass is normaly not in
41 the scope of the current package.
42 This appears only in autobuild mode, e.g. compiling a package B after a package A,
43 when :
44 -the package A imports the plugin P
45 -the package B does not imports the plugin P
46 -B uses bypass from P
47
48 This situation works because of the side effects accumulated there,
49 but the user is just warned that if he would try to compile the package B separatly,
50 it would not work, and invite him to add the import-plugin P in the package B.
51 *)
52
53 (*
54 The plugin basename, without the opp extesion
55 *)
56 type plugin_name = string
57
58 module S =
59 struct
60 type entry = {
61 plugin_name : plugin_name ;
62 extralib : string ;
63 extrapath : string ;
64 bypass : string ;
65 }
66 type t = entry list
67 let pass = "BslLoading"
68 let pp_entry fmt e =
69 Format.fprintf fmt "@[<2>Entry: {@\nplugin_name:%S@\nextralib:%S@\nextrapath:%S@\nbypass:%S@]}@]"
70 e.plugin_name
71 e.extralib
72 e.extrapath
73 e.bypass
74 let pp = Format.pp_list "@\n" pp_entry
75
76 let make plugin_name extralib extrapath bypass = {
77 plugin_name ;
78 extralib ;
79 extrapath ;
80 bypass ;
81 }
82 end
83
84 module R = ObjectFiles.Make(S)
85
86 module Separation :
87 sig
88 type t
89 val create : unit -> t
90 val add : t -> S.entry -> unit
91 val get : t -> S.t
92 end =
93 struct
94 type t = S.entry list ref
95 let create () = ref []
96 let add t s = t := s :: !t
97 let get t = !t
98 end
99
100 let already_seen_plugin : (plugin_name, plugin_name) Hashtbl.t = Hashtbl.create 16
101
102 (*
103 We accumulate the extralib and extrapath implied by the plugin seens,
104 and add it in the topologic order of plugins (after finalization).
105 *)
106
107 let extralib_plugin : (plugin_name, string) Hashtbl.t = Hashtbl.create 16
108 let extrapath_plugin : (plugin_name, string) Hashtbl.t = Hashtbl.create 16
109
110 let pp_options fmt options =
111 let pp = DebugPrint.pp ~depth:max_int in
112 Format.fprintf fmt "cclib: %a@\n" pp options.O.cclib ;
113 Format.fprintf fmt "ccopt: %a@\n" pp options.O.ccopt ;
114 Format.fprintf fmt "mllopt: %a@\n" pp options.O.mllopt ;
115 Format.fprintf fmt "mlcopt: %a@\n" pp options.O.mlcopt ;
116 Format.fprintf fmt "extrapath: %a@\n" pp options.O.extrapath ;
117 Format.fprintf fmt "extralibs: %a@\n" pp options.O.extralibs ;
118 ()
119
120 (*
121 Add in the options the needed extralib and extrapath implies by the topologic
122 order of plugins given.
123 This add at the end of already present lib and path, if there are not already there.
124 *)
125 let upgrade_options plugins options =
126 let make_tbl list =
127 let tab = Hashtbl.create 16 in
128 let () = List.iter (fun lib -> Hashtbl.add tab lib ()) list in
129 tab
130 in
131
132 (* options implied by the dependencies of the plugins *)
133 let t_cclib = make_tbl options.O.cclib in
134 let t_ccopt = make_tbl options.O.ccopt in
135 let t_mllopt = make_tbl options.O.mllopt in
136 let t_mlcopt = make_tbl options.O.mlcopt in
137 let t_extrapath = make_tbl options.O.extrapath in
138 let t_extralibs = make_tbl options.O.extralibs in
139
140 let rev_filter_append present list old = List.fold_left
141 (fun rev elt -> if Hashtbl.mem present elt then rev else elt::rev)
142 old list
143 in
144
145 let upgrade_from_properties (rev_cclib, rev_ccopt, rev_mllopt, rev_mlcopt, rev_extrapath, rev_extralibs) properties =
146 let rev_cclib = rev_filter_append t_cclib properties.BslConf.cclib rev_cclib in
147 let rev_ccopt = rev_filter_append t_ccopt properties.BslConf.ccopt rev_ccopt in
148 let rev_mlcopt = rev_filter_append t_mlcopt properties.BslConf.mlcopt rev_mlcopt in
149 let rev_mllopt = rev_filter_append t_mllopt properties.BslConf.mllopt rev_mllopt in
150 let rev_extrapath = rev_filter_append t_extrapath properties.BslConf.mlinclude rev_extrapath in
151 let rev_extralibs = rev_filter_append t_extralibs properties.BslConf.mllibs rev_extralibs in
152 (rev_cclib, rev_ccopt, rev_mllopt, rev_mlcopt, rev_extrapath, rev_extralibs)
153 in
154
155 let rev_cclib, rev_ccopt, rev_mllopt, rev_mlcopt, rev_extrapath, rev_extralibs =
156 List.fold_left
157 (fun rev_stuffs plugin ->
158 let conf = plugin.BPI.conf in
159 (* All platform *)
160 let properties = conf.BslConf.all_platform in
161 let rev_stuffs = upgrade_from_properties rev_stuffs properties in
162
163 (* Platform specificities *)
164 let platform =
165 let open Mlstate_platform in
166 match mlstate_platform with
167 | Unix -> conf.BslConf.linux
168 | Windows -> conf.BslConf.windows
169 | Cygwin -> conf.BslConf.cygwin
170 in
171 let rev_stuffs = Option.fold upgrade_from_properties rev_stuffs platform in
172 rev_stuffs
173 )
174 ([], [], [], [], [], [])
175 plugins
176 in
177
178 let cclib = options.O.cclib @ (List.rev rev_cclib) in
179 let ccopt = options.O.ccopt @ (List.rev rev_ccopt) in
180 let mllopt = options.O.mllopt @ (List.rev rev_mllopt) in
181 let mlcopt = options.O.mlcopt @ (List.rev rev_mlcopt) in
182 let extrapath = options.O.extrapath @ (List.rev rev_extrapath) in
183 let extralibs = options.O.extralibs @ (List.rev rev_extralibs) in
184
185 (* options implied by the plugins *)
186
187 let t_bypass_plugins = make_tbl options.O.bypass_plugin in
188 let t_extralibs = make_tbl extralibs in
189 let t_extrapath = make_tbl extrapath in
190
191 let rev_acc present to_add = List.fold_left
192 (fun rev plugin ->
193 let plugin_name = plugin.BPI.basename in
194 let rev =
195 match Hashtbl.find_opt to_add plugin_name with
196 | None -> rev
197 | Some add ->
198 if Hashtbl.mem present add
199 then rev
200 else add::rev
201 in
202 rev) [] plugins
203 in
204
205 let rev_plugins = rev_acc t_bypass_plugins already_seen_plugin in
206 let rev_libs = rev_acc t_extralibs extralib_plugin in
207 let rev_path = rev_acc t_extrapath extrapath_plugin in
208
209 let bypass_plugin = options.O.bypass_plugin @ (List.rev rev_plugins) in
210 let extralibs = extralibs @ (List.rev rev_libs) in
211 let extrapath = extrapath @ (List.rev rev_path) in
212
213 { options
214 with OpaEnv.
215 cclib ;
216 ccopt ;
217 mllopt ;
218 mlcopt ;
219 bypass_plugin ;
220 extralibs ;
221 extrapath ;
222 }
223
224
225 let process
226 ~options
227 ~code
228 =
229
230 (* Separated compilation: loading *)
231 let () =
232 let iter (package_name, _) entries =
233 let iter_entry entry =
234 let { S.plugin_name = basename ; extralib ; extrapath ; bypass } = entry in
235 if not (Hashtbl.mem already_seen_plugin basename)
236 then (
237 BslLib.declare_visibility package_name basename ;
238 Hashtbl.add already_seen_plugin basename basename ;
239 Hashtbl.add extralib_plugin basename extralib ;
240 Hashtbl.add extrapath_plugin basename extrapath ;
241 BslDynlink.load_bypass_plugin_cache (BslDynlink.MarshalPlugin bypass) ;
242 )
243 in
244 List.iter iter_entry entries
245 in
246 R.iter_with_name ~packages:true ~deep:true iter
247 in
248 let separation = Separation.create () in
249
250 (* Pass *)
251 let plugins = options.O.bypass_plugin in
252 let extrapath = options.O.extrapath in
253 let back_end = options.O.back_end in
254 let js_back_end = options.O.js_back_end in
255
256 let commandline = FilePos.nopos "command line" in
257 let plugins = List.map (fun p -> (p, commandline)) plugins in
258
259 (*
260 Collect plugin from code and add then in the plugins list.
261 Resolve the found location for these plugins (using also by default
262 the location in the InstallDir)
263 *)
264 let code, imported_plugins =
265 let imported_plugins = ref [] in
266 let filter = function
267 | SA.Package (`import_plugin, name), label ->
268 let pos = label.QmlLoc.pos in
269 let names = [] in (* maybe give plugin from command line *)
270 let targets = ObjectFiles.expand_glob ~mode:`plugin names (name, pos) in
271 let () =
272 #<If:BSL_LOADING $contains "import">
273 debug "import-plugin: %a" (Format.pp_list " ; " (Format.pp_fst Format.pp_print_string)) targets
274 #<End>
275 in
276 imported_plugins := List.rev_append targets !imported_plugins ;
277 false
278 | _ -> true
279 in
280 let code = List.tail_map
281 (fun (filename, content, code) ->
282 let code = List.filter filter code in
283 (filename, content, code)) code
284 in
285 code, !imported_plugins
286 in
287 let plugins = List.rev_append imported_plugins plugins in
288
289 (*
290 Normalization of plugin name: add extension if not present
291 *)
292 let suffix = "." ^ BslConvention.Extension.plugin in
293 let plugins = List.rev_map
294 (fun (name, pos) ->
295 let name = if String.is_suffix suffix name then name else name^suffix in
296 name, pos
297 ) plugins in
298
299 (* Register default plug-ins. *)
300 let () = OpabslgenPlugin.Self.self_store () in
301
302 let package_name = ObjectFiles.get_current_package_name () in
303
304 (*
305 The compiler inserts calls to bypass of the opabsl potentially in every package
306 *)
307 BslLib.declare_visibility package_name OpabslgenPlugin.Self.basename ;
308
309 (* Search additional plug-ins.*)
310 let cwd = Sys.getcwd () in
311 let search_path = cwd :: extrapath in
312 List.iter (
313 fun (bypass_plugin, pos) ->
314 (* the bypass_plugin is containing the extension opp *)
315 let basename = Filename.basename bypass_plugin in
316 let basename = File.chop_extension basename in
317
318 (*
319 There we can add an information of bypass visibility:
320 The current package is in the scope of visibility of the plugin basename.
321 This can be used for adding a warning about missing dependencies detected in autobuild.
322 *)
323 BslLib.declare_visibility package_name basename ;
324
325 if not (Hashtbl.mem already_seen_plugin basename)
326 then (
327 Hashtbl.add already_seen_plugin basename basename ;
328
329 let filename =
330 if Filename.is_relative bypass_plugin
331 then
332 (*
333 We should find it in the searched path
334 *)
335
336 let found_files = List.filter_map
337 (fun p ->
338 let fullname = Filename.concat p bypass_plugin in
339 if File.is_directory fullname then Some fullname else None
340 ) search_path in
341 let file = match found_files with
342 | [] -> bypass_plugin
343 | [fullname] -> fullname
344 | fullname::_ ->
345 OManager.warning ~wclass:WarningClass.bsl_loading
346 "%a@\nThe plugin @{<bright>%S@} is found in several places.@\nI will use @{<bright>%S@}"
347 FilePos.pp pos
348 bypass_plugin
349 fullname ;
350 fullname
351 in
352 file
353 else bypass_plugin
354 in
355
356 let () =
357 if not (File.is_directory filename)
358 then
359 OManager.error "%a@\nI/O error: cannot find @{<bright>%S@}" FilePos.pp pos filename
360 in
361
362 let inclusion = BslConvention.inclusion ~cwd filename in
363 let extralib = inclusion.BslConvention.extralib in
364 let extrapath = inclusion.BslConvention.extrapath in
365 let plugin = inclusion.BslConvention.plugin in
366 Hashtbl.add extralib_plugin basename extralib ;
367 Hashtbl.add extrapath_plugin basename extrapath ;
368 BslDynlink.load_bypass_plugin (BslDynlink.MarshalPlugin plugin) ;
369 Separation.add separation (S.make basename extralib extrapath plugin) ;
370 )
371 ) plugins ;
372
373 (* Resolve dependencies. *)
374 let plugins = BslPluginTable.finalize () in
375
376 (* upgrade options *)
377 let () =
378 #<If:BSL_LOADING $contains "options">
379 debug "@[<2>options before upgrade: @\n%a@]@\n" pp_options options
380 #<End>
381 in
382 let options = upgrade_options plugins options in
383 let () =
384 #<If:BSL_LOADING $contains "options">
385 debug "@[<2>options after upgrade: @\n%a@]@\n" pp_options options
386 #<End>
387 in
388
389 (* Link with ObjectFiles *)
390 let () =
391 let t = List.rev_map (fun p -> p.BPI.self_module_name, p.BPI.uniq_id) plugins in
392 ObjectFiles.set_bsl_plugins t
393 in
394
395 (*
396 Actually load plugins.
397 There is already a mecanism for avoiding multiple loading in the RegisterInterface.
398 *)
399 List.iter (fun loader -> BslLib.BSL.RegisterInterface.dynload loader.BPI.dynloader) plugins;
400
401 (*
402 TODO(Mathieu) : if needed only.
403 It is actually possible to remove this
404 by coding a table export in libbsl
405 *)
406 let back_end_dynload =
407 match back_end with
408 | `qmlflat -> Flat_Compiler.dynloader in
409 let js_back_end_dynload =
410 let module M = (val js_back_end : Qml2jsOptions.JsBackend) in
411 M.dynloader in
412 (* Register plug-ins with actual backend.*)
413 List.iter
414 (fun plugin ->
415 (* ML back-end *)
416 back_end_dynload plugin ;
417 (* js back-end *)
418 js_back_end_dynload plugin ;
419 ) plugins;
420 let bymap = BslLib.BSL.RegisterTable.build_bypass_map () in (* Build public map.*)
421 let bsl = { BslLib.bymap = bymap ; plugins = plugins } in
422
423 (* Separated compilation: saving *)
424 let () = R.save (Separation.get separation) in
425
426 options, code, bsl
Something went wrong with that request. Please try again.