(**************************************************************************) (* *) (* OCaml *) (* *) (* Pierre Chambart, OCamlPro *) (* Mark Shinwell and Leo White, Jane Street Europe *) (* *) (* Copyright 2013--2016 OCamlPro SAS *) (* Copyright 2014--2016 Jane Street Group LLC *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) [@@@ocaml.warning "+a-4-9-30-40-41-42"] module Env = Closure_conversion_aux.Env module Function_decls = Closure_conversion_aux.Function_decls module Function_decl = Function_decls.Function_decl module IdentSet = Lambda.IdentSet let name_expr = Flambda_utils.name_expr type t = { current_unit_id : Ident.t; symbol_for_global' : (Ident.t -> Symbol.t); filename : string; mutable imported_symbols : Symbol.Set.t; } let add_default_argument_wrappers lam = (* CR-someday mshinwell: Temporary hack to mark default argument wrappers as stubs. Other possibilities: 1. Change Lambda.inline_attribute to add another ("stub") case; 2. Add a "stub" field to the Lfunction record. *) let stubify body : Lambda.lambda = let stub_prim = Primitive.simple ~name:Closure_conversion_aux.stub_hack_prim_name ~arity:1 ~alloc:false in Lprim (Pccall stub_prim, [body]) in let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs in let f (lam : Lambda.lambda) : Lambda.lambda = match lam with | Llet (( Strict | Alias | StrictOpt), _k, id, Lfunction {kind; params; body = fbody; attr}, body) -> begin match Simplif.split_default_wrapper id kind params fbody attr ~create_wrapper_body:stubify with | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body) | [fun_id, def; inner_fun_id, def_inner] -> Llet (Alias, Pgenval, inner_fun_id, def_inner, Llet (Alias, Pgenval, fun_id, def, body)) | _ -> assert false end | Lletrec (defs, body) as lam -> if defs_are_all_functions defs then let defs = List.flatten (List.map (function | (id, Lambda.Lfunction {kind; params; body; attr}) -> Simplif.split_default_wrapper id kind params body attr ~create_wrapper_body:stubify | _ -> assert false) defs) in Lletrec (defs, body) else lam | lam -> lam in Lambda.map f lam (** Generate a wrapper ("stub") function that accepts a tuple argument and calls another function with arguments extracted in the obvious manner from the tuple. *) let tupled_function_call_stub original_params unboxed_version : Flambda.function_declaration = let tuple_param = Variable.rename ~append:"tupled_stub_param" unboxed_version in let params = List.map (fun p -> Variable.rename p) original_params in let call : Flambda.t = Apply ({ func = unboxed_version; args = params; (* CR-someday mshinwell for mshinwell: investigate if there is some redundancy here (func is also unboxed_version) *) kind = Direct (Closure_id.wrap unboxed_version); dbg = Debuginfo.none; inline = Default_inline; specialise = Default_specialise; }) in let _, body = List.fold_left (fun (pos, body) param -> let lam : Flambda.named = Prim (Pfield pos, [tuple_param], Debuginfo.none) in pos + 1, Flambda.create_let param lam body) (0, call) params in Flambda.create_function_declaration ~params:[tuple_param] ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline ~specialise:Default_specialise ~is_a_functor:false let rec eliminate_const_block (const : Lambda.structured_constant) : Lambda.lambda = match const with | Const_block (tag, consts) -> Lprim (Pmakeblock (tag, Asttypes.Immutable, None), List.map eliminate_const_block consts) | Const_base _ | Const_pointer _ | Const_immstring _ | Const_float_array _ -> Lconst const let default_debuginfo ?(inner_debuginfo = Debuginfo.none) env_debuginfo = match env_debuginfo with | None -> inner_debuginfo | Some debuginfo -> debuginfo let rec close_const t env (const : Lambda.structured_constant) : Flambda.named * string = match const with | Const_base (Const_int c) -> Const (Int c), "int" | Const_base (Const_char c) -> Const (Char c), "char" | Const_base (Const_string (s, _)) -> Allocated_const (String s), "string" | Const_base (Const_float c) -> Allocated_const (Float (float_of_string c)), "float" | Const_base (Const_int32 c) -> Allocated_const (Int32 c), "int32" | Const_base (Const_int64 c) -> Allocated_const (Int64 c), "int64" | Const_base (Const_nativeint c) -> Allocated_const (Nativeint c), "nativeint" | Const_pointer c -> Const (Const_pointer c), "pointer" | Const_immstring c -> Allocated_const (Immutable_string c), "immstring" | Const_float_array c -> Allocated_const (Immutable_float_array (List.map float_of_string c)), "float_array" | Const_block _ -> Expr (close t env (eliminate_const_block const)), "const_block" and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = match lam with | Lvar id -> begin match Env.find_var_exn env id with | var -> Var var | exception Not_found -> match Env.find_mutable_var_exn env id with | mut_var -> name_expr (Read_mutable mut_var) ~name:"read_mutable" | exception Not_found -> Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" Ident.print id end | Lconst cst -> let cst, name = close_const t env cst in name_expr cst ~name:("const_" ^ name) | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> (* TODO: keep value_kind in flambda *) let var = Variable.create_with_same_name_as_ident id in let defining_expr = close_let_bound_expression t var env defining_expr in let body = close t (Env.add_var env id var) body in Flambda.create_let var defining_expr body | Llet (Variable, block_kind, id, defining_expr, body) -> let mut_var = Mutable_variable.of_ident id in let var = Variable.create_with_same_name_as_ident id in let defining_expr = close_let_bound_expression t var env defining_expr in let body = close t (Env.add_mutable_var env id mut_var) body in Flambda.create_let var defining_expr (Let_mutable { var = mut_var; initial_value = var; body; contents_kind = block_kind }) | Lfunction { kind; params; body; attr; } -> let name = (* Name anonymous functions by their source location, if known. *) match body with | Levent (_, { lev_loc }) -> Format.asprintf "anon-fn[%a]" Location.print_compact lev_loc | _ -> "anon-fn" in let closure_bound_var = Variable.create name in (* CR-soon mshinwell: some of this is now very similar to the let rec case below *) let set_of_closures_var = Variable.create ("set_of_closures_" ^ name) in let set_of_closures = let decl = Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind ~params ~body ~inline:attr.inline ~specialise:attr.specialise ~is_a_functor:attr.is_a_functor in close_functions t env (Function_decls.create [decl]) in let project_closure : Flambda.project_closure = { set_of_closures = set_of_closures_var; closure_id = Closure_id.wrap closure_bound_var; } in Flambda.create_let set_of_closures_var set_of_closures (name_expr (Project_closure (project_closure)) ~name:("project_closure_" ^ name)) | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _; ap_inlined; ap_specialised; } -> Lift_code.lifting_helper (close_list t env ap_args) ~evaluation_order:`Right_to_left ~name:"apply_arg" ~create_body:(fun args -> let func = close t env ap_func in let func_var = Variable.create "apply_funct" in Flambda.create_let func_var (Expr func) (Apply ({ func = func_var; args; kind = Indirect; dbg = default_debuginfo ~inner_debuginfo:(Debuginfo.from_location Dinfo_call ap_loc) debuginfo; inline = ap_inlined; specialise = ap_specialised; }))) | Lletrec (defs, body) -> let env = List.fold_right (fun (id, _) env -> Env.add_var env id (Variable.create_with_same_name_as_ident id)) defs env in let function_declarations = (* Identify any bindings in the [let rec] that are functions. These will be named after the corresponding identifier in the [let rec]. *) List.map (function | (let_rec_ident, Lambda.Lfunction { kind; params; body; attr; }) -> let closure_bound_var = Variable.create_with_same_name_as_ident let_rec_ident in let function_declaration = Function_decl.create ~let_rec_ident:(Some let_rec_ident) ~closure_bound_var ~kind ~params ~body ~inline:attr.inline ~specialise:attr.specialise ~is_a_functor:attr.is_a_functor in Some function_declaration | _ -> None) defs in begin match Misc.Stdlib.List.some_if_all_elements_are_some function_declarations with | Some function_declarations -> (* When all the bindings are (syntactically) functions, we can eliminate the [let rec] construction, instead producing a normal [Let] that binds a set of closures containing all of the functions. *) (* CR-someday lwhite: This is a very syntactic criteria. Adding an unused value to a set of recursive bindings changes how functions are represented at runtime. *) let name = (* The Microsoft assembler has a 247-character limit on symbol names, so we keep them shorter to try not to hit this. *) if Sys.win32 then begin match defs with | (id, _)::_ -> (Ident.unique_name id) ^ "_let_rec" | _ -> "let_rec" end else begin String.concat "_and_" (List.map (fun (id, _) -> Ident.unique_name id) defs) end in let set_of_closures_var = Variable.create name in let set_of_closures = close_functions t env (Function_decls.create function_declarations) in let body = List.fold_left (fun body decl -> let let_rec_ident = Function_decl.let_rec_ident decl in let closure_bound_var = Function_decl.closure_bound_var decl in let let_bound_var = Env.find_var env let_rec_ident in (* Inside the body of the [let], each function is referred to by a [Project_closure] expression, which projects from the set of closures. *) (Flambda.create_let let_bound_var (Project_closure { set_of_closures = set_of_closures_var; closure_id = Closure_id.wrap closure_bound_var; }) body)) (close t env body) function_declarations in Flambda.create_let set_of_closures_var set_of_closures body | None -> (* If the condition above is not satisfied, we build a [Let_rec] expression; any functions bound by it will have their own individual closures. *) let defs = List.map (fun (id, def) -> let var = Env.find_var env id in var, close_let_bound_expression t ~let_rec_ident:id var env def) defs in Let_rec (defs, close t env body) end | Lsend (kind, meth, obj, args, loc) -> let meth_var = Variable.create "meth" in let obj_var = Variable.create "obj" in let dbg = Debuginfo.from_location Dinfo_call loc in Flambda.create_let meth_var (Expr (close t env meth)) (Flambda.create_let obj_var (Expr (close t env obj)) (Lift_code.lifting_helper (close_list t env args) ~evaluation_order:`Right_to_left ~name:"send_arg" ~create_body:(fun args -> Send { kind; meth = meth_var; obj = obj_var; args; dbg; }))) | Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2]) when not !Clflags.fast -> (* not -unsafe *) let arg2 = close t env arg2 in let arg1 = close t env arg1 in let numerator = Variable.create "numerator" in let denominator = Variable.create "denominator" in let zero = Variable.create "zero" in let is_zero = Variable.create "is_zero" in let exn = Variable.create "division_by_zero" in let exn_symbol = t.symbol_for_global' Predef.ident_division_by_zero in t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; Flambda.create_let zero (Const (Int 0)) (Flambda.create_let exn (Symbol exn_symbol) (Flambda.create_let denominator (Expr arg2) (Flambda.create_let numerator (Expr arg1) (Flambda.create_let is_zero (Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none)) (If_then_else (is_zero, name_expr (Prim (Praise Raise_regular, [exn], default_debuginfo debuginfo)) ~name:"dummy", (* CR-someday pchambart: find the right event. mshinwell: I briefly looked at this, and couldn't figure it out. lwhite: I don't think any of the existing events are suitable. I had to add a new one for a similar case in the array data types work. mshinwell: deferred CR *) (* Debuginfo.from_raise event *) name_expr ~name:"result" (Prim (prim, [numerator; denominator], Debuginfo.none)))))))) | Lprim ((Pdivint | Pmodint), _) when not !Clflags.fast -> Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" | Lprim (Psequor, [arg1; arg2]) -> let arg1 = close t env arg1 in let arg2 = close t env arg2 in let const_true = Variable.create "const_true" in let cond = Variable.create "cond_sequor" in Flambda.create_let const_true (Const (Int 1)) (Flambda.create_let cond (Expr arg1) (If_then_else (cond, Var const_true, arg2))) | Lprim (Psequand, [arg1; arg2]) -> let arg1 = close t env arg1 in let arg2 = close t env arg2 in let const_false = Variable.create "const_false" in let cond = Variable.create "cond_sequand" in Flambda.create_let const_false (Const (Int 0)) (Flambda.create_let cond (Expr arg1) (If_then_else (cond, arg2, Var const_false))) | Lprim ((Psequand | Psequor), _) -> Misc.fatal_error "Psequand / Psequor must have exactly two arguments" | Lprim (Pidentity, [arg]) -> close t env arg | Lprim (Pdirapply loc, [funct; arg]) | Lprim (Prevapply loc, [arg; funct]) -> let apply : Lambda.lambda_apply = { ap_func = funct; ap_args = [arg]; ap_loc = loc; ap_should_be_tailcall = false; (* CR-someday lwhite: it would be nice to be able to give inlined attributes to functions applied with the application operators. *) ap_inlined = Default_inline; ap_specialised = Default_specialise; } in close t env ?debuginfo (Lambda.Lapply apply) | Lprim (Praise kind, [Levent (arg, event)]) -> let arg_var = Variable.create "raise_arg" in Flambda.create_let arg_var (Expr (close t env arg)) (name_expr (Prim (Praise kind, [arg_var], default_debuginfo ~inner_debuginfo:(Debuginfo.from_raise event) debuginfo)) ~name:"raise") | Lprim (Pfield _, [Lprim (Pgetglobal id, [])]) when Ident.same id t.current_unit_id -> Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ unit is forbidden upon entry to the middle end" | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, []); _]) -> Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ forbidden upon entry to the middle end" | Lprim (Pgetglobal id, []) when Ident.is_predef_exn id -> let symbol = t.symbol_for_global' id in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:"predef_exn" | Lprim (Pgetglobal id, []) -> assert (not (Ident.same id t.current_unit_id)); let symbol = t.symbol_for_global' id in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:"Pgetglobal" | Lprim (p, args) -> (* One of the important consequences of the ANF-like representation here is that we obtain names corresponding to the components of blocks being made (with [Pmakeblock]). This information can be used by the simplification pass to increase the likelihood of eliminating the allocation, since some field accesses can be tracked back to known field values. ,*) let name = Printlambda.name_of_primitive p in Lift_code.lifting_helper (close_list t env args) ~evaluation_order:`Right_to_left ~name:(name ^ "_arg") ~create_body:(fun args -> let inner_debuginfo = Debuginfo.from_filename Debuginfo.Dinfo_call t.filename in name_expr (Prim (p, args, default_debuginfo debuginfo ~inner_debuginfo)) ~name) | Lswitch (arg, sw) -> let scrutinee = Variable.create "switch" in let aux (i, lam) = i, close t env lam in let zero_to_n = Numbers.Int.zero_to_n in Flambda.create_let scrutinee (Expr (close t env arg)) (Switch (scrutinee, { numconsts = zero_to_n (sw.sw_numconsts - 1); consts = List.map aux sw.sw_consts; numblocks = zero_to_n (sw.sw_numblocks - 1); blocks = List.map aux sw.sw_blocks; failaction = Misc.may_map (close t env) sw.sw_failaction; })) | Lstringswitch (arg, sw, def) -> let scrutinee = Variable.create "string_switch" in Flambda.create_let scrutinee (Expr (close t env arg)) (String_switch (scrutinee, List.map (fun (s, e) -> s, close t env e) sw, Misc.may_map (close t env) def)) | Lstaticraise (i, args) -> Lift_code.lifting_helper (close_list t env args) ~evaluation_order:`Right_to_left ~name:"staticraise_arg" ~create_body:(fun args -> let static_exn = Env.find_static_exception env i in Static_raise (static_exn, args)) | Lstaticcatch (body, (i, ids), handler) -> let st_exn = Static_exception.create () in let env = Env.add_static_exception env i st_exn in let vars = List.map (Variable.create_with_same_name_as_ident) ids in Static_catch (st_exn, vars, close t env body, close t (Env.add_vars env ids vars) handler) | Ltrywith (body, id, handler) -> let var = Variable.create_with_same_name_as_ident id in Try_with (close t env body, var, close t (Env.add_var env id var) handler) | Lifthenelse (cond, ifso, ifnot) -> let cond = close t env cond in let cond_var = Variable.create "cond" in Flambda.create_let cond_var (Expr cond) (If_then_else (cond_var, close t env ifso, close t env ifnot)) | Lsequence (lam1, lam2) -> let var = Variable.create "sequence" in let lam1 = Flambda.Expr (close t env lam1) in let lam2 = close t env lam2 in Flambda.create_let var lam1 lam2 | Lwhile (cond, body) -> While (close t env cond, close t env body) | Lfor (id, lo, hi, direction, body) -> let bound_var = Variable.create_with_same_name_as_ident id in let from_value = Variable.create "for_from" in let to_value = Variable.create "for_to" in let body = close t (Env.add_var env id bound_var) body in Flambda.create_let from_value (Expr (close t env lo)) (Flambda.create_let to_value (Expr (close t env hi)) (For { bound_var; from_value; to_value; direction; body; })) | Lassign (id, new_value) -> let being_assigned = match Env.find_mutable_var_exn env id with | being_assigned -> being_assigned | exception Not_found -> Misc.fatal_errorf "Closure_conversion.close: unbound mutable \ variable %s in assignment" (Ident.unique_name id) in let new_value_var = Variable.create "new_value" in Flambda.create_let new_value_var (Expr (close t env new_value)) (Assign { being_assigned; new_value = new_value_var; }) | Levent (lam, ev) -> begin match ev.lev_kind with | Lev_after _ -> close t env ~debuginfo:(Debuginfo.from_call ev) lam | _ -> close t env lam end | Lifused _ -> (* [Lifused] is used to mark that this expression should be alive only if an identifier is. Every use should have been removed by [Simplif.simplify_lets], either by replacing by the inner expression, or by completely removing it (replacing by unit). *) Misc.fatal_error "[Lifused] should have been removed by \ [Simplif.simplify_lets]" (** Perform closure conversion on a set of function declarations, returning a set of closures. (The set will often only contain a single function; the only case where it cannot is for "let rec".) *) and close_functions t external_env function_declarations : Flambda.named = let closure_env_without_parameters = Function_decls.closure_env_without_parameters external_env function_declarations in let all_free_idents = Function_decls.all_free_idents function_declarations in let close_one_function map decl = let body = Function_decl.body decl in let dbg = (* Move any debugging event that may exist at the start of the function body onto the function declaration itself. *) match body with | Levent (_, ({ lev_kind = Lev_function } as ev)) -> Debuginfo.from_call ev | _ -> Debuginfo.none in let params = Function_decl.params decl in (* Create fresh variables for the elements of the closure (cf. the comment on [Function_decl.closure_env_without_parameters], above). This induces a renaming on [Function_decl.free_idents]; the results of that renaming are stored in [free_variables]. *) let closure_env = List.fold_right (fun id env -> Env.add_var env id (Variable.create_with_same_name_as_ident id)) params closure_env_without_parameters in (* If the function is the wrapper for a function with an optional argument with a default value, make sure it always gets inlined. CR-someday pchambart: eta-expansion wrapper for a primitive are not marked as stub but certainly should *) let stub, body = match Function_decl.primitive_wrapper decl with | None -> false, body | Some wrapper_body -> true, wrapper_body in let params = List.map (Env.find_var closure_env) params in let closure_bound_var = Function_decl.closure_bound_var decl in let body = close t closure_env body in let fun_decl = Flambda.create_function_declaration ~params ~body ~stub ~dbg ~inline:(Function_decl.inline decl) ~specialise:(Function_decl.specialise decl) ~is_a_functor:(Function_decl.is_a_functor decl) in match Function_decl.kind decl with | Curried -> Variable.Map.add closure_bound_var fun_decl map | Tupled -> let unboxed_version = Variable.rename closure_bound_var in let generic_function_stub = tupled_function_call_stub params unboxed_version in Variable.Map.add unboxed_version fun_decl (Variable.Map.add closure_bound_var generic_function_stub map) in let function_decls = Flambda.create_function_declarations ~funs: (List.fold_left close_one_function Variable.Map.empty (Function_decls.to_list function_declarations)) in (* The closed representation of a set of functions is a "set of closures". (For avoidance of doubt, the runtime representation of the *whole set* is a single block with tag [Closure_tag].) *) let set_of_closures = let free_vars = IdentSet.fold (fun var map -> let internal_var = Env.find_var closure_env_without_parameters var in let external_var : Flambda.specialised_to = { var = Env.find_var external_env var; projection = None; } in Variable.Map.add internal_var external_var map) all_free_idents Variable.Map.empty in Flambda.create_set_of_closures ~function_decls ~free_vars ~specialised_args:Variable.Map.empty ~direct_call_surrogates:Variable.Map.empty in Set_of_closures set_of_closures and close_list t sb l = List.map (close t sb) l and close_let_bound_expression t ?let_rec_ident let_bound_var env (lam : Lambda.lambda) : Flambda.named = match lam with | Lfunction { kind; params; body; attr; } -> (* Ensure that [let] and [let rec]-bound functions have appropriate names. *) let closure_bound_var = Variable.rename let_bound_var in let decl = Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline:attr.inline ~specialise:attr.specialise ~is_a_functor:attr.is_a_functor in let set_of_closures_var = Variable.rename let_bound_var ~append:"_set_of_closures" in let set_of_closures = close_functions t env (Function_decls.create [decl]) in let project_closure : Flambda.project_closure = { set_of_closures = set_of_closures_var; closure_id = Closure_id.wrap closure_bound_var; } in Expr (Flambda.create_let set_of_closures_var set_of_closures (name_expr (Project_closure (project_closure)) ~name:(Variable.unique_name let_bound_var))) | lam -> Expr (close t env lam) let lambda_to_flambda ~backend ~module_ident ~size ~filename lam : Flambda.program = let lam = add_default_argument_wrappers lam in let module Backend = (val backend : Backend_intf.S) in let compilation_unit = Compilation_unit.get_current_exn () in let t = { current_unit_id = Compilation_unit.get_persistent_ident compilation_unit; symbol_for_global' = Backend.symbol_for_global'; filename; imported_symbols = Symbol.Set.empty; } in let module_symbol = Backend.symbol_for_global' module_ident in let block_symbol = let linkage_name = Linkage_name.create "module_as_block" in Symbol.create compilation_unit linkage_name in (* The global module block is built by accessing the fields of all the introduced symbols. *) (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are compiled. *) let fields = Array.init size (fun pos -> let pos_str = string_of_int pos in let sym_v = Variable.create ("block_symbol_" ^ pos_str) in let result_v = Variable.create ("block_symbol_get_" ^ pos_str) in let value_v = Variable.create ("block_symbol_get_field_" ^ pos_str) in Flambda.create_let sym_v (Symbol block_symbol) (Flambda.create_let result_v (Prim (Pfield 0, [sym_v], Debuginfo.none)) (Flambda.create_let value_v (Prim (Pfield pos, [result_v], Debuginfo.none)) (Var value_v)))) in let module_initializer : Flambda.program_body = Initialize_symbol ( block_symbol, Tag.create_exn 0, [close t Env.empty lam], Initialize_symbol ( module_symbol, Tag.create_exn 0, Array.to_list fields, End module_symbol)) in { imported_symbols = t.imported_symbols; program_body = module_initializer; }