Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[fix] slicer: wrong slicing of nested local functions

when an inner function is contained in a local annotated function
  • Loading branch information...
commit 08f3271c175ee97b0b80a97903d484ce2d040e2b 1 parent 24ae106
Valentin Gatien-Baron authored
View
9 libqmlcompil/qmlAst.ml
@@ -788,15 +788,14 @@ type doctype_access_directive =
type lambda_lifting_directive = [
| `partial_apply of int option (* original arity of the function, guaranteed to be filled by lambda lifting, None means 'undisclosed information' :) *)
- | `full_apply of int (* size of the env *)
- | `lifted_lambda of int * Ident.t option (* size of the env and the toplevel name of the declaration from where it was lifted
- * (meaningful between lambda lifting and explicit instantiation, because
- * ei adds @lifted_lambda on declarations that are not really lifted, so
- * what would the value be?) *)
(**
Used to indicate a partial application
Must be around an Apply node
*)
+ | `full_apply of int (* size of the env *)
+ | `lifted_lambda of int * Ident.t list
+ (* size of the env and the toplevel name of the hierarchy of functions
+ * from which it was lifted (innermost function first) *)
]
(*
View
5 libqmlcompil/qmlPrint.ml
@@ -150,7 +150,10 @@ let directive (d:QmlAst.qml_directive) =
| `partial_apply None -> "@partial_apply"
| `partial_apply (Some i) -> Printf.sprintf "@partial_apply[misssing:%d]" i
| `full_apply n -> Printf.sprintf "@full_apply[env %d]" n
- | `lifted_lambda (n,o) -> Printf.sprintf "@lifted_lambda[env %d%s]" n (match o with None -> "" | Some i -> Printf.sprintf ", %s" (Ident.to_string i))
+ | `lifted_lambda (n,l) ->
+ Format.sprintf "@@lifted_lambda[env %d,[%a]]"
+ n
+ (Format.pp_list "@ " (fun f i -> Format.pp_print_string f (Ident.to_string i))) l
| `tagged_string (s, kind) ->
Printf.sprintf "@tagged_string[%S, %s]" s
(match kind with
View
2  opa/opa_InsertRemote.ml
@@ -995,7 +995,7 @@ let generate_stub explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side
List.map (fun id -> id, !OpaType.col) ident_col_list @
id_ty_std_list)
match_instantiate in
- TypedExpr.directive annotmap (`lifted_lambda (nb_tyvar + nb_colvar + nb_rowvar, None)) [lambda] [] in
+ TypedExpr.directive annotmap (`lifted_lambda (nb_tyvar + nb_colvar + nb_rowvar, [])) [lambda] [] in
(* Expand if necessary to have a lambda with 0 args *)
let expand = (not is_lambda) && nb_tyvar = 0 && nb_colvar = 0 && nb_rowvar = 0 in
View
2  qmlpasses/pass_ExplicitInstantiation.ml
@@ -1373,7 +1373,7 @@ let rec get_lambda = function
| _ -> assert false
)
| Q.Ident (_,x) -> `ident x
- | Q.Lambda (_,params,e) -> `lambda ((0,None),params,e)
+ | Q.Lambda (_,params,e) -> `lambda ((0,[]),params,e)
| _ -> `none
(* not sure if this test should be in sync with something else *)
View
17 qmlpasses/pass_LambdaLifting.ml
@@ -371,7 +371,7 @@ type env = {
* it contains all toplevel types and is used to determine if
* a name is defined at toplevel or not *);
hoisted : (Ident.t * Q.expr) list list;
- toplevel_name : Ident.t option;
+ hierarchy : Ident.t list; (* see the description of @lifted_lambda *)
}
(* In the functions that take an env and a gamma, the gamma
@@ -528,8 +528,7 @@ let absify ~toplevel env gamma_with_lambda_bindings annotmap e xs =
let ty = QmlTypes.Scheme.explicit_forall tsc in
(i, ty)) il in
let annotmap, e = QmlAstCons.TypedExpr.lambda annotmap (xs @ orig_xs) e in
- assert (env.toplevel_name <> None);
- QmlAstCons.TypedExpr.directive_id annotmap (`lifted_lambda (List.length xs, env.toplevel_name)) e
+ QmlAstCons.TypedExpr.directive_id annotmap (`lifted_lambda (List.length xs, List.tl env.hierarchy)) e
| Q.Coerce _
| Q.Directive (_, #ignored_directive, _, _) as e ->
tra annotmap e
@@ -912,6 +911,8 @@ and parameterLiftBnds ~options ~toplevel (gamma,annotmap,env) bnds =
{env with gamma = env_gamma}
| `fun_action _ | `untyped -> env in
+ let hierarchy = env.hierarchy in
+
let (annotmap,env),funcs =
(* rewrite the body of each function *)
List.fold_left_map
@@ -924,7 +925,7 @@ and parameterLiftBnds ~options ~toplevel (gamma,annotmap,env) bnds =
(fun (x,_) -> Ident.equal x f_ident)
funcs) in
(* lift the body *)
- let env = if toplevel then {env with toplevel_name = Some f_ident} else env in
+ let env = {env with hierarchy = f_ident :: hierarchy} in
let (gamma_with_lambda_bindings,annotmap,env),body =
parameterLiftLambda ~options (gamma,annotmap,env) body in
let annotmap,body,sigma =
@@ -963,11 +964,13 @@ and parameterLiftBnds ~options ~toplevel (gamma,annotmap,env) bnds =
let (annotmap,env),vals =
List.fold_left_map
(fun (annotmap,env) (x,e) ->
- let env = if toplevel then {env with toplevel_name = Some x} else env in
let (_,annotmap,env),e = parameterLiftExp ~options (gamma,annotmap,env) e in
(annotmap,env),(x,e))
(annotmap,env)
vals in
+
+ let env = {env with hierarchy} in
+
(gamma,annotmap,env),(funcs,vals)
(* the gamma returned by this function contains the identifiers bound by the lambda
@@ -1093,14 +1096,14 @@ let lift_code_elt ~options (annotmap,env) elt =
let process_code_elt ~options (annotmap,env) elt =
let annotmap,elt = name_anonymous_lambda_code_elt ~options annotmap elt in
let (annotmap,env),elts = lift_code_elt ~options (annotmap,env) elt in
- let env = {env with hoisted = []; toplevel_name = None} in
+ let env = {env with hoisted = []; hierarchy = []} in
(annotmap,env),elts
let empty_env gamma = {
gamma = gamma;
funcs = IdentMap.empty;
hoisted = [];
- toplevel_name = None;
+ hierarchy = [];
}
(*
View
164 qmlslicer/qmlSimpleSlicer.ml
@@ -98,7 +98,7 @@ type information = (* TODO: explicit the invariants *)
mutable calls_server_bypass : BslKey.t option;
mutable calls_client_bypass : BslKey.t option;
mutable has_sliced_expr : bool;
- mutable lambda_lifted : Ident.t option;
+ mutable lambda_lifted : Ident.t list;
(* computed by propagate_server_private *)
mutable calls_private : information value option; (* this field is independent of the @publish annotation *)
@@ -334,7 +334,7 @@ let default_information ~env ~annotmap (ident,expr) =
if not (QmlTypesUtils.Inspect.is_type_void env.gamma ty) then fail ());
);
{ calls_private = None;
- lambda_lifted = None;
+ lambda_lifted = [];
calls_server_bypass = None;
calls_client_bypass = None;
privacy = Option.default Visible !visibility;
@@ -404,14 +404,11 @@ let update_call_graph env info =
QmlError.serror error_context "@[This is an invalid slicer annotation: they can only appear on toplevel bindings (or inside toplevel modules) or on function bindings.@]";
context
- | Q.Directive (_, `lifted_lambda (_,name), _, _) ->
- assert (info.lambda_lifted = None);
+ | Q.Directive (_, `lifted_lambda (_,hierarchy), _, _) ->
+ assert (info.lambda_lifted = []);
(* if the code is lifted, you have only one function per toplevel
declaration (so at most one @lifted_lambda) *)
- assert (name <> None);
- (* if name is None, then the lambda lifting screwed up, because
- * None is meant for ei, lambda lifting always puts a Some *)
- info.lambda_lifted <- name;
+ info.lambda_lifted <- hierarchy;
context
| _ ->
@@ -758,41 +755,60 @@ let node_is_annotated info =
| _ -> true
)
| _ -> true
+
+let enclosing_info_if_not_toplevel_and_not_annotated env info =
+ if info.lambda_lifted = [] || node_is_annotated info then None
+ else (
+ let orig =
+ try
+ (* a local function is sliced as the its innermost
+ * enclosing function that is annotated
+ * (or the toplevel one by default) *)
+ List.find
+ (fun ident ->
+ let info = IdentTable.find env.informations ident in
+ node_is_annotated info
+ ) info.lambda_lifted
+ with Not_found -> List.last info.lambda_lifted in
+ let orig_info = IdentTable.find env.informations orig in
+ Some orig_info
+ )
+
let inline_informations_lambda_lifted env =
IdentTable.iter
(fun _ info ->
- match info.lambda_lifted with
- | Some orig ->
- if node_is_annotated info then () else (
- (* merging @sliced_expr, @call_*_bypass
- * because these are the only properties that would
- * be different if the the lifted functions were inlined
- * I think (they depend on the field expr) *)
- let orig_info = IdentTable.find env.informations orig in
- orig_info.has_sliced_expr <- orig_info.has_sliced_expr || info.has_sliced_expr;
- orig_info.calls_client_bypass <- (
- match orig_info.calls_client_bypass with
- | None -> info.calls_client_bypass
- | Some _ as v -> v
- );
- orig_info.calls_server_bypass <- (
- match orig_info.calls_server_bypass with
- | None -> info.calls_server_bypass
- | Some _ as v -> v
- );
- (* we add a dependency from the original to the lifted one
- * because if the local function is not used, then there is no dependency
- * (and the outer function will be put on both sides, so will the inner function
- * and if it is server private, resolveRemoteCalls will break)
- * example of such a problem if you remove this:
- * @server_private x = 1
- * g() =
- * f() = x
- * @fail
- *)
- G.add_edge env.call_graph orig_info info
- )
- | None -> ()
+ match info.expr with
+ | External _ -> ()
+ | Local _ ->
+ match enclosing_info_if_not_toplevel_and_not_annotated env info with
+ | None -> ()
+ | Some orig_info ->
+ (* merging @sliced_expr, @call_*_bypass
+ * because these are the only properties that would
+ * be different if the the lifted functions were inlined
+ * I think (they depend on the field expr) *)
+ orig_info.has_sliced_expr <- orig_info.has_sliced_expr || info.has_sliced_expr;
+ orig_info.calls_client_bypass <- (
+ match orig_info.calls_client_bypass with
+ | None -> info.calls_client_bypass
+ | Some _ as v -> v
+ );
+ orig_info.calls_server_bypass <- (
+ match orig_info.calls_server_bypass with
+ | None -> info.calls_server_bypass
+ | Some _ as v -> v
+ );
+ (* we add a dependency from the original to the lifted one
+ * because if the local function is not used, then there is no dependency
+ * (and the outer function will be put on both sides, so will the inner function
+ * and if it is server private, resolveRemoteCalls will break)
+ * example of such a problem if you remove this:
+ * @server_private x = 1
+ * g() =
+ * f() = x
+ * @fail
+ *)
+ G.add_edge env.call_graph orig_info info
) env.informations
let choose_sides env =
@@ -844,13 +860,8 @@ let choose_sides env =
(* third step: dispatch according the annotation *)
List.iter (fun node ->
- match node.lambda_lifted with
- | Some _ ->
- if node_is_annotated node then
- look_at_user_annotation env pp_pos node node.user_annotation
- else
- (* this is treated below *)
- ()
+ match enclosing_info_if_not_toplevel_and_not_annotated env node with
+ | Some _ -> (* this is treated below *) ()
| None -> look_at_user_annotation env pp_pos node node.user_annotation
) group
)
@@ -860,25 +871,22 @@ let choose_sides env =
(fun group ->
List.iter
(fun node ->
- match node.lambda_lifted with
- | Some i ->
- if node_is_annotated node then () else (
- (* never publish those for now at least, because it adds type
- * variables in unwanted places like the runtime of the serialization *)
- let node_i = IdentTable.find env.informations i in
- let relax = function
- | None -> assert false
- | Some (Some `expression)
- | Some None as v -> v
- | Some (Some `alias)
- | Some (Some `insert_server_value) ->
- (* avoids many useless insert_server_values
- * should be solved cleanly when we have an actual slicing strategy for
- * local functions *)
- Some None in
- node.on_the_server <- relax (node_i.on_the_server :> client_code_kind option option);
- node.on_the_client <- relax node_i.on_the_client;
- )
+ match enclosing_info_if_not_toplevel_and_not_annotated env node with
+ | Some node_i ->
+ (* never publish those for now at least, because it adds type
+ * variables in unwanted places like the runtime of the serialization *)
+ let relax = function
+ | None -> assert false
+ | Some (Some `expression)
+ | Some None as v -> v
+ | Some (Some `alias)
+ | Some (Some `insert_server_value) ->
+ (* avoids many useless insert_server_values
+ * should be solved cleanly when we have an actual slicing strategy for
+ * local functions *)
+ Some None in
+ node.on_the_server <- relax (node_i.on_the_server :> client_code_kind option option);
+ node.on_the_client <- relax node_i.on_the_client;
| None -> ()
) group
) groups
@@ -1454,18 +1462,18 @@ struct
List.iter
(fun info ->
(* BEWARE: do not modify this info, or else you screw the value memoized in objectFiles *)
- let info =
- match info.server_ident with
- | `ident _ -> info
- | `undefined -> assert false
- | `tsc tsc_opt -> {info with server_ident = `tsc (refresh_opt "SERVER" info package tsc_opt)}
- | `ident_tsc (ident, tsc_opt) -> {info with server_ident = `ident_tsc (ident, refresh_opt "SERVER" info package tsc_opt)} in
- let info =
- match info.client_ident with
- | `ident _ -> info
- | `undefined -> assert false
- | `tsc tsc_opt -> {info with client_ident = `tsc (refresh_opt "CLIENT" info package tsc_opt)}
- | `ident_tsc (ident, tsc_opt) -> {info with client_ident = `ident_tsc (ident, refresh_opt "CLIENT" info package tsc_opt)} in
+ (* damned, cannot simply copy a record *)
+ let info = {info with ident = info.ident} in
+ (match info.server_ident with
+ | `ident _ -> ()
+ | `undefined -> assert false
+ | `tsc tsc_opt -> info.server_ident <- `tsc (refresh_opt "SERVER" info package tsc_opt)
+ | `ident_tsc (ident, tsc_opt) -> info.server_ident <- `ident_tsc (ident, refresh_opt "SERVER" info package tsc_opt));
+ (match info.client_ident with
+ | `ident _ -> ()
+ | `undefined -> assert false
+ | `tsc tsc_opt -> info.client_ident <- `tsc (refresh_opt "CLIENT" info package tsc_opt)
+ | `ident_tsc (ident, tsc_opt) -> info.client_ident <- `ident_tsc (ident, refresh_opt "CLIENT" info package tsc_opt));
IdentTable.add informations info.ident info;
G.add_vertex call_graph info;
) infos
Please sign in to comment.
Something went wrong with that request. Please try again.