Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 358 lines (296 sloc) 12.966 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 Cps Transformation of QmlAst.
20
21 + goes from qml to qmlCpsIL.IL representation
22 + get back to qml
23 + branch with standard back-ends
24
25 Main : cf function {b cps_pass}
26
27 Note for hackers :
28
29 This pass inserts bypass calls essentially from bslCps.ml, which
30 are linked with bypass defined in module QmlCpsServerLib.
31 Reading the serverlib is a good point to start hacking the rewriting pass.
32
33 @see "qmlcps/QmlCpsServerLib" for the implementation of runtime support
34 @see "opabsl/mlbsl/bslCps.ml" for the registration of runtime bypass
35
36 @author David Rajchenbach-Teller
37 @author Mathieu Barbin
38 @author Rudy Sicard
39 *)
40
41 (** {6 Error reporting} *)
42 (** *)
43 type error
44 exception Exception of error
45 val error_message : error -> string
46
47 (** {6 Bypass restriction} *)
48
49 (**
50 The id used by this module for the restricted bypass generation.
51 All the cps-specific bypass generated by this module are of
52 the following form :
53
54 {[Directive ( `restricted_bypass cps_id, _, Some { e = Bypass skey }, _)]}
55
56 This id should be keeped coherent with the bsl tags used in [bslCps.ml] :
57
58 {[##register [ restricted:$cps_id ] cps_bypass_01 : ....]}
59
60 Other bypass production leads to normal bypass (not restricted)
61 *)
62 val cps_id : string
63
64 (** {6 Options} *)
65
66 (**
67 The options of this rewriting pass.
68 Any corresponding option from qml2ocaml or opaEnv should be passed consistency.
69
70 <!> As usual to be more robust to any added option in this interface,
71 any construction of options should be done with the syntax
72 {[{ QmlCpsRewriter.default_options with
73 ...
74 }]}
75
76 The warn_x_field is there to evoid the warning :
77 this record is defined with a 'with construction'
78 but no field are keeped from the original.
79
80 Details about options :
81 + {b no_assert} : the cps pass should know if assert should be keeped,
82 because after the transformation, the back-end is not able to remove all
83 the code corresponding to an assertion (too complex after rewriting).
84 Default value is [false] : keep assertion
85 + {b qml_closure} : tell the cps pass that there will be a closure pass after
86 + {b toplevel_concurrency} all toplevel value of the program will be evaluated pseudo-concurrently
87 if false, there is a blocking wait after each toplevel declaration.
88 default value is [false], toplevel_concurrency is an experimental option.
89 <!> The module may be not quiet (warnings) cf option no_warnings
90 + {b warn_x_field} : see note upper:
91 {[Warning X: this record is defined by a `with' expression,
92 but no fields are borrowed from the original.]}
93 *)
94 type options =
95 {
96 no_assert : bool ;
97 no_server : bool ;
98 qml_closure : bool ;
99 toplevel_concurrency : bool ;
100 warn_x_field : unit ;
101 server_side : bool ;
102 }
103
104 val default_options : options
105
106 (** {6 Env} *)
107
108 (**
109 The public env used by this transformation.
110 This env is needed during the pass, but is not modified (read-only).
111 In a further version, the cps pass may update gamma and annotmap.
112 (optimisations for field access using qmlflatcompiler)
113
114 The field bsl_bypass_typer is needed to access exactly
115 the information registred in the bsl definition of the primitive.
116 The field bypass_typer of typing (cf QmlTypes.env)
117 may have been modified after some unifications (if the bypass is coerced),
118 and may cause error during projection.
119 *)
120 type env =
121 {
122 options : options ;
123 bsl_bypass_tags : BslKey.t -> BslTags.t ;
124 bsl_bypass_cps : BslKey.t -> BslKey.t option ;
125 bsl_bypass_typer : BslKey.t -> BslTypes.t ;
126 typing : QmlTyper.env ;
127 }
128
129 (**
130 create an env from each field value.
131 default value are :
132 + options : [default_options]
133 + bsl_bypass_typer : [fun _ -> None]
134 + typing : [Typer.initial]
135 *)
136 val env_initial :
137 options:options ->
138 bsl_bypass_typer:(BslKey.t -> BslTypes.t) ->
139 bsl_bypass_tags:(BslKey.t -> BslTags.t) ->
140 bsl_bypass_cps: (BslKey.t -> BslKey.t option) ->
141 typing:QmlTyper.env ->
142 unit -> env
143
144 (**
145 The private env used by this transformation.
146 This env is updated during the transformation, and need to be passed
147 consistencly to transform a code, using fold_map like functions.
148 This env is functionnal.
149 *)
150 type private_env
151
152 (**
153 Constructor of initial private_env, for any new indepedant transformation
154 *)
155 val private_env_initial : unit -> private_env
156
157 (** {6 Internal traduction} *)
158 (**
159 Exported in this interface for interaction and debugging with
160 a pass doing some analysis on the IL representation.
161 Nobody should really need to use this low-level functions.
162 In particular, you should read the notice explaining that qml expr
163 optained by this low-level function may contain unbound identifier
164 introduced by the private_env. (cf private_binding)
165 *)
166
167 (** *)
168 val private_binding : private_env -> (Ident.t * QmlAst.expr) list
169
170 val il_simplification : env -> private_env -> QmlCpsIL.IL.term -> private_env * QmlCpsIL.IL.term
171
172 (** <!> the returned expr contains some unbound identifier (cf private_binding) *)
173 val qml_of_il :
174 toplevel_cont:(Ident.t -> QmlAst.expr) -> (** toplevel return *)
175 env ->
176 private_env ->
177 QmlCpsIL.IL.term ->
178 private_env * QmlAst.expr
179
180 (** {6 Qml Traduction} *)
181
182 (** Rewriting a code_elt in cps-mode.
183 a single code_elt can lead to the production of several code_elts.
184 <!> same warning as in [qml_of_il] unbound identifier are in [private_binding]
185 *)
186 val code_elt : env -> private_env -> QmlAst.code_elt -> private_env * QmlAst.code
187
188 (** rewriting a full code
189 <!> Beware this function insert at end a call to the scheduler if the option is set.
190 The call should be added only once. If you use the function code directly with
191 several pieces of code, set the insert tags only for the last one.
192 Default is false (do not insert).
193
194 <!> this function already insert as well the private_binding from the private_env.
195 *)
196 val code : env -> private_env -> QmlAst.code -> private_env * QmlAst.code
197
198 (** Sugar of interface for compilers : qmlc, opa *)
199
200 (** global pass on a full qml-code
201
202 Some infos about what is used from env :
203 + use bypass typer for bypass (bsl)
204 + does not use other type informations (from Hmx)
205 + annotmap is used only to produce location traces of \@assert directives.
206
207 <!> Beware : currently this pass does not update neither gamma nor annotmap.
208 Since the rewriting changes the type of every function, insering some
209 arguments (continuations), this pass should be used only at end,
210 just before the back-ends, or before any pass which does not need
211 any type informations (after this pass, gamma is inconsistent).
212
213 As a side effect of this, during shape analysis in qmlflat, some possible
214 optimizations are lost (replacing static access by cache).
215
216 TODO: see what we want and need
217 + updating gamma during this pass seems to be a lot of work
218 + qmflat use only a very small part of gamma.
219 + maybe we can add some directives for record access optimization.
220 *)
221 val cps_pass : side:[`server|`client] -> env -> QmlAst.code -> QmlAst.code
222
223 val no_cps_pass : env -> QmlAst.code -> QmlAst.code
224
225 (** {6 Common tools for back-ends} *)
226
227 (**
228 The name of the module of Cps Server Lib
229 This module contains the implementation of low-level functions
230 dealing with continuation on server side.
231 It is an ocaml module taking part of the linking of any server
232 compiled in the cps mode.
233
234 Currently, this module is ["QmlCpsServerLib"]
235
236 Nobody should really need it, because now bypass are registred
237 in opabsl, this module name is inserted during bypass key resolution.
238
239 However, the generation meta_cps [meta_cps_utils] produces a string
240 of ml code containing some direct calls to this module.
241 *)
242 val serverlib_module_name : string
243
244 (**
245 Generate the ocaml-code for uncps$(i) using uncps$(i-1)
246 It is used to generate part of bsl_ocaml_init.ml
247 TODO : rewrite in an AST (ocaml or qml) if needed.
248
249 Type of functions :
250 {[
251 val uncps : ('a continuation -> unit) -> 'a
252 val uncps1 : ('a -> 'b continuation -> unit) -> 'a -> 'b
253 val uncps2 :
254 ('a -> ('b -> 'c continuation -> unit) continuation -> unit) ->
255 'a -> 'b -> 'c
256 val uncps3 :
257 ('a ->
258 ('b -> ('c -> 'd continuation -> unit) continuation -> unit)
259 continuation -> unit) ->
260 'a -> 'b -> 'c -> 'd
261 etc...
262 val cps : 'a -> 'a continuation -> unit
263 val cps1 : ('a -> 'b) -> 'a -> 'b continuation -> unit
264 val cps2 :
265 ('a -> 'b -> 'c) ->
266 'a -> ('b -> 'c continuation -> unit) continuation -> unit
267 val cps3 :
268 ('a -> 'b -> 'c -> 'd) ->
269 'a ->
270 ('b -> ('c -> 'd continuation -> unit) continuation -> unit)
271 continuation -> unit
272 etc...
273 ]}
274
275 This function produces the following code when not in closure mode:
276 {[
277 let uncps = QmlCpsServerLib.uncps
278 let uncps1 k f x = uncps k (f x)
279 let uncps2 k f x = uncps1 k (uncps k (f x))
280 let uncps3 k f x = uncps2 k (uncps k (f x))
281 etc...
282 let cps f k = QmlCpsServerLib.return k f
283 let cps1 f x k = QmlCpsServerLib.return k (f x)
284 let cps2 f x k = QmlCpsServerLib.return k (cps1 (f x))
285 let cps3 f x k = QmlCpsServerLib.return k (cps2 (f x))
286 etc...
287 ]}
288
289 In closure mode, the code is as follows (note that it depends on the non closure-mode cpsX functions):
290 {[
291 let export = OpabslgenMLRuntime.BslClosure.export
292 let (clos_cps1, clos_cps2, clos_cps3, clos_uncps1, clos_uncps2, clos_uncps3) = Obj.magic (
293 let cps_uniq = Obj.magic (object end) in
294 let can_import = ... (* written in clear in the implem *) in
295 let clos_uncps1 f = (); fun x -> if x == uniq then Obj.magic f else uncps (f x)
296 let clos_uncps2 f = (); fun x -> if x == uniq then Obj.magic f else clos_uncps1 (export (uncps (f x)))
297 let clos_uncps3 f = (); fun x -> if x == uniq then Obj.magic f else clos_uncps2 (export (uncps (f x)))
298 let clos_cps1 f = if can_import f then Obj.magic (f : _ -> _) cps_uniq else cps1 f
299 let clos_cps2 f = if can_import f then Obj.magic (f : _ -> _) cps_uniq else cps2 f
300 let clos_cps3 f = if can_import f then Obj.magic (f : _ -> _) cps_uniq else cps3 f in
301 (clos_cps1, clos_cps2, clos_cps3, clos_uncps1, clos_uncps2, clos_uncps3)
302
303 let clos_uncps1 : ('v0,'v1) func -> 'v0 -> 'v1 = clos_uncps1
304 let clos_uncps2 : ('v0,('v1,'v2) func) func -> 'v0 -> 'v1 -> 'v2 = clos_uncps2
305 let clos_uncps3 : ('v0,('v1,('v2, 'v3) func) func) func -> 'v0 -> 'v1 -> 'v2 -> 'v3 = clos_uncps3
306 let clos_cps1 : ('v0 -> 'v1) -> ('v0,'v1) func = clos_cps1
307 let clos_cps2 : ('v0 -> 'v1 -> 'v2) -> ('v0,('v1,'v2) func) func = clos_cps2
308 let clos_cps3 : ('v0 -> 'v1 -> 'v2 -> 'v3) -> ('v0,('v1,('v2,'v3) func) func) func = clos_cps3
309 ]}
310
311 NARY-MODE (this is not the default case)
312
313 Types
314 {[
315 val uncps : ('a continuation -> unit) -> 'a
316 val uncps1 : ('a -> 'b continuation -> unit) -> 'a -> 'b
317 val uncps2 : ('a -> 'b -> 'c continuation -> unit) -> 'a -> 'b -> 'c
318 val uncps3 : ('a -> 'b -> 'c -> 'd continuation -> unit) -> 'a -> 'b -> 'c -> 'd
319 etc...
320 val cps : 'a -> 'a continuation -> unit
321 val cps1 : ('a -> 'b) -> 'a -> 'b continuation -> unit
322 val cps2 :
323 ('a -> 'b -> 'c) ->
324 ('a -> 'b -> 'c continuation -> unit)
325 val cps3 :
326 ('a -> 'b -> 'c -> 'd) ->
327 ('a -> 'b -> 'c -> 'd continuation -> unit)
328 ]}
329
330 This function produces the following code when not in closure mode:
331 {[
332 let uncps = QmlCpsServerLib.uncps
333 let uncps1 f x1 = uncps (f x1)
334 let uncps2 f x1 x2 = uncps (f x1 x2)
335 let uncps3 f x1 x2 x3 = uncps (f x1 x2 x3)
336 etc...
337 let cps f k = QmlCpsServerLib.return k f
338 let cps1 f x1 k = QmlCpsServerLib.return k (f x1)
339 let cps2 f x1 x2 k = QmlCpsServerLib.return k (f x1 x2)
340 let cps3 f x1 x2 x3 k = QmlCpsServerLib.return k (f x1 x2 x3)
341 etc...
342 ]}
343
344 This function is called by back-ends at end of bypass projection,
345 using as n value the maximum of function arity present in the projected code.
346
347 The cps/uncps functions are used to project functional arguments of bypass,
348 because after the pass, every function has changed.
349
350 <!> uncps is based on a blocking wait for a barrier to be release,
351 asynchronous call to the continuation are not yet supported.
352
353 Since this code is generated dynamically, this function is called
354 in the [BslFor$Backends] modules, using [CTrans.conversion_code] facility.
355 @see "BslLib.ML_CTRANS" interface
356 *)
357 val meta_cps_utils : int -> string
Something went wrong with that request. Please try again.