Skip to content
Browse files

[cleanup] qmljsimp: removing some dead code (and slighly refactoring …

…on the way)
  • Loading branch information...
1 parent f2ce0c4 commit 750fba915133c1983e273de8adaf380389e06aa2 Valentin Gatien-Baron committed Jul 22, 2011
View
2 qmljsimp.mllib
@@ -9,4 +9,4 @@ qmljsimp/Imp_SumCase
qmljsimp/Imp_Renaming
qmljsimp/Imp_CleanUp
qmljsimp/Imp_Inlining
-qmljsimp/jsPasses
+qmljsimp/Imp_SimpleRenaming
View
2 qmljsimp/imp_Renaming.ml
@@ -815,7 +815,7 @@ let rename_code_elt code_elt =
acc, J.Je_function (label,name,params,body)
| _ -> tra acc e)
false code_elt in
- if failed then JsPasses.local_alpha_stm code_elt else code_elt
+ if failed then Imp_SimpleRenaming.local_alpha_stm code_elt else code_elt
let rename code =
List.map rename_code_elt code
View
226 qmljsimp/imp_SimpleRenaming.ml
@@ -0,0 +1,226 @@
+(*
+ Copyright © 2011 MLstate
+
+ This file is part of OPA.
+
+ OPA is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ OPA is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with OPA. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+module J = JsAst
+module Cons = JsCons
+
+let (|>) = InfixOperator.(|>)
+
+module IdentMap = JsAst.IdentMap;;
+module IdentSet = JsAst.IdentSet;;
+
+module List = Base.List
+module String = Base.String
+
+type jsp = JsAst.code -> JsAst.code
+
+(*
+ If we need to have unicity of annotation,
+ we must replace rlabel by :
+ {[
+ let rlabel = Annot.refresh
+ ]}
+*)
+external rlabel : Annot.label -> Annot.label = "%identity"
+
+module Rename :
+sig
+ type env
+ val empty : env
+ val add : JsAst.ident -> env -> env
+ val new_binding : env -> JsAst.ident -> env * JsAst.ident
+ val resolve : env -> JsAst.ident -> JsAst.ident
+ val assert_resolve : env -> JsAst.ident -> JsAst.ident
+end =
+struct
+
+ (*
+ Generate a short JS identifier from an int.
+ In case the identifier returned is a js keyword,
+ skip it, and inspect the next generated one.
+
+ The function return the next int to use for generating
+ the next short ident.
+ *)
+ let rec name_of_int i =
+ let name = IdentGenerator.alphanum i in
+ if JsAst.is_keyword name then name_of_int (i+1) else JsCons.Ident.native name, (i+1)
+
+ type env = JsAst.ident IdentMap.t * int
+ let empty = (IdentMap.empty, 0)
+
+ let new_binding (map, number) ident =
+ let new_ident, number = name_of_int number in
+ let map = IdentMap.add ident new_ident map in
+ (map, number), new_ident
+
+ let add ident (map, number) =
+ let new_ident, number = name_of_int number in
+ let map = IdentMap.add ident new_ident map in
+ (map, number)
+
+ let resolve (map, _) ident =
+ match IdentMap.find_opt ident map with
+ | Some ident -> ident
+ | None -> ident
+
+ let assert_resolve (map, _) ident =
+ match IdentMap.find_opt ident map with
+ | Some ident -> ident
+ | None ->
+ assert false
+end
+
+(*
+ Collect vars and function local to a statement, without entering
+ internal function inside other functions.
+*)
+let stmt_collect_locals acc s =
+ JsWalk.OnlyStatement.traverse_fold (
+ fun tra acc -> function
+ | J.Js_var (_, ident, _) -> Rename.add ident acc
+ | J.Js_function (_, ident, _, _) -> Rename.add ident acc (* NOT traversing *)
+ | J.Js_trycatch (_,_,catches,_) ->
+ let acc = List.fold_left (fun acc (ident,_,_) -> Rename.add ident acc) acc catches in
+ tra acc s
+ | s ->
+ tra acc s
+ ) acc s
+
+(*
+ Cf the notice for the 3 following recursive functions.
+
+ {[
+ let rec rename_expr
+ and rename_function
+ and rename_statement
+ ]}
+*)
+
+let rec rename_expr (acc : Rename.env) e =
+ JsWalk.OnlyExpr.traverse_map (
+ fun tra e ->
+ match e with
+ | J.Je_function (label, ident, params, body) ->
+ let recons (ident, params, body) = J.Je_function (label, ident, params, body) in
+ recons (rename_function acc ident params body)
+
+ | J.Je_ident (label, ident) ->
+ let ident = Rename.resolve acc ident in
+ let e = J.Je_ident (label, ident) in
+ e
+
+ | e ->
+ tra e
+ ) e
+
+and rename_function acc ident params body =
+ let ident = Option.map (Rename.resolve acc) ident in
+ let acc, params = List.fold_left_map Rename.new_binding acc params in
+ let acc = List.fold_left stmt_collect_locals acc body in
+ let body = List.tail_map (rename_statement acc) body in
+ (ident, params, body)
+
+and rename_statement acc stmt =
+ JsWalk.TStatement.traverse_map (
+ fun traS _traE s ->
+ match s with
+ | J.Js_var (label, ident, expr) ->
+ let ident = Rename.resolve acc ident in
+ let expr = Option.map (rename_expr acc) expr in
+ J.Js_var (label, ident, expr)
+
+ | J.Js_function (label, ident, params, body) ->
+ let recons (ident, params, body) =
+ let ident = Option.get ident in
+ J.Js_function (label, ident, params, body) in
+ recons (rename_function acc (Some ident) params body)
+
+ | J.Js_trycatch (label, body, catches, finally) ->
+ let catches = List.map (fun (ident, e, s) -> (Rename.resolve acc ident, e, s)) catches in
+ let s = J.Js_trycatch (label, body, catches, finally) in
+ traS s
+
+ (*
+ the node with is not supported by the local renaming
+ *)
+ | J.Js_with _ -> assert false
+
+ | s -> traS s
+ )
+ (fun _traE _traS e -> rename_expr acc e)
+ stmt
+
+
+(*
+ Renaming function parameters, and local variables.
+ This renaming does not affect toplevel identifiers
+*)
+let local_alpha_stm stm =
+ let acc = Rename.empty in
+ rename_statement acc stm
+let local_alpha code =
+ let acc = Rename.empty in
+ List.tail_map (rename_statement acc) code
+
+(*
+ NOTICE:
+
+let rec rename_expr (acc : Rename.env) e =
+ let rec aux e =
+ ExprOnly.map_down
+ ou un traverse_map_down où on fait gaffe aux je_function
+ map_down utilisant acc
+ sauf dans le cas Je_function,
+ où on appelle une regle de renommage des fonctions
+ qui appelle rename_statement avec (acc + quelque chose)
+ in
+ aux_expr e
+
+and rename_function recons acc ident params body =
+ 1) on rename ident avec ce acc,
+
+ 2) collect les var et les function dans body sans rentrer dans les function
+ fold sur statement only, pas de tra sur Js_function
+ StatementOnly.traverse_fold
+
+ 3) ca en fait un acc2,
+ on met params dans acc2
+ on renomme le body avec acc2 (rename_statement)
+ et on recons
+
+and rename_statement acc s =
+
+ - si tombe sur Js_function, simplement appliquer rename_function
+ - si var : simplement appliquer le renommage
+
+ sinon : rename_expr avec le meme acc
+ et tra acc sur les statement
+ TStatement.traverse_map
+ avec rename_expr sur les expr
+ et tra sur les statement
+
+TStatement.traverse_map
+ (fun traS traE e -> rename_expr acc e)
+ (fun traS traE s ->
+ match s with
+ | Js_function -> rename_function
+ | JsVar -> lookup acc pour renommer
+ | s -> traS s)
+ s
+*)
View
30 qmljsimp/imp_SimpleRenaming.mli
@@ -0,0 +1,30 @@
+(*
+ Copyright © 2011 MLstate
+
+ This file is part of OPA.
+
+ OPA is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ OPA is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with OPA. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+(**
+ This function makes an alpha renaming on each local value:
+ - function parameters
+ - local function variables
+ - local letin
+ - identifiers bound by catch
+
+ using a short ident generator, using a reset for each toplevel declaration,
+ for keeping identifier short, even on a huge code.
+*)
+val local_alpha_stm : JsAst.statement -> JsAst.statement
+val local_alpha : JsAst.code -> JsAst.code
View
714 qmljsimp/jsPasses.ml
@@ -1,714 +0,0 @@
-(*
- Copyright © 2011 MLstate
-
- This file is part of OPA.
-
- OPA is free software: you can redistribute it and/or modify it under the
- terms of the GNU Affero General Public License, version 3, as published by
- the Free Software Foundation.
-
- OPA is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
- more details.
-
- You should have received a copy of the GNU Affero General Public License
- along with OPA. If not, see <http://www.gnu.org/licenses/>.
-*)
-
-module J = JsAst
-module Cons = JsCons
-
-let (|>) = InfixOperator.(|>)
-
-module IdentMap = JsAst.IdentMap;;
-module IdentSet = JsAst.IdentSet;;
-
-module List = Base.List
-module String = Base.String
-
-type jsp = JsAst.code -> JsAst.code
-
-(*
- If we need to have unicity of annotation,
- we must replace rlabel by :
- {[
- let rlabel = Annot.refresh
- ]}
-*)
-external rlabel : Annot.label -> Annot.label = "%identity"
-
-(* ======================================================================= *)
-(*
- PASS 1: TAILREC MACHINE
-*)
-(* ======================================================================= *)
-
-(*
- [map_tl f e]
- map the output of the expression [e] :
- it just rewrites the returned expression when it's a Call node.
-
- The function [f] rewrite a node [g(args)] by taking the function
- [g] and the parameters list [args] in argument. (plus the [pure] flag)
-*)
-let expr_map_tl map e =
- let rec aux e =
- match e with
-
- | J.Je_comma (label, comma, last) ->
- let last = aux last in
- JsCons.Expr.comma ~label comma last
-
- | J.Je_cond (label, cond, then_, else_) ->
- let then_ = aux then_ in
- let else_ = aux else_ in
- JsCons.Expr.cond ~label cond then_ else_
-
- | J.Je_call (label, func, el, pure) ->
- map label func el pure
-
- | e -> e
- in
- aux e
-
-(*
- rewrite tail call apply with tco property
-*)
-let expr_rewrite_tl expr =
- expr_map_tl
- (fun label f el pure ->
- let recons f = JsCons.Expr.call ~label ~pure f el in
- let tco () = recons (JsCons.Expr.field ~label:(rlabel label) f "tco") in
- match f with
- | J.Je_ident (_, J.Native (_, n)) ->
- (*Special optimization: don't [tco-ize] calls to the BSL, unless we know we need it*)
- if String.is_prefix "clos_apply" n
- then tco ()
- else recons f
- | _ -> tco ()
- ) expr
-
-(*
- map the expression returned
-*)
-let statement_map_return map = function
- | J.Js_return (label, Some e) -> J.Js_return (label, Some (map e))
- | s -> s
-
-(*
- map all expression contained in all tail call position of a statement
-*)
-let statement_map_tl map stmt =
- JsWalk.Statement.map_down (statement_map_return map) stmt
-
-(*
- process to the tco rewriting in all tail call positions of a statement
-*)
-let statement_rewrite_tl stmt = statement_map_tl expr_rewrite_tl stmt
-
-(*
- Once all tail call have been rewriten using [tco], other call should
- be rewriten using [t].
-*)
-let search_and_rewrite_fun e =
- match e with
- | J.Je_call ( _, J.Je_dot (_, _, "tco"), _, _pure) -> e
- | J.Je_call (label, e, li, pure) ->
- JsCons.Expr.call ~label ~pure (JsCons.Expr.field ~label:(rlabel label) e "t") li
- | _ -> e
-
-let mktl (code:JsAst.code) : JsAst.code =
- let code = List.tail_map
- (function
- | J.Js_var (label, ident, Some e) ->
- let e = JsWalk.Expr.map_down search_and_rewrite_fun e in
- JsCons.Statement.var ~label ident ~expr:e
-
- | J.Js_function (label, ident, params, body) ->
- let body = List.map statement_rewrite_tl body in
- let body = List.map (JsWalk.ExprInStatement.map_down search_and_rewrite_fun) body in
- JsCons.Statement.function_ ~label ident params body
-
- | J.Js_var (_,_,None)
- | J.Js_comment _ as s -> s
-
- | s ->
- OManager.printf "statement: %a@\n" JsPrint.pp#statement s ;
- assert false
- )
- code
- in code
-
-(* ======================================================================= *)
-(*
- PASS 2: LOCAL RENAMING
-*)
-(* ======================================================================= *)
-
-module Rename :
-sig
- type env
- val empty : env
- val add : JsAst.ident -> env -> env
- val new_binding : env -> JsAst.ident -> env * JsAst.ident
- val resolve : env -> JsAst.ident -> JsAst.ident
- val assert_resolve : env -> JsAst.ident -> JsAst.ident
-end =
-struct
-
- (*
- Generate a short JS identifier from an int.
- In case the identifier returned is a js keyword,
- skip it, and inspect the next generated one.
-
- The function return the next int to use for generating
- the next short ident.
- *)
- let rec name_of_int i =
- let name = IdentGenerator.alphanum i in
- if JsAst.is_keyword name then name_of_int (i+1) else JsCons.Ident.native name, (i+1)
-
- type env = JsAst.ident IdentMap.t * int
- let empty = (IdentMap.empty, 0)
-
- let new_binding (map, number) ident =
- let new_ident, number = name_of_int number in
- let map = IdentMap.add ident new_ident map in
- (map, number), new_ident
-
- let add ident (map, number) =
- let new_ident, number = name_of_int number in
- let map = IdentMap.add ident new_ident map in
- (map, number)
-
- let resolve (map, _) ident =
- match IdentMap.find_opt ident map with
- | Some ident -> ident
- | None -> ident
-
- let assert_resolve (map, _) ident =
- match IdentMap.find_opt ident map with
- | Some ident -> ident
- | None ->
- assert false
-end
-
-(*
- Collect vars and function local to a statement, without entering
- internal function inside other functions.
-*)
-let stmt_collect_locals acc s =
- JsWalk.OnlyStatement.traverse_fold (
- fun tra acc -> function
- | J.Js_var (_, ident, _) -> Rename.add ident acc
- | J.Js_function (_, ident, _, _) -> Rename.add ident acc (* NOT traversing *)
- | J.Js_trycatch (_,_,catches,_) ->
- let acc = List.fold_left (fun acc (ident,_,_) -> Rename.add ident acc) acc catches in
- tra acc s
- | s ->
- tra acc s
- ) acc s
-
-(*
- Cf the notice for the 3 following recursive functions.
-
- {[
- let rec rename_expr
- and rename_function
- and rename_statement
- ]}
-*)
-
-let rec rename_expr (acc : Rename.env) e =
- JsWalk.OnlyExpr.traverse_map (
- fun tra e ->
- match e with
- | J.Je_function (label, ident, params, body) ->
- let recons (ident, params, body) = J.Je_function (label, ident, params, body) in
- recons (rename_function acc ident params body)
-
- | J.Je_ident (label, ident) ->
- let ident = Rename.resolve acc ident in
- let e = J.Je_ident (label, ident) in
- e
-
- | e ->
- tra e
- ) e
-
-and rename_function acc ident params body =
- let ident = Option.map (Rename.resolve acc) ident in
- let acc, params = List.fold_left_map Rename.new_binding acc params in
- let acc = List.fold_left stmt_collect_locals acc body in
- let body = List.tail_map (rename_statement acc) body in
- (ident, params, body)
-
-and rename_statement acc stmt =
- JsWalk.TStatement.traverse_map (
- fun traS _traE s ->
- match s with
- | J.Js_var (label, ident, expr) ->
- let ident = Rename.resolve acc ident in
- let expr = Option.map (rename_expr acc) expr in
- J.Js_var (label, ident, expr)
-
- | J.Js_function (label, ident, params, body) ->
- let recons (ident, params, body) =
- let ident = Option.get ident in
- J.Js_function (label, ident, params, body) in
- recons (rename_function acc (Some ident) params body)
-
- | J.Js_trycatch (label, body, catches, finally) ->
- let catches = List.map (fun (ident, e, s) -> (Rename.resolve acc ident, e, s)) catches in
- let s = J.Js_trycatch (label, body, catches, finally) in
- traS s
-
- (*
- the node with is not supported by the local renaming
- *)
- | J.Js_with _ -> assert false
-
- | s -> traS s
- )
- (fun _traE _traS e -> rename_expr acc e)
- stmt
-
-
-(*
- Renaming function parameters, and local variables.
- This renaming does not affect toplevel identifiers
-*)
-let local_alpha_stm stm =
- let acc = Rename.empty in
- rename_statement acc stm
-let local_alpha code =
- let acc = Rename.empty in
- List.tail_map (rename_statement acc) code
-
-(*
- NOTICE:
-
-let rec rename_expr (acc : Rename.env) e =
- let rec aux e =
- ExprOnly.map_down
- ou un traverse_map_down où on fait gaffe aux je_function
- map_down utilisant acc
- sauf dans le cas Je_function,
- où on appelle une regle de renommage des fonctions
- qui appelle rename_statement avec (acc + quelque chose)
- in
- aux_expr e
-
-and rename_function recons acc ident params body =
- 1) on rename ident avec ce acc,
-
- 2) collect les var et les function dans body sans rentrer dans les function
- fold sur statement only, pas de tra sur Js_function
- StatementOnly.traverse_fold
-
- 3) ca en fait un acc2,
- on met params dans acc2
- on renomme le body avec acc2 (rename_statement)
- et on recons
-
-and rename_statement acc s =
-
- - si tombe sur Js_function, simplement appliquer rename_function
- - si var : simplement appliquer le renommage
-
- sinon : rename_expr avec le meme acc
- et tra acc sur les statement
- TStatement.traverse_map
- avec rename_expr sur les expr
- et tra sur les statement
-
-TStatement.traverse_map
- (fun traS traE e -> rename_expr acc e)
- (fun traS traE s ->
- match s with
- | Js_function -> rename_function
- | JsVar -> lookup acc pour renommer
- | s -> traS s)
- s
-*)
-
-(*
-
- match e with
- | J.Je_function (label, ident, params, body) ->
- assert ident = None;
- let acc, params = List.fold_left_map Rename.new_binding acc params in
- let _, body = List.fold_left_map self_statement acc body in
- let e = J.Je_function (label, ident, params, body) in
- e
-
- (*
- We check there than not renamed identifier are not modified
- This would be a bug detection, meaning than a function modify a toplevel variable
- in a letin e.g.
- *)
-
- | J.Je_unop (l1, op, (J.Je_ident (l2, ident))) ->
- if JsAst.is_side_effect_unop op
- then
- let ident = Rename.assert_resolve acc ident in
- let e = J.Je_unop (l1, op, (J.Je_ident (l2, ident)))
- acc, e
- else
- tra acc e
-
- | J.Je_binop (l1, op, (J.Je_ident (l2, ident)), e2) ->
- if JsAst.is_side_effect_binop op
- then
- let ident = Rename.assert_resolve acc ident in
- let acc, e2 = self_expr acc e2 in
- let e = J.Je_binop (l1, op, (J.Je_ident (l2, ident)), e2) in
- acc, e
- else
- tra acc e
-
- (* end of check *)
-
- | J.Je_ident (label, ident) ->
- let ident = Rename.resolve acc ident in
- let e = J.Je_ident (label, ident) in
- acc, e
-
- | e ->
- tra acc e
-
-
-(* deep statement *)
-
- match s with
- | J.Js_var (label, ident, expr) ->
- let acc, ident = Rename.new_binding acc ident in
- let acc, expr = self_expr acc expr in
- let s = J.Js_var (label, ident, expr) in
- acc, s
-
- | J.Js_function (label, ident, params, body) ->
- let acc as init_acc, = acc in
- let acc, params = List.fold_left_map Rename.new_binding acc params in
- let acc, body = List.fold_left_map self_statement acc body in
-
- let acc, ident = Rename.new_binding
-
- | s ->
- tra acc s
-
-(* toplevel statement *)
-
- match s with
-
- | J.Js_var (label, ident, expr) ->
- let _, expr = rename_expr Rename.empty expr in
- JsCons.Statement.var ~label ident expr
-
- | J.Js_function (label, ident, params, body) ->
- let process (map, n) i =
- let ni, n1 = name_of_int n in
- let map = IdentMap.add i ni map in
- (map, n1)
- in
- let (newnames, _) as acc = List.fold_left process (IdentMap.empty, 0) params in
- let params =
- let find x = IdentMap.find x newnames in
- List.map find params
- in
-
- let _, body =
- List.fold_left_map (
- fun acc stmt ->
- JsWalk.ExprInStatement
- rename (newnames, number)
- ) acc body in
-
- JsCons.Statement.function_ ~label ident params body
-
- | ( J.Js_comment _ ) as s -> s
-
- | s ->
- OManager.printf "statement: %a@\n" JsPrint.pp#statement s ;
- assert false
- )
-
-*)
-
-(*
-let rename (((_ : JsAst.ident IdentMap.t), (_ : int)) as acc) expr =
- JsWalk.self_traverse_foldmap
- (fun self tra acc e ->
- match e with
-
- | J.LetIn (annot, bindings, expr) ->
- let acc, bindings =
- List.fold_left_map
- ( fun (map, number) (i, expr) ->
- let ni, number = match IdentMap.find_opt i map with
- | Some ni -> ni, number
- | None -> assert false
- in
- let map = IdentMap.add i ni map in
- let acc, expr = self (map, number) expr in
- acc, (ni, expr)
- ) acc bindings in
- let acc, expr = self acc expr in
- acc, J.LetIn (annot, bindings, expr)
-
- | J.Func (annot, args, local, body) ->
- let on_list acc idents =
- List.fold_left_map
- (fun (map, number) i ->
- let ni, number =
- match IdentMap.find_opt i map with
- | Some ni -> ni, number
- | None -> name_of_int number in
- let map = IdentMap.add i ni map in
- (map, number), ni
- ) acc idents in
- let acc, args = on_list acc args in
- let acc, local = on_list acc local in
- let acc, body = self acc body in
- acc, (J.Func (annot, args, local, body))
-
- | J.Ident (annot, i) ->
- let map = fst acc in
- let i = Option.default i (IdentMap.find_opt i map) in
- acc, J.Ident (annot, i)
-
- | _ -> tra acc e
-
- ) acc expr
-
-let local_alpha code =
- List.map
- (function
-
- | J.Js_var (label, ident, expr) ->
- let _, expr = rename (IdentMap.empty, 0) expr in
- JsCons.Statement.var ~label ident expr
-
- | J.Js_function (label, ident, params, body) ->
- let process (map, n) i =
- let ni, n1 = name_of_int n in
- let map = IdentMap.add i ni map in
- (map, n1)
- in
- let (newnames, _) as acc = List.fold_left process (IdentMap.empty, 0) params in
- let params =
- let find x = IdentMap.find x newnames in
- List.map find params
- in
-
- let _, body =
- List.fold_left_map (
- fun acc stmt ->
- JsWalk.ExprInStatement
- rename (newnames, number)
- ) acc body in
-
- JsCons.Statement.function_ ~label ident params body
-
- | ( J.Js_comment _ ) as s -> s
-
- | s ->
- OManager.printf "statement: %a@\n" JsPrint.pp#statement s ;
- assert false
- )
- code
-
-*)
-
-(* ======================================================================= *)
-(*
- PASS 3: SPLIT DEEP EXPRESSIONS
-*)
-(* ======================================================================= *)
-
-(*
- Adding identifiers in a list and a set simultanously.
-*)
-let add_idents acc idents =
- List.fold_left (
- fun ((li, idents) as acc) i ->
- if IdentSet.mem i idents
- then acc
- else (i :: li, (IdentSet.add i idents))
- ) acc idents
-
-(*
- Compute the depth of an Js expression
-*)
-let rec depth e =
- 1 + JsWalk.OnlyExpr.fold_nonrec
- (fun acc e ->
- max acc (depth e)
- )
- 0 e
-
-(*
- doc ?
-*)
-let maxp = 12
-
-(*
-
-(**
- @param [ident] used only for giving a name related to the original name of the [code_elt]
- containing the expression being rewriten.
-*)
-let rewrite
- (ident:JsAst.ident)
- (local:IdentSet.t)
- (e:JsAst.expr)
- (p:int)
- before
- (local_set_toremove:IdentSet.t)
- =
- let rec rewrite
- (local:IdentSet.t)
- (e:JsAst.expr)
- (p:int)
- before
- (local_set_toremove:IdentSet.t)
- =
- if (depth e) < maxp
- then
- (before, local_set_toremove), e
- else
- let local =
- match e with
- | J.Func (_annot, idents, idents2, _) ->
- IdentSet.union local
- (IdentSet.from_list (List.rev_append idents idents2))
- | _ -> local
- in
- if p = 0 then
- let local_newexpr, local_set = JsWalk.fold_down
- (fun acc e -> match e with
- | J.LetIn (_annot, bindings, _) ->
- add_idents acc (List.map fst bindings)
- | J.Func (_annot, idents, _, _) ->
- add_idents acc idents
- | _ -> acc
- ) ([], IdentSet.empty) e
- in
- let tobind = JsWalk.fold_down
- (fun idents e -> match e with
- | J.Ident (_, i) ->
- if IdentSet.mem i local
- then IdentSet.add i idents
- else idents
- | _ -> idents
- ) IdentSet.empty e
- in
- let tobind = IdentSet.diff tobind local_set |> IdentSet.elements in
- let (before, local_set_toremove), ne =
- rewrite local e maxp before (IdentSet.union local_set_toremove local_set) in
- let nident = JsCons.Ident.fresh ident in
- let ndefs = J.Defun(Cons.annot (), nident, tobind, local_newexpr, ne) :: before in
- let nexpr = Cons.call ~pure:false (Cons.ident nident) (List.map Cons.ident tobind)
- in (ndefs, local_set_toremove), nexpr
-
- else
- JsWalk.foldmap_nonrec (
- fun (before, local_set_toremove) e ->
- rewrite local e (p - 1) before local_set_toremove
- ) (before, local_set_toremove) e
-
- in
- rewrite
- (local:IdentSet.t)
- (e:JsAst.expr)
- (p:int)
- before
- (local_set_toremove:IdentSet.t)
-
-*)
-
-(*
- doc ?
-*)
-let split code = code
-
-(*
-
- let rewrite ident construct local e =
- let (before, local_set_toremove), e =
- rewrite ident (IdentSet.from_list local) e maxp [] IdentSet.empty
- in
- List.rev ((construct e local_set_toremove) :: before)
- in
- List.concat_map (
- function
- | J.Def (annot, ident, expr) ->
- let recons e _ = J.Def (annot, ident, e) in
- rewrite ident recons [] expr
-
- | J.Defun(annot, ident, args, local, body) ->
- let recons e local_toremove =
- let locals = IdentSet.elements (IdentSet.diff (IdentSet.from_list local) local_toremove) in
- J.Defun (annot, ident, args, locals, e)
- in
- rewrite ident recons (List.append args local) body
-
- | x -> [x]
-
- ) code
-
-*)
-
-
-
-
-(*
-
-
-... acc ...
-
-let rec rename_expr acc e =
- let rec aux_expr e =
- ExprOnly.map_down
- où un traverse_map_down ou on fait gaffe aux je_function
- map_down utilisant acc
- sauf dans le cas Je_function,
- où on appelle une regle de renommage des fonctions
- qui appelle rename_statement avec (acc + quelque chose)
- in
- aux_expr e
-
-and rename_function recons acc ident params body =
- 1) on rename ident avec ce acc,
-
- 2) collect les var et les function dans body sans rentrer dans les function
- fold sur statement only, pas de tra sur Js_function
- StatementOnly.traverse_fold
-
- 3) ca en fait un acc2,
- on met params dans acc2
- on renomme le body avec acc2 (rename_statement)
- et on recons
-
-and rename_statement acc s =
-
- - si tombe sur Js_function, simplement appliquer rename_function
- - si var : simplement appliquer le renommage
-
- sinon : rename_expr avec le meme acc
- et tra acc sur les statement
- TStatement.traverse_map
- avec rename_expr sur les expr
- et tra sur les statement
-
-
-TStatement.traverse_map
- (fun traS traE e -> rename_expr acc e)
- (fun traS traE s ->
- match s with
- | Js_function -> rename_function
- | JsVar -> lookup acc pour renommer
- | s -> traS s)
- s
- *)
View
60 qmljsimp/jsPasses.mli
@@ -1,60 +0,0 @@
-(*
- Copyright © 2011 MLstate
-
- This file is part of OPA.
-
- OPA is free software: you can redistribute it and/or modify it under the
- terms of the GNU Affero General Public License, version 3, as published by
- the Free Software Foundation.
-
- OPA is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
- more details.
-
- You should have received a copy of the GNU Affero General Public License
- along with OPA. If not, see <http://www.gnu.org/licenses/>.
-*)
-(**
- This module contains some passes for the javascript AST.
- @author Maxime Audouin
-*)
-
-type jsp = JsAst.code -> JsAst.code
-
-(**
- Transform recursive code element on element code using [tailrec_machine].
- Replace call to function by call using the [t] and [tco] function prototype
-
- cf ["qmlJsfunClientLib.js"]
- for the implementation of prototype [t] and [tso].
-
- This transformation is made in 2 kind of location for function applications:
-
- 1) in terminal call position, instead of beeing recursive, and returning a call to itself,
- it returns potentially a [TailCall] object, containing the rest of the execution to
- process, using the prototype [tco] of the [Function] class.
-
- 2) in other call positions, instead of calling the function direclty (it would not type
- because the function potentially has previously returned a [TailCall] object instead of
- the restul) it used the prototype [t] of the [Function] class, which loops until the
- final result is returned.
-*)
-val mktl : jsp
-
-(**
- This function makes an alpha renaming on each local value:
- -function parameters
- -local function variables
- -local letin
-
- using a short ident generator, using a reset for each toplevel declaration,
- for keeping identifier short, even on a huge code.
-*)
-val local_alpha_stm : JsAst.statement -> JsAst.statement
-val local_alpha : jsp
-
-(**
- Split too deep expressions.
-*)
-val split : jsp
View
56 qmljsimp/qmlJsImpClientLib.js
@@ -16,21 +16,26 @@
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*/
+/* js_void is shared */
var js_void = {}
var _true = true
var _false = false
+
/**
* @type {!Object}
*/
var js_none = {none:js_void}
+
/**
* @return(!Object)
*/
function js_some(x) { return {some:x} }
+
function bool2obj(x) {
// WONT BE IMPLEMENTED or change the name
return x
}
+
function unsafe_dot(r,f) {
switch (f) {
case "true": r = dot_true(r); break
@@ -41,6 +46,7 @@ function unsafe_dot(r,f) {
if (r === undefined) error("unsafe_dot failed on " + f);
return r
}
+
function dot(r,f) {
switch (f) {
case "true": r = dot_true(r); break
@@ -51,6 +57,7 @@ function dot(r,f) {
if (r === undefined) return js_none
return {some:r}
}
+
function udot(r,f) {
switch (f) {
case "true": return dot_true(r)
@@ -59,10 +66,14 @@ function udot(r,f) {
default: return r[f];
}
}
+
function fold_record(f, record, acc) {
- // FIXME? should try to use the enumeration of object properties
- // to avoid resorting later
- // but if we decide to do it, beware with the implementation of extendrecord
+ /* after a few tests:
+ * [for in] is a slow of iterating over the properties of an object
+ * (even if you don't sort as is done here)
+ * it is actually faster if you have the array of fields
+ * (in addition to the record you want to fold)
+ */
switch (record) {
case true: return f("true",js_void,acc)
case false: return f("false",js_void,acc)
@@ -77,6 +88,7 @@ function fold_record(f, record, acc) {
return acc
}
}
+
function fold_2_record(f, record1, record2, acc) {
switch (record1) {
case true: return f("true", js_void, js_void, acc)
@@ -92,33 +104,40 @@ function fold_2_record(f, record1, record2, acc) {
return acc
}
}
+
function name_of_field(field) {
return {some : field}
}
+
function field_of_name(name) {
return {some : name}
}
+
function static_field_of_name(name) {
return name
}
+
function empty_constructor() {
var c = {} /* this object will be modified, do not share it with js_void */
c[_size] = 0
return c
}
+
function add_field(constructor, field, value) {
if (field in constructor) error("add_field: trying to add the field " +field+" to the constructor "+constructor.toSource())
constructor[field] = value;
constructor[_size]++;
return constructor
}
+
function make_record(constructor) {
switch (size(constructor)) {
case 0: return js_void;
case 1: return un_uniformize_bool(constructor)
default: return constructor;
}
}
+
function make_simple_record(field) {
switch (field) {
case "true": return true
@@ -129,6 +148,7 @@ function make_simple_record(field) {
return r
}
}
+
function make_onefield_record(field,value) {
switch (field) {
case "true": return build_true(value)
@@ -139,22 +159,27 @@ function make_onefield_record(field,value) {
return r;
}
}
+
function obj2bool() {
// WONT BE IMPLEMENTED or change the name
error("obj2bool not implemented")
}
+
function normalize_obj(x) { return x;
// WONT BE IMPLEMENTED
// error("normalize_obj not implemented")
}
+
function normalize_num() {
// WONT BE IMPLEMENTED or change the name
error("normalize_num not implemented")
}
+
function extendrecord() {
// WONT BE IMPLEMENTED or change the name
error("extendrecord not implemented")
}
+
function list2js(opalist) {
var result = [], tl;
while ((tl = opalist.tl) !== undefined) {
@@ -163,24 +188,27 @@ function list2js(opalist) {
}
return result;
}
+
function js2list(array) {
var i = array.length - 1, result = {nil : js_void}
for (; i >= 0; i--) {
result = {hd:array[i], tl:result}
}
return result
}
+
function option2js(obj) {
return 'some' in obj ? obj.some : null
}
+
function option2jsu(obj) {
return obj.some
}
+
function js2option(obj) {
return obj == null ? js_none : {some : obj}
}
-// copy pasted from qmlfunclientlib
function compare_raw(a,b) {
switch (typeof a){
case "number":
@@ -238,13 +266,15 @@ function tailcall_manager_apply(fun, args) {
function build_true(e) {
return e === js_void ? true : {'true':e}
}
+
function build_false(e) {
return e === js_void ? false : {'false':e}
}
function dot_true(e) {
return e === true ? js_void : e["true"]
}
+
function dot_false(e) {
return e === false ? js_void : e["false"]
}
@@ -269,6 +299,7 @@ function size(x) {
function uniformize_bool(o) {
return o === true ? {'true':js_void} : o === false ? {'false':js_void} : o;
}
+
function un_uniformize_bool(o) {
return o["true"] === js_void && size(o) === 1 ? true : o["false"] === js_void && size(o) === 1 ? false : o;
}
@@ -284,50 +315,67 @@ function extend_record(original_record,new_fields) {
/*
* dynamic type checking
+ * the functions in here take (at least) a value
+ * and checks that it has the expected type (it is a shallow test
+ * since you can't do much better for functions)
*/
function typeerror(key,msg) {
error("TypeError on the bsl key %"+"%"+key+"%"+"% : "+msg)
}
+
function type_var(key,value) {
value != null || typeerror(key,"type var vs value "+value)
}
+
function type_bool(key,value) {
typeof value == "boolean" || typeerror(key,"type bool vs value "+value)
}
+
function type_void(key,value) {
value === js_void || typeerror(key,"type void vs value "+value)
}
+
function type_option(key,value) {
size(value) == 1 && ('none' in value || 'some' in value) || typeerror(key,"type option vs value "+value)
}
+
// special case: we accept the js_void, in case of a double projection
function type_native_void(key,value) {
value == null || value === js_void || typeerror(key, "type native void vs value "+value)
}
+
function type_native_option(key,value) {
value != null || value === null || typeerror(key, "type native option vs value "+value)
}
+
function type_int(key,value) {
typeof value == "number" && Math.round(value) == value && !isNaN(value) || typeerror(key,"type int vs value "+value)
}
+
function type_float(key,value) {
typeof value == "number" || typeerror(key,"type float vs value "+value)
}
+
function type_string(key,value) {
typeof value == "string" || typeerror(key,"type string vs value "+value)
}
+
function type_char(key,value) {
typeof value == "string" && value.length == 1 || typeerror(key,"type char vs value "+value)
}
+
function type_extern(key,value) {
value != null || typeerror(key,"type extern vs value "+value)
}
+
function type_fun(key,value) {
typeof value == "function" || typeerror(key,"type fun vs value "+value)
}
+
function type_fun_arity(key,args,arity) {
args.length == arity || typeerror(key,"type fun of arity="+arity+" vs arguments received: "+args.length)
}
+
function type_opavalue(key,value) {
value != null || typeerror(key,"type opavalue vs value "+value)
}

0 comments on commit 750fba9

Please sign in to comment.
Something went wrong with that request. Please try again.