From 818a58658036a6695a6a4f08f164bb589a4993cb Mon Sep 17 00:00:00 2001 From: Radu Grigore Date: Wed, 2 Jun 2021 22:47:31 -0700 Subject: [PATCH] [erl-frontend] Translation for functions Summary: This handles function definitions. (Expressions, aka function bodies, are not translated.) Reviewed By: skcho Differential Revision: D28606721 fbshipit-source-id: 0fd5dc57e --- infer/src/IR/BuiltinDecl.ml | 2 + infer/src/IR/BuiltinDecl.mli | 3 + infer/src/erlang/ErlangTranslator.ml | 166 ++++++++++++++++++-------- infer/src/erlang/ErlangTranslator.mli | 2 +- infer/src/integration/Rebar3.ml | 4 +- 5 files changed, 124 insertions(+), 53 deletions(-) diff --git a/infer/src/IR/BuiltinDecl.ml b/infer/src/IR/BuiltinDecl.ml index a1ca5fbea..a1525459b 100644 --- a/infer/src/IR/BuiltinDecl.ml +++ b/infer/src/IR/BuiltinDecl.ml @@ -76,6 +76,8 @@ let __delete_array = create_procname "__delete_array" let __delete_locked_attribute = create_procname "__delete_locked_attribute" +let __erlang_pattern_fail = create_procname "__erlang_pattern_fail" + let __exit = create_procname "_exit" let __objc_bridge_transfer = create_procname "__objc_bridge_transfer" diff --git a/infer/src/IR/BuiltinDecl.mli b/infer/src/IR/BuiltinDecl.mli index 2511da9c2..9d9cace63 100644 --- a/infer/src/IR/BuiltinDecl.mli +++ b/infer/src/IR/BuiltinDecl.mli @@ -13,6 +13,9 @@ include BUILTINS.S with type t = Procname.t val is_declared : Procname.t -> bool +val __erlang_pattern_fail : t +(** all patterns in a function failed to match *) + val __infer_initializer_list : Procname.t val __infer_skip_function : Procname.t diff --git a/infer/src/erlang/ErlangTranslator.ml b/infer/src/erlang/ErlangTranslator.ml index efd366744..975301f28 100644 --- a/infer/src/erlang/ErlangTranslator.ml +++ b/infer/src/erlang/ErlangTranslator.ml @@ -33,19 +33,27 @@ end type module_name = string [@@deriving sexp_of] -(** [exports] are used to determine which functions are public; [imports] and [current_module] are - used to turn unqualified function references into qualified ones *) -type names_env = - { exports: UnqualifiedFunction.Set.t - ; imports: module_name UnqualifiedFunction.Map.t - ; current_module: module_name } +type block = + { start: Procdesc.Node.t + ; exit_success: Procdesc.Node.t + ; exit_failure: Procdesc.Node.t + ; value: Ident.t } + +type environment = + { exports: UnqualifiedFunction.Set.t (** used to determine public/private access *) + ; imports: module_name UnqualifiedFunction.Map.t (** used to resolve function names *) + ; current_module: module_name (** used to qualify function names *) + ; source: (SourceFile.t[@sexp.opaque]) (** used to add location information *) + ; procdesc: (Procdesc.t option[@sexp.opaque]) (** imperative, being built *) } [@@deriving sexp_of] -let get_environment module_ : names_env = +let get_environment module_ : environment = let init = { exports= UnqualifiedFunction.Set.empty ; imports= UnqualifiedFunction.Map.empty (* TODO: auto-import from module "erlang" *) - ; current_module= Printf.sprintf "%s:unknown_module" __FILE__ } + ; current_module= Printf.sprintf "%s:unknown_module" __FILE__ + ; source= SourceFile.invalid __FILE__ + ; procdesc= None } in let f env (form : Ast.form) = match form.simple_form with @@ -66,67 +74,127 @@ let get_environment module_ : names_env = {env with imports} | Module current_module -> {env with current_module} + | File {path} -> + {env with source= SourceFile.create path} | _ -> env in List.fold ~init ~f module_ -let translate_one_function source names_env cfg line function_ clauses = +let ( |~~> ) from to_ = Procdesc.set_succs from ~normal:(Some to_) ~exn:None + +(** Assumes that the values on which patterns should be matched have been loaded into the + identifiers listed in [values]. *) +let translate_case_clause env (_values : Ident.t list) {Ast.line; patterns= _; guards= _; body= _} : + block = + (* TODO: This is just a dummy implementation. *) + let loc = {Location.line; col= -1; file= env.source} in + let procdesc = Option.value_exn env.procdesc in + let create_node kind = Procdesc.create_node procdesc loc kind [] in + let create_stmt_node () = create_node (Stmt_node CaseStmt) in + let create_prune_node branch = + let kind : Procdesc.Node.prune_node_kind = + if branch then PruneNodeKind_TrueBranch else PruneNodeKind_FalseBranch + in + create_node (Prune_node (branch, Ik_switch, kind)) + in + let start = create_stmt_node () in + let prune_true = create_prune_node true in + let prune_false = create_prune_node false in + let exit_success = create_stmt_node () in + let exit_failure = create_stmt_node () in + let value = Ident.create_fresh Ident.knormal in + start |~~> [prune_true; prune_false] ; + prune_true |~~> [exit_success] ; + prune_false |~~> [exit_failure] ; + {start; exit_success; exit_failure; value} + + +let translate_one_function env cfg line function_ clauses = let uf_name = UnqualifiedFunction.of_ast function_ in let {UnqualifiedFunction.name= function_name; arity} = uf_name in let name = - let module_name = names_env.current_module in + let module_name = env.current_module in Procname.make_erlang ~module_name ~function_name ~arity in + let any = typ_of_name Any in let attributes = - let default = ProcAttributes.default source name in - let access : ProcAttributes.access = - if Set.mem names_env.exports uf_name then Public else Private + let default = ProcAttributes.default env.source name in + let access : ProcAttributes.access = if Set.mem env.exports uf_name then Public else Private in + let formals = List.init ~f:(fun i -> (mangled_arg i, any)) arity in + let loc = {Location.line; col= -1; file= env.source} in + {default with access; formals; loc; ret_type= any} + in + let procdesc = Cfg.create_proc_desc cfg attributes in + let env = {env with procdesc= Some procdesc} in + let idents, loads = + let load (formal, typ) = + let id = Ident.create_fresh Ident.knormal in + let pvar = Pvar.mk formal name in + let load = Sil.Load {id; e= Exp.Lvar pvar; root_typ= typ; typ; loc= attributes.loc} in + (id, load) + in + List.unzip (List.map ~f:load attributes.formals) + in + let blocks = List.map ~f:(translate_case_clause env idents) clauses in + let fail_node = + (* Add a node that loads all values on which we pattern-match into idents. *) + let loads_node = Procdesc.create_node procdesc attributes.loc (Stmt_node CaseStmt) loads in + Procdesc.get_start_node procdesc |~~> [loads_node] ; + (* Connect exit_failure of one case_clause to the start of the next case_clause. *) + let f previous {start; exit_failure; _} = + previous |~~> [start] ; + exit_failure + in + List.fold ~init:loads_node ~f blocks + in + let () = + (* If all patterns fail, call BuiltinDecl.__erlang_pattern_fail *) + let crash_instruction = + let ret_var = Ident.create_fresh Ident.knormal (* not used: nothing returned *) in + let pattern_fail_fun = Exp.Const (Cfun BuiltinDecl.__erlang_pattern_fail) in + Sil.Call ((ret_var, any), pattern_fail_fun, [], attributes.loc, CallFlags.default) + in + let crash_node = + Procdesc.create_node procdesc attributes.loc Procdesc.Node.throw_kind [crash_instruction] in - let formals = List.init ~f:(fun i -> (mangled_arg i, typ_of_name Any)) arity in - let loc = {Location.line; col= -1; file= source} in - let ret_type = typ_of_name Any in - {default with access; formals; loc; ret_type} + fail_node |~~> [crash_node] ; + crash_node |~~> [Procdesc.get_exit_node procdesc] in - let _proc = Cfg.create_proc_desc cfg attributes in - (* TODO: add nodes to proc *) - if List.is_empty clauses then - L.die InternalError "%s:%a has no clauses" names_env.current_module Procname.pp name + let () = + (* Copy result of each case into return value, and go to exit node. *) + let ret_exp = Exp.Lvar (Pvar.get_ret_pvar name) in + let f {exit_success; value; _} = + let copy_instruction = + Sil.Store {e1= ret_exp; root_typ= any; typ= any; e2= Exp.Var value; loc= attributes.loc} + in + let copy_node = + Procdesc.create_node procdesc attributes.loc (Stmt_node ReturnStmt) [copy_instruction] + in + exit_success |~~> [copy_node] ; + copy_node |~~> [Procdesc.get_exit_node procdesc] + in + List.iter ~f blocks + in + () -let translate_functions source names_env cfg module_ = +let translate_functions env cfg module_ = let f (form : Ast.form) = match form.simple_form with | Function {function_; clauses} -> - translate_one_function source names_env cfg form.line function_ clauses + translate_one_function env cfg form.line function_ clauses | _ -> () in List.iter module_ ~f ; - DB.Results_dir.init source ; - Cfg.store source cfg ; - SourceFiles.add source cfg Tenv.Global None - - -let to_source_and_cfg module_ = - let source = - let extract_path = function - | {Ast.line= _; simple_form= File {path}} -> - Some path - | _ -> - None - in - match List.find_map ~f:extract_path module_ with - | None -> - SourceFile.invalid __FILE__ - | Some path -> - SourceFile.create path - in - let cfg = - let cfg = Cfg.create () in - let names_env = get_environment module_ in - translate_functions source names_env cfg module_ ; - cfg - in - (source, cfg) + DB.Results_dir.init env.source ; + Cfg.store env.source cfg ; + SourceFiles.add env.source cfg Tenv.Global None + + +let translate_module module_ = + let cfg = Cfg.create () in + let env = get_environment module_ in + translate_functions env cfg module_ diff --git a/infer/src/erlang/ErlangTranslator.mli b/infer/src/erlang/ErlangTranslator.mli index 515767014..b34b09a19 100644 --- a/infer/src/erlang/ErlangTranslator.mli +++ b/infer/src/erlang/ErlangTranslator.mli @@ -7,4 +7,4 @@ open! IStd -val to_source_and_cfg : ErlangAst.module_ -> SourceFile.t * Cfg.t +val translate_module : ErlangAst.module_ -> unit diff --git a/infer/src/integration/Rebar3.ml b/infer/src/integration/Rebar3.ml index 91b64f98c..d2bd0f489 100644 --- a/infer/src/integration/Rebar3.ml +++ b/infer/src/integration/Rebar3.ml @@ -20,9 +20,7 @@ let parse_and_store result_dir = | None -> false | Some ast -> - let source_file, cfg = ErlangTranslator.to_source_and_cfg ast in - let tenv = (* TODO: types *) Tenv.Global in - SourceFiles.add source_file cfg tenv None ; + ErlangTranslator.translate_module ast ; true in let log error = L.progress "E: %s@." error in