Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 210 lines (186 sloc) 9.77 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 (* alias *)
19 module PatternAnalysis = Imp_PatternAnalysis
20 module List = Base.List
21
22 (* shorthand *)
23 module E = Imp_Env
24
25 (* -- *)
26
27 let warning_set = Imp_Warnings.warning_set
28
1a910b2 [cleanup] blender: reduce dependency to the Blender
Mathieu Barbin authored
29 let initial_env ~val_ ~renaming_server ~renaming_client options env_typer code =
fccc685 Initial open-source release
MLstate authored
30 let js_ctrans = Imp_Bsl.build_ctrans_env ~options in
31 let private_bymap = Imp_Bsl.JsImpBSL.RegisterTable.build_bypass_map ~js_ctrans () in
1a910b2 [cleanup] blender: reduce dependency to the Blender
Mathieu Barbin authored
32 let gamma = env_typer.QmlTypes.gamma in
33 let annotmap = env_typer.QmlTypes.annotmap in
fccc685 Initial open-source release
MLstate authored
34 let env = {E.
35 options;
36 gamma;
37 annotmap;
38 val_;
39 private_bymap;
40 renaming_client;
41 renaming_server;
42 } in
43 env, code
44
45 let initial_private_env () = {E.
46 local_vars = [];
47 renaming = IdentMap.empty;
48 no_warn_x = ();
49 }
50
51 let _outputer oc js_code =
52 let fmt = Format.formatter_of_out_channel oc in
53 Format.fprintf fmt "%a%!" JsPrint.pp#code js_code
54
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
55 (* repeats [f] [n] times *)
56 let repeat2 n (f : int -> 'a -> 'b -> 'a * 'b) =
fccc685 Initial open-source release
MLstate authored
57 let rec aux i a b =
58 if i = n then a, b
59 else
60 let a, b = f i a b in
61 aux (i+1) a b in
62 aux 0
63
1a910b2 [cleanup] blender: reduce dependency to the Blender
Mathieu Barbin authored
64 let compile ?(val_=fun _ -> assert false) ?bsl ?(closure_map=IdentMap.empty) ~renaming_server ~renaming_client options _env_bsl env_typer code =
fccc685 Initial open-source release
MLstate authored
65 let _chrono = Chrono.make () in
66 _chrono.Chrono.start ();
1a910b2 [cleanup] blender: reduce dependency to the Blender
Mathieu Barbin authored
67 let env, code = initial_env ~val_ ~renaming_server ~renaming_client options env_typer code in
fccc685 Initial open-source release
MLstate authored
68 let js_init = Imp_Bsl.JsImpBSL.ByPassMap.js_init env.E.private_bymap in
69 #<If:JS_IMP$contains "time"> Printf.printf "bsl projection: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
70 let private_env = initial_private_env () in
71
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
72 (* lambda lifting used to generate some code specially for qmljsimp
73 * but now that lambda lifting is done before slicing, we can't do that anymore
74 * here we use the directives left by the lambda lifting in the code to generate
75 * the code as it was before the early lambda lifting:
76 * - no partial application
77 * - the code is almost lifted ie one lambda appears at the toplevel
78 * or two successive lambdas appear at the toplevel
79 * (the first lambda taking the environment, and the second the argument)
80 *)
fccc685 Initial open-source release
MLstate authored
81 let code =
82 QmlAstWalk.CodeExpr.map
83 (QmlAstWalk.Expr.map
84 (function
85 | QmlAst.Directive (label, `lifted_lambda (env,_), [QmlAst.Lambda (label2,params,body) as sub],_) ->
86 if env = 0 then sub else
87 let env_params, params = List.split_at env params in
88 (* the type is crappy here but the
89 * backend doesn't look at it anyway *)
90 QmlAst.Lambda (label, env_params, QmlAst.Lambda (label2, params, body))
91 | QmlAst.Directive (label, `full_apply env, [QmlAst.Apply (label2,fun_,args) as sub], _) ->
92 if env = 0 then sub else
93 let env_args, args = List.split_at env args in
94 (* same here *)
b49c2c1 [bug fix] jsimp: tail call optimization was broken for local functions
Valentin Gatien-Baron authored
95 (* BEWARE duplicating the annotation [label] is bad, but the
96 * backend doesn't care about that and then they are lost *)
97 QmlAst.Apply (
98 label,
99 QmlAst.Directive
100 (label,
936d60a [feature] closure serialisation: adding closure instrumentation (compile...
Valentin Gatien-Baron authored
101 `partial_apply (None, false),
b49c2c1 [bug fix] jsimp: tail call optimization was broken for local functions
Valentin Gatien-Baron authored
102 [QmlAst.Apply (label2, fun_, env_args)],
103 []),
104 args)
fccc685 Initial open-source release
MLstate authored
105 | QmlAst.Directive (_,(`lifted_lambda _ | `full_apply _),_,_) -> assert false
106 | e -> e)
107 ) code in
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
108
fccc685 Initial open-source release
MLstate authored
109 let _private_env, js_code = Imp_Code.compile env private_env code in
110 #<If:JS_IMP$contains "time"> Printf.printf "qml -> js: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
111 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:"js_imp_0_translation" _outputer js_code) #<End>;
112
113 let js_code =
114 if options.Qml2jsOptions.global_inlining then (
115 let initial_env =
116 match bsl with
117 | Some code -> Imp_Inlining.global_inline_analyse_code (Imp_Inlining.env_of_map closure_map) code
118 | None -> Imp_Inlining.env_of_map closure_map in
119 let loaded_env = Imp_Inlining.R.load initial_env in
120 (* we first analyse the code just to be able to inline simple recursive functions
121 * the results of this analysis will be overwritten when we do the real analysis in
122 * global_inline_stm *)
123 let env = Imp_Inlining.global_inline_analyse_code loaded_env js_code in
124 let env, js_code =
125 repeat2 2 (* we repeat all this twice because well, you need to simplify the code
126 * to be able to inline better but once you inline, some other pass can
127 * simplify your code, etc... :/
128 * It should be better to run the function below twice on each code element
129 * instead of analysing the whole code twice, but it didn't make any difference
130 * in my example
131 *)
132 (fun _n ->
133 List.fold_left_collect
134 (fun env stm ->
135 (* first global inline inside the statement using the environment of the dependencies
136 * (which may not be enough for recursive cases, but you can't realy inline anyway,
137 * except for cases such as an eta expansion in the middle of a recursive group) *)
138 let stm = Imp_Inlining.global_inline_rewrite_stm env stm in
139 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:(Printf.sprintf "js_imp_1_%d_global_inline" _n) _outputer [stm]) #<End>;
140 (* then, local inline to remove all useless stuff in the original code,
141 * introduced by patterns compilation and from global inline *)
142 let stm = Imp_Inlining.local_inline_stm stm in
143 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:(Printf.sprintf "js_imp_2_%d_local_inline" _n) _outputer [stm]) #<End>;
144 (* cleanup, constant folding, etc to make the code as lightweight as possible *)
145 let stms = Imp_CleanUp.clean_stm ~use_shortcut_assignment:false stm in
146 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:(Printf.sprintf "js_imp_3_%d_cleanup" _n) _outputer stms) #<End>;
147 (* now that the code is as small as it can get, we analyse it to know if it is inlinable
148 * in particular, if inlining inside its body made the code simpler, then we can
149 * inline now and we couldn't have if we analysed first, and inlined after *)
150 let env = Imp_Inlining.global_inline_analyse_code env stms in
151 env, stms
152 )
153 ) env js_code in
154 Imp_Inlining.R.save ~env ~loaded_env ~initial_env;
155 #<If:JS_IMP$contains "time"> Printf.printf "global inline: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
156 js_code
157 ) else
158 js_code in
159
160 (* this local inline doesn't do much but it still removes a few variables *)
161 let js_code = if options.Qml2jsOptions.inlining then Imp_Inlining.local_inline js_code else js_code in
162 #<If:JS_IMP$contains "time"> Printf.printf "local inline: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
163 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:"js_imp_4_local_inline" _outputer js_code) #<End>;
164
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
165 (* local renaming must be done last, because it generates very tricky code
166 * when it squashes variables together *)
fccc685 Initial open-source release
MLstate authored
167 let js_code = if options.Qml2jsOptions.alpha_renaming then Imp_Renaming.rename js_code else js_code in
168 #<If:JS_IMP$contains "time"> Printf.printf "local renaming: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
169 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:"js_imp_5_local_renaming" _outputer js_code) #<End>;
170
171 let js_code = if options.Qml2jsOptions.cleanup then Imp_CleanUp.clean ~use_shortcut_assignment:true js_code else js_code in
172 #<If:JS_IMP$contains "time"> Printf.printf "clean up: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
173 #<If:JS_IMP$contains "print"> ignore (PassTracker.file ~filename:"js_imp_6_cleanup" _outputer js_code) #<End>;
174
175 {Qml2jsOptions.
176 js_init_contents = [ "bsl_dynamic_code_and_projections.js", `ast js_init;
177 ];
178 js_code = js_code;
179 }
180
181
182 let dummy_compile () =
183 Imp_Inlining.R.save
184 ~env:Imp_Inlining.empty_env
185 ~loaded_env:Imp_Inlining.empty_env
186 ~initial_env:Imp_Inlining.empty_env
187
188 module Backend =
189 struct
190 let dynloader plugin =
191 Imp_Bsl.JsImpBSL.RegisterInterface.dynload plugin.BslPluginInterface.dynloader
192 let name = "qmljsimp"
193 let compile = compile
194 let dummy_compile = dummy_compile
195 let runtime_libs ~cps:_ =
196 (*
197 If needed: we can have specialized configuration for each file
198 *)
199 let conf = BslJsConf.Optimized {BslJsConf.
200 localrenaming = true;
201 cleanup = true;
202 } in [
203 "clientLibLib.js", conf ;
204 "qmlCpsClientLib.js", conf ;
205 "qmlJsImpClientLib.js", conf ;
206 ]
207 end
208
209 let () = Qml2jsOptions.register_backend (module Backend : Qml2jsOptions.JsBackend)
Something went wrong with that request. Please try again.