Browse files

[clean] most passes: removing @expanded_bypass

not introduced anymore by BypassHoisting
  • Loading branch information...
1 parent 88694da commit 339410857dccd815641776131d9378bd6e3f229c Valentin Gatien-Baron committed Jun 17, 2011
View
8 libqmlcompil/qmlAst.ml
@@ -914,14 +914,6 @@ type qml_directive = [
| `typeof (** -> WIP, don't use (yet) *)
| `expand of Big_int.big_int option (**Marker for macro (function) that are macro-expanded, the integer represents the number of unrolling the compiler is authorised to do, it must do at least one *)
- | `expanded_bypass (*of string * int (* useful to check if a bypass is already expanded *)*)
- (**Specify that a bypass has been expanded so as to make it a complete application and should therefore
- not be expanded (again). The [expr option] should be [Some e] where [e] should have the form
- [fun x1 x2 x3 ... xn -> %%bypass%% x1 x2 x3 ... xn].
- Produced by QmlBypassHoisting.
- Produced and handled by CPS transformation.
- Handled by back-ends if no --cps mode
- *)
| `restricted_bypass of string
(** this directive should be produced by any pass inserting some restricted bypass,
with a static string identifier to identify the pass.
View
34 libqmlcompil/qmlAstUtils.ml
@@ -326,40 +326,6 @@ struct
end
-module Bypass =
-struct
- module QC = QmlAstCons.UntypedExpr
-
- type t = (Ident.t list * Q.expr list) option
-
- let unexpand_t e =
- let fail _ = invalid_arg "QmlAstUtils.Bypass.unexpand" in
- let aux bypass =
- let original_bypass = bypass in
- let rec aux_aux = function
- | Q.Directive (_, `restricted_bypass _, [e], _)
- | Q.Directive (_, `may_cps, [e], _) -> aux_aux e
- | Q.Bypass (_, skey) -> skey, original_bypass
- | _ -> fail ()
- in aux_aux original_bypass
- in
- match e with
- | Q.Lambda (_, params, Q.Apply (_, bypass, args)) ->
- if List.length params = List.length args
- then Some (params, args), aux bypass
- else fail ()
- | _ -> None, aux e
-
- let unexpand e = snd (unexpand_t e)
-
- let expand_t t bypass =
- match t with
- | None -> bypass
- | Some (params, args) ->
- let apply = QC.apply bypass args in
- QC.lambda params apply
-end
-
module Const =
struct
let compare a b =
View
27 libqmlcompil/qmlAstUtils.mli
@@ -36,7 +36,7 @@
these directives.
{[
- type structural_ignored_directives = [ `tracker | `coerce | `expanded_bypass, etc..]
+ type structural_ignored_directives = [ `tracker | `coerce, etc..]
let util ... =
let rec aux ... = function
| Directive (#structural_ignored_directive, e, ...) -> aux e
@@ -290,31 +290,6 @@ sig
val expr_fold : ('a -> Annot.t -> QmlAst.ident -> 'a) -> QmlAst.expr -> 'a -> 'a
end
-module Bypass:
-sig
-
- (**
- used to introspect `expanded_bypass. return the node Bypass or `restricted bypass and the skey.
-
- The [expr] passed to this function should be the one directly protected by the expanded_bypass
- directive.
-
- {[
- | Directive (`expanded_bypass, _, Some expr, _) -> unexpand expr
- ]}
-
- @raise Invalid_argument if the expr is not a valid bypass
- *)
- val unexpand : QmlAst.expr -> BslKey.t * QmlAst.expr
-
- (**
- A private type for cons/decons
- *)
- type t
- val unexpand_t : QmlAst.expr -> t * (BslKey.t * QmlAst.expr)
- val expand_t : t -> QmlAst.expr -> QmlAst.expr
-end
-
(**
Utils on Record node.
*)
View
120 libqmlcompil/qmlCheck.ml
@@ -115,14 +115,6 @@ struct
WarningClass.create ~parent:cond_bypass ~name:"applied"
~doc:"Total application of bypasses"
~err:true ~enable:true ()
- let cond_bypass_expanded =
- WarningClass.create ~parent:cond_bypass ~name:"expanded"
- ~doc:"Well-formedness of directives @expanded_bypass (rejecting sole bypasses)"
- ~err:true ~enable:true ()
- let cond_bypass_well_formed =
- WarningClass.create ~parent:cond_bypass ~name:"well-formed"
- ~doc:"Well-formedness of directives @expanded_bypass"
- ~err:true ~enable:true ()
let id = PassHandler.define_cond cond_bypass
@@ -199,118 +191,6 @@ struct
(fun env ->
let bypass_typer, code = extract env in
bypass_applied bypass_typer code)
-
-
- let expanded_id = PassHandler.define_cond cond_bypass_expanded
- let well_formed_id = PassHandler.define_cond cond_bypass_well_formed
- (* Implementation
- If all is ok, return unit, else call some [scheck_fail]
- *)
- let bypass_expanded_factory ~allow_not_expanded bypass_typer code =
- let cond_id = if allow_not_expanded then well_formed_id else expanded_id in
- let is_well_formed code_elt traverse expr =
- let (!!) fmt = QmlError.scheck_fail cond_id (context_code_elt_expr code_elt expr) fmt in
- match expr with
- | Q.Directive (_, `expanded_bypass, [expanded], _) -> (
- let rec aux_expanded expanded =
- match expanded with
- | Q.Lambda (_, fun_params, body) -> (
- let fun_arity = List.length fun_params in
- match body with
- | Q.Apply (_, bypass, app_args) -> (
- let rec aux_apply bypass =
- match bypass with
- | Q.Directive (_, `may_cps, [bypass], _) -> aux_apply bypass
- | Q.Directive (_, `restricted_bypass _, [ Q.Bypass (_, skey) ],_)
- | Q.Bypass (_, skey) ->
- let ty = bypass_typer skey in
- let bypass_arity =
- match ty with
- | Some (QmlAst.TypeArrow (args, ty)) -> QmlTypesUtils.TypeArrow.nary_arity args ty
- | Some _ -> 0 (* should not happen *)
- | None -> fun_arity
- (* type is unknown so simply check the form
- (by assuming the bypass has the same arity than the lambda term) *)
- in
- let args_number = List.length app_args in
- let iter2 expr ident =
- match expr with
- | Q.Ident (_, id) ->
- if not (Ident.equal id ident) then
- !! "Incorrect expansion : var %s@\n" (Ident.stident id)
- | _ -> !! "Bypass not applied to an identifier but to %a@\n" QmlPrint.pp#expr expr
- in
- let _ =
- try
- List.iter2 iter2 app_args fun_params
- with
- | Invalid_argument _ -> !! "Incorrect expansion: free vars\n"
- in
- (* The lambda term takes [fun_arity] arguments.
- The bypass takes also [fun_arity] arguments and
- is applied to [args_number] arguments which must be
- equal to [fun_arity] *)
- if not (args_number = fun_arity && fun_arity = bypass_arity) then
- let ty = Option.default (QmlAst.TypeConst QmlAst.TyNull) ty in
- !! (
- "The expansion of the bypass does not correspond to the arity@\n"^^
- "returned by the bsl bypass typer@\n"^^
- "bsl typer type : %a@\nbsl arity : %d@\n"^^
- "and there the eta-expension has arity %d" )
- QmlPrint.pp#ty ty bypass_arity args_number
-
- | _ -> !! "Incorrect application"
- in aux_apply bypass
- )
- | _ -> !! "Expanded bypass with wrong application"
- )
- | Q.Directive (_, `may_cps, [bypass], _) -> aux_expanded bypass
- | Q.Directive (_, `restricted_bypass _, [ Q.Bypass (_, skey) ], _)
- | Q.Bypass (_, skey) -> (* a bypass of arity 0 (so is not applied) *)
- let ty = bypass_typer skey in
- let bypass_arity =
- match ty with
- | Some (QmlAst.TypeArrow (args, ty)) -> QmlTypesUtils.TypeArrow.nary_arity args ty
- | Some _ -> 0 (* a value *)
- | None -> 0 (* ! *)
- in
- if not (bypass_arity = 0) then
- let ty = Option.default (QmlAst.TypeConst QmlAst.TyNull) ty in
- !! (
- "The expansion of the bypass does not correspond to the arity@\n"^^
- "returned by the bsl bypass typer@\n"^^
- "bsl typer type : %a@\nbsl arity : %d@\n"^^
- "and there the eta-expension has arity %d" )
- QmlPrint.pp#ty ty bypass_arity 0
- | _ -> !! "This bypass is not well expanded"
- in aux_expanded expanded
- )
- | Q.Directive (_, `may_cps, _, _)
- | Q.Directive (_, `restricted_bypass _, _, _)
- | Q.Bypass _ -> if not allow_not_expanded then !! "This bypass is not expanded"
- | _ -> traverse expr
- in
- List.iter (
- fun code_elt ->
- QmlAstWalk.Top.iter_expr (QmlAstWalk.Expr.traverse_iter (is_well_formed code_elt)) code_elt
- )
- code
-
- let bypass_expanded bypass_typer code = bypass_expanded_factory ~allow_not_expanded:false bypass_typer code
- let bypass_well_formed bypass_typer code = bypass_expanded_factory ~allow_not_expanded:true bypass_typer code
-
- (* link to passHandler *)
- let expanded extract =
- PassHandler.make_condition expanded_id
- (fun env ->
- let bypass_typer, code = extract env in
- bypass_expanded bypass_typer code)
-
- let well_formed extract =
- PassHandler.make_condition well_formed_id
- (fun env ->
- let bypass_typer, code = extract env in
- bypass_well_formed bypass_typer code)
end
(* c *)
View
27 libqmlcompil/qmlCheck.mli
@@ -124,33 +124,6 @@ sig
*)
val applied : ('env, (QmlTypes.bypass_typer * QmlAst.code)) checker
val applied_id : PassHandler.cond_id
-
- (** {6 Expanded} *)
-
- (**
- Checks that every bypass is correctly protected with the directive
- [`expanded_bypass] and that the expression inside has the correct
- form, which is :
- {[fun x1 x2 ... xn -> %%bypass%% x1 x2 ... xn]} for a bypass of arity [n]
-
- If the type is unknown (the bypass typer returns [None]),
- simply checks the form.
- - Condition name : ["cond.bypass.expanded"]
- - Warning class : [cond_bypass_expanded]
- *)
- val expanded : ('env, (QmlTypes.bypass_typer * QmlAst.code)) checker
- val expanded_id : PassHandler.cond_id
-
- (**
- Perform the same check as 'expanded' on bypass which are expanded,
- but do not crash if some bypass are not yet expanded.
- (i.e. not protected with [`expanded_bypass] directive).
-
- - Condition name : ["cond.bypass.well-formed"]
- - Warning class : [cond_bypass_well_formed]
- *)
- val well_formed : ('env, (QmlTypes.bypass_typer * QmlAst.code)) checker
- val well_formed_id : PassHandler.cond_id
end
(** General checks on the code *)
View
1 libqmlcompil/qmlDirectives.ml
@@ -268,7 +268,6 @@ let ty directive exprs tys =
(* === *)
(* Expansion *)
| `expand _ -> Ty.id ()
- | `expanded_bypass -> Ty.id ()
(* === *)
(* Closures *)
View
1 libqmlcompil/qmlEffects.ml
@@ -365,7 +365,6 @@ struct
List.iter (fun e -> ignore (infer bp env effect level e)) el;
next_var level
| Q.Directive (_, ( `restricted_bypass _
- | `expanded_bypass
| #Q.type_directive
| `recval
| #Q.slicer_directive
View
1 libqmlcompil/qmlPrint.ml
@@ -118,7 +118,6 @@ let directive (d:QmlAst.qml_directive) =
| `spawn -> "@spawn"
| `wait -> "@wait"
| `callcc -> "@callcc"
- | `expanded_bypass -> "@expanded_bypass"
| `restricted_bypass pass -> "@restricted_bypass["^ pass ^ "]"
| `fail -> "@fail"
| `create_lazy_record -> "@create_lazy_record"
View
7 opa/passes.ml
@@ -550,13 +550,6 @@ let remove_client_bypass_GEN ~broken_annotmap bymap annotmap qmlAst =
let rec rewr expanded tra e =
match e with
- (* detect if already expanded *)
- | Q.Directive (_, `expanded_bypass, [expanded], []) ->
- let _, unexp = QmlAstUtils.Bypass.unexpand expanded in
- let unexp' = rewr false tra unexp in
- if unexp'== unexp then e
- else unexp'
-
(* exchange the bslkey if needed *)
| Q.Bypass (label, bslkey)
| Q.Directive (label, `restricted_bypass _, [Q.Bypass (_, bslkey)], []) ->
View
1 opa/s3Passes.ml
@@ -1807,7 +1807,6 @@ let pass_ServerCpsRewriter =
] in
let precond =
[
- QmlCheck.Bypass.well_formed extract ;
] in
let postcond =
[
View
1 opatop/opaTopEval.ml
@@ -59,7 +59,6 @@ type ('a, 'b) ignored_directive = [
| QmlAst.type_directive
| `asynchronous_toplevel
| `atomic
-| `expanded_bypass
| `fun_action of 'a
| `nonexpansive
| `spawn
View
3 qmlcompilers/qmlCompilers.ml
@@ -447,7 +447,6 @@ struct
] in
let postcond =
[
- QmlCheck.Bypass.expanded extract ;
QmlAlphaConv.Check.alpha extract_final_ac ;
] in
make_final_pass precond postcond (
@@ -590,7 +589,6 @@ struct
in
let precond =
[
- QmlCheck.Bypass.well_formed extract;
] in
let postcond =
[
@@ -641,7 +639,6 @@ struct
(* needed by closures *)
|> PassHandler.handler "BypassHoisting" pass_BypassHoisting
- (* expects bypasses to be at the toplevel (could be patched to remove this precondition) *)
|> PassHandler.handler "DiscardRemoteBypasses" (pass_DiscardRemoteBypasses ~lang)
(* This one is for testing, maybe we'll use it, and update Cps so that it does its
View
87 qmlcps/qmlCpsRewriter.ml
@@ -227,7 +227,7 @@ let string_of_pos = FilePos.to_string
(* The cps transform makes no assumption about the bypass it receives
* It will eta expand if needed, but only when necessary (when bypasses
- * are not surrounded by a `expanded_bypass) *)
+ * are not applied) *)
let expand_bypass (env:env) (expr:QmlAst.expr) =
let key =
match expr with
@@ -236,30 +236,19 @@ let expand_bypass (env:env) (expr:QmlAst.expr) =
| _ -> assert false in
let typ = env.bsl_bypass_typer key in
(* forming the type list corresponding to this type *)
- let inputs, output = match typ with
+ let inputs, _output = match typ with
| BslTypes.Fun (_, inputs, output) -> Some inputs, output
| _ -> None, typ
in
- let _ =
- match output with
- | BslTypes.Fun _ ->
- OManager.i_error
- "Error on bypass : %a@\ncps cannot handle bypass which return a functionnal value@\n%a@\nreturned type : %a@\n"
- BslKey.pp key
- BslTypes.pp typ
- BslTypes.pp output
- | _ -> ()
- in
match inputs with
| None ->
- (* it is not a function, just protect it *)
- (Q.Directive (Annot.next_label (Q.Pos.expr expr), `expanded_bypass, [expr], []))
+ (* it is not a function, do nothing *)
+ None
| Some l ->
let n = List.length l in
let args = List.init n (fun i -> Ident.nextf "bypass_arg_%d" i) in
let apply = QC.apply expr (List.map QC.ident args) in
- let expanded = QC.lambda args apply in
- Q.Directive (Annot.next_label (Q.Pos.expr expanded), `expanded_bypass, [expanded], [])
+ Some (QC.lambda args apply)
(* private context to be sure to control what goes out *)
@@ -399,7 +388,7 @@ module U = struct
| Q.Bypass (_, key) -> key, None
| _ ->
let context = QmlError.Context.expr bp in
- QmlError.cond_violation QmlCheck.Bypass.well_formed_id context
+ QmlError.i_error None context
"Unexpected form of bypass"
let bp_get_key bp = fst (bp_get_key_and_passid bp)
@@ -564,12 +553,7 @@ end
(** The code_elt is there only for Error context *)
(* Convert a QML expression to a CPS term.*)
-let il_of_qml ?code_elt ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr:QmlAst.expr) =
- let error_context sub_expr =
- let c = QmlError.Context.exprs expr [sub_expr] in
- let c = match code_elt with Some code_elt -> QmlError.Context.merge2 c (QmlError.Context.code_elt code_elt) | None -> c in
- c
- in
+let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr:QmlAst.expr) =
(* Records
<!> beware, this function is partial, it is defined only on complex records, and lazy records.
the skip option specify if we accept to use and propagate skip nodes and provide the
@@ -873,12 +857,27 @@ let il_of_qml ?code_elt ?(can_skip_toplvl=false) (env:env) (private_env:private_
List.fold_left fold il_term build_fields
| Q.Bypass _
- | Q.Directive (_, `restricted_bypass _, [Q.Bypass _], _) ->
+ | Q.Directive (_, `restricted_bypass _, [Q.Bypass _], _) -> (
(* if we end up here, it means QmlBypassHoisting wasn't called, or that someone
* introduced other bypasses in the meantime
* In any case, we eta expand them ourselves
*)
- aux_can_skip ~can_skip_lambda (expand_bypass env expr) context
+ match expand_bypass env expr with
+ | None -> (
+ match expr with
+ | Q.Directive (_, `restricted_bypass pass, [Q.Bypass (_, key)], _) ->
+ (* value bypass *)
+ let v = IL.fresh_v () in
+ IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, Some pass)), Context.apply context v)
+ | Q.Bypass (_, key) ->
+ (* value bypass *)
+ let v = IL.fresh_v () in
+ IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, None)), Context.apply context v)
+ | _ -> assert false (* not matched by the outer pattern *)
+ )
+ | Some e ->
+ aux_can_skip ~can_skip_lambda e context
+ )
| Q.Coerce (_, e, _) -> aux_can_skip ~can_skip_lambda e context
@@ -944,30 +943,6 @@ let il_of_qml ?code_elt ?(can_skip_toplvl=false) (env:env) (private_env:private_
(* in particular : see if this directive should be removed by this pass,
or preserved (or transformed?) for a specific back-end directive *)
- | Q.Directive (_, `expanded_bypass, [expanded_bypass], _) ->
- (*At this stage, [expr] should have the form
- [fun x1 x2 x3 ... xn -> %%bypass%% x1 x2 x3 ... xn]
- We transform the [fun] part without altering the application part,
- as we cannot deal with partial application in bypasses.
- *)
- let fail e =
- QmlError.cond_violation QmlCheck.Bypass.well_formed_id (error_context expr)
- "Got: %a" QmlPrint.pp#expr e in
- let collect_lambdas expr context =
- match expr with
- | Q.Lambda (_, _, _) -> aux_can_skip ~can_skip_lambda expr context
- | Q.Directive (_, `restricted_bypass pass, [Q.Bypass (_, key)], _) ->
- (* value bypass *)
- let v = IL.fresh_v () in
- IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, Some pass)), Context.apply context v)
- | Q.Bypass (_, key) ->
- (* value bypass *)
- let v = IL.fresh_v () in
- IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, None)), Context.apply context v)
- | _ -> fail expr
- in
- collect_lambdas expanded_bypass context
-
| Q.Directive (_, `assert_, [e], _) ->
if env.options.no_assert
then aux (QC.unit ()) context
@@ -1398,8 +1373,6 @@ let qml_of_il ~toplevel_cont (env:_) (private_env:private_env) (term:IL.term) =
| IL.Directive (`immovable, _, _) -> assert false (* cf remark in qml -> IL *)
- | IL.Directive (`expanded_bypass, _, _) -> assert false (* removed by qml -> IL *)
-
| IL.Directive (`create_lazy_record, _, _) -> assert false (* expressed as const after qml -> IL *)
| IL.Directive (`module_, _, _) -> assert false (* removed by qml -> IL *)
@@ -1571,7 +1544,7 @@ let code_elt (env:env) (private_env:private_env) code_elt =
| Q.Directive (_, `asynchronous_toplevel, [e], _) -> true, e
| _ -> false, expr
in
- let private_env, il_term = il_of_qml ~code_elt ~can_skip_toplvl:can_skip_toplvl env private_env expr in
+ let private_env, il_term = il_of_qml ~can_skip_toplvl:can_skip_toplvl env private_env expr in
let private_env, il_term = il_simplification env private_env il_term in
match il_term with
(* a barrier won't be needed when an expression is skipable at toplvl *)
@@ -1623,7 +1596,7 @@ let code_elt (env:env) (private_env:private_env) code_elt =
end
in
let immediate_lambda arity =
- let private_env, il_term = il_of_qml ~code_elt ~can_skip_toplvl:true env private_env expr in
+ let private_env, il_term = il_of_qml ~can_skip_toplvl:true env private_env expr in
let private_env, il_term = il_simplification env private_env il_term in
let toplevel_cont v = QC.ident v in
match il_term with
@@ -1635,7 +1608,7 @@ let code_elt (env:env) (private_env:private_env) code_elt =
let fskip_id = Ident.refreshf ~map:"%s_skip" id in
let private_env = private_env_add_skipped_fun id arity fskip_id id private_env in
let fskip_eta_exp = QmlAstUtils.Lambda.eta_expand_ast arity (QC.ident id) in
- let private_env, fcps_il = il_of_qml ~code_elt env private_env fskip_eta_exp in
+ let private_env, fcps_il = il_of_qml env private_env fskip_eta_exp in
let private_env, fcps = qml_of_il ~toplevel_cont env private_env fcps_il in
let fcps = simpl_let_in fcps in
private_env, [ (fskip_id, fskip); (id, fcps) ]
@@ -1673,7 +1646,6 @@ let code_elt (env:env) (private_env:private_env) code_elt =
| Q.LetRecIn _ -> immediate_value_or_barrier ()
| Q.Directive (_, `restricted_bypass _, [Q.Lambda (_, l, _)], _)
- | Q.Directive (_, `expanded_bypass, [Q.Lambda (_, l, _)], _)
| Q.Lambda (_, l, _) -> immediate_lambda (List.length l)
| Q.Apply _ -> immediate_value_or_barrier ~can_skip_toplvl:true ()
@@ -1689,7 +1661,6 @@ let code_elt (env:env) (private_env:private_env) code_elt =
| Q.ExtendRecord _ -> immediate_value_or_barrier ()
| Q.Directive (_, `restricted_bypass _, _, _)
- | Q.Directive (_, `expanded_bypass, _, _)
| Q.Bypass _ -> immediate_value_or_barrier ()
| Q.Coerce (_, e, _) -> fold_filter_map private_env (id, e)
@@ -1773,7 +1744,7 @@ let code_elt (env:env) (private_env:private_env) code_elt =
(* normal case *)
| Q.Lambda _ ->
- let private_env, il_term = il_of_qml ~code_elt ~can_skip_toplvl:false env private_env expr in
+ let private_env, il_term = il_of_qml ~can_skip_toplvl:false env private_env expr in
let private_env, il_term = il_simplification env private_env il_term in
let toplevel_cont v = QC.ident v in
begin match il_term with
@@ -1891,8 +1862,6 @@ let no_cps_pass env code =
in
let rewrite expr =
match expr with
- | Q.Directive (_, `expanded_bypass, [e], _) -> e
- | Q.Directive (_, `expanded_bypass, _, _) -> assert false
| Q.Apply (_, Q.Ident _, _) -> expr
| Q.Apply (_, f, f_args) when (not(U.good_apply_property private_env f f_args))-> expr
| Q.Apply (label, bypass, f_args) ->
View
1 qmlflat/flat/flat_ExprGeneration.ml
@@ -44,7 +44,6 @@ type ('a, 'b, 'c, 'd, 'e) assume_traverse = [
| QmlAst.type_directive
| `asynchronous_toplevel
| `atomic
-| `expanded_bypass
| `fun_action of 'a
| `nonexpansive
| `spawn
View
4 qmljsimp/imp_Code.ml
@@ -130,10 +130,6 @@ let compile_expr_to_expr env private_env expr =
| Q.Bypass (_, key) ->
private_env, compile_bypass env key
- | Q.Directive (_, `expanded_bypass, [expr], _) ->
- let key, _ = QmlAstUtils.Bypass.unexpand expr in
- private_env, compile_bypass env key
-
| Q.Lambda _ ->
unimplemented "internal lambda"
View
6 qmlpasses/pass_LambdaLifting.ml
@@ -214,7 +214,6 @@ let pp_ident_set f set =
type 'a ignored_directive =
[ Q.type_directive
- | `expanded_bypass
| `partial_apply of int option
| `lifted_lambda of 'a
| `full_apply of int
@@ -297,11 +296,6 @@ let name_anonymous_lambda_expr ~options annotmap (toplevel_name,e) =
| `untyped ->
let rec aux tra is_anonymous annotmap e =
match e with
- | Q.Directive (_, `expanded_bypass,
- [(Q.Bypass _
- |Q.Directive (_, `restricted_bypass _, _, _))],_) -> annotmap, e
- (* not creating a letin when the expanded bypass is not a function *)
- | Q.Directive (_, `expanded_bypass, _, _)
| Q.Lambda _ when is_anonymous ->
let fun_ident = Ident.refreshf ~map:"anon_fun_%s" toplevel_name in
let annotmap, e = aux tra false annotmap e in
View
2 qmlpasses/pass_Uncurry.ml
@@ -18,7 +18,7 @@
module Q = QmlAst
module List = Base.List
-type ignored_directive = [ Q.type_directive | `expanded_bypass ]
+type ignored_directive = Q.type_directive
(* for each top level function, we record
1-its defining identifier,
View
82 qmlslicer/qmlFakeSlicer.ml
@@ -32,80 +32,24 @@ let locally_defined_bypass ~bymap ~lang bypass =
let langs = BslLib.BSL.ByPass.langs bypass in
List.mem lang langs
-let fresh_ty () = Q.TypeVar (Q.TypeVar.next ())
-
-type info =
- { rewritten : IdentSet.t }
- (* the set of identifier that became functions -> its uses need to be applied *)
-
-let empty_info =
- { rewritten = IdentSet.empty }
-
-let make_error_expr ~annotmap ~bypass ~label =
- let pos = Annot.pos label in
- let error_string =
- Printf.sprintf "Error: trying to use a discarded remote call to %s"
- (BslKey.to_string bypass)
- in
- let arity =
- match QmlAnnotMap.find_ty_label label annotmap with
- | QmlAst.TypeArrow (l,_) -> List.length l
- | _ -> 1 in
- let args = List.init arity (fun _ -> Ident.next "_", fresh_ty ()) in
- let annotmap, error_string_expr =
- QmlAstCons.TypedExpr.string annotmap error_string in
- let annotmap, body =
- QmlAstCons.TypedExpr.directive ~pos annotmap `fail [error_string_expr] [] in
- let annotmap, e =
- QmlAstCons.TypedExpr.lambda annotmap args body in
- annotmap, e
-
(* assuming bypass hoisting has been done
* so bypass are named and are only at the toplevel *)
let gather_info ~bymap ~lang ~annotmap (code : QmlAst.code) =
- QmlAstWalk.CodeExpr.fold_map_name_expr
- (fun ((annotmap, info) as acc) ((i,e) as binding) ->
- match e with
- | Q.Directive (label, `expanded_bypass, [ Q.Bypass (_, bypass) ], _) ->
- if locally_defined_bypass ~bymap ~lang bypass then
- acc, binding
- else
- (* non functional bypass -> we make it a function *)
- let info = {rewritten = IdentSet.add i info.rewritten} in
- let annotmap, e = make_error_expr ~bypass ~label ~annotmap in
- (annotmap, info), (i, e)
- | Q.Directive (_, `expanded_bypass, [e], _) ->
- let bypass =
- Option.get (
- QmlAstWalk.Expr.findmap
- (function
- | Q.Bypass (_, s) -> Some s
- | _ -> None) e
- ) in
- if locally_defined_bypass ~bymap ~lang bypass then
- (* the bypass exists: do not change anything *)
- acc, binding
- else
- (* the bypass does not exists: replace it with the error *)
- let annotmap, e = make_error_expr ~bypass ~label:(Q.Label.expr e) ~annotmap in
- (annotmap,info), (i,e)
- | _ ->
- acc, binding) (annotmap,empty_info) code
-
-let propagate_functionalization info ~gamma ~annotmap (code : QmlAst.code) =
QmlAstWalk.CodeExpr.fold_map
- (fun annotmap e ->
- QmlAstWalk.Expr.foldmap
- (fun annotmap -> function
- | Q.Ident (label, s) when IdentSet.mem s info.rewritten ->
- let annotmap, unit = QmlAstCons.TypedExpr.unit annotmap in
- let pos = Annot.pos label in
- let annotmap, ident = QmlAstCons.TypedExpr.ident ~pos annotmap s (fresh_ty ()) in
- QmlAstCons.TypedExpr.apply gamma annotmap ident [unit]
- | e -> annotmap, e) annotmap e
+ (QmlAstWalk.Expr.traverse_foldmap
+ (fun tra annotmap e ->
+ match e with
+ | Q.Bypass (label,key) when not (locally_defined_bypass ~bymap ~lang key) ->
+ let error_string =
+ Printf.sprintf "Error: trying to use a discarded remote call to %s"
+ (BslKey.to_string key) in
+ let annotmap, error_string_expr = QmlAstCons.TypedExpr.string annotmap error_string in
+ annotmap, Q.Directive (label,`fail,[error_string_expr],[])
+ | _ ->
+ tra annotmap e
+ )
) annotmap code
let discard_remote_bypasses ~bymap ~lang gamma annotmap code =
- let (annotmap, info), code = gather_info ~bymap ~lang ~annotmap code in
- let annotmap, code = propagate_functionalization info ~gamma ~annotmap code in
+ let annotmap, code = gather_info ~bymap ~lang ~annotmap code in
(gamma, annotmap), code
View
2 qmlslicer/qmlSimpleSlicer.ml
@@ -996,7 +996,7 @@ let is_a_lambda info =
let rec aux = function
(* this check should be kept consistent with the one in qmlUncurry presumably *)
| Q.Coerce (_, e, _)
- | Q.Directive (_, (#Q.type_directive | `expanded_bypass), [e], _) -> aux e
+ | Q.Directive (_, #Q.type_directive, [e], _) -> aux e
| Q.Lambda _ -> true
| _ -> false in
match info.expr with

0 comments on commit 3394108

Please sign in to comment.