From 643da006559e10b8b29669b74fb59b989fc3fb28 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 15 Nov 2019 15:11:14 +0000 Subject: [PATCH 01/80] Split code from closures --- flambdatest/mlexamples/tests0.ml | 12 + middle_end/flambda2.0/basic/code_id.ml | 21 +- middle_end/flambda2.0/basic/code_id.mli | 10 +- middle_end/flambda2.0/basic/id_types.ml | 12 +- middle_end/flambda2.0/basic/id_types.mli | 3 +- .../from_lambda/closure_conversion.ml | 97 +- .../flambda2.0/inlining/inlining_cost.ml | 49 +- .../flambda2.0/inlining/inlining_cost.mli | 9 +- .../flambda2.0/inlining/inlining_decision.ml | 7 +- .../inlining/inlining_transforms.ml | 7 +- .../inlining/inlining_transforms.mli | 2 +- .../flambda2.0/naming/name_occurrences.ml | 81 +- .../flambda2.0/naming/name_occurrences.mli | 14 + .../flambda2.0/parser/fexpr_to_flambda.ml | 34 +- .../simplify/env/simplify_env_and_result.ml | 100 +- .../env/simplify_env_and_result_intf.ml | 22 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 168 ++-- .../flambda2.0/simplify/simplify_import.ml | 1 + .../flambda2.0/simplify/simplify_import.mli | 1 + .../flambda2.0/simplify/simplify_named.rec.ml | 192 +++- .../simplify/simplify_named.rec.mli | 37 +- .../simplify/simplify_static.rec.ml | 167 +++- .../simplify/typing_helpers/reification.ml | 1 - middle_end/flambda2.0/terms/apply_expr.ml | 2 +- middle_end/flambda2.0/terms/call_kind.ml | 32 +- middle_end/flambda2.0/terms/call_kind.mli | 15 +- middle_end/flambda2.0/terms/dune | 6 - middle_end/flambda2.0/terms/flambda.mli | 123 +-- middle_end/flambda2.0/terms/flambda_static.ml | 311 +++++-- .../flambda2.0/terms/flambda_static.mli | 73 +- .../flambda2.0/terms/function_declaration.ml | 135 +++ ...ation.rec.mli => function_declaration.mli} | 19 +- .../terms/function_declaration.rec.ml | 188 ---- ...ations.rec.ml => function_declarations.ml} | 6 +- ...ions.rec.mli => function_declarations.mli} | 0 .../terms/function_params_and_body.rec.ml | 29 +- middle_end/flambda2.0/terms/rec_modules | 3 - ..._of_closures.rec.ml => set_of_closures.ml} | 2 +- ...f_closures.rec.mli => set_of_closures.mli} | 0 .../terms/template/flambda.templ.ml | 6 +- middle_end/flambda2.0/to_cmm/un_cps.ml | 23 +- .../flambda2.0/to_cmm/un_cps_closure.ml | 8 +- .../flambda2.0/types/basic/or_unknown.mli | 16 + .../types/basic/or_unknown_or_bottom.ml | 5 + .../types/basic/or_unknown_or_bottom.mli | 2 + .../term_language_function_declaration.ml | 4 + middle_end/flambda2.0/types/dune | 8 +- .../flambda2.0/types/env/typing_env.rec.ml | 15 +- .../flambda2.0/types/env/typing_env.rec.mli | 4 + .../types/env/typing_env_extension.rec.ml | 5 + .../types/env/typing_env_extension.rec.mli | 2 + middle_end/flambda2.0/types/flambda_type.ml | 21 - middle_end/flambda2.0/types/flambda_type.mli | 485 +++++++++- middle_end/flambda2.0/types/flambda_type0.mli | 24 - .../types/structures/closures_entry.rec.ml | 237 ++--- .../types/structures/closures_entry.rec.mli | 4 +- .../types/structures/code_age_relation.ml | 91 ++ .../types/structures/code_age_relation.mli | 39 + .../function_declaration_type.rec.ml | 311 ++++++- .../function_declaration_type.rec.mli | 68 +- .../types/structures/product.rec.ml | 2 + .../types/structures/product_intf.ml | 3 +- .../types/template/flambda_type.templ.ml | 880 ++++++++++++++++++ .../types/template/flambda_type0.templ.ml | 880 ------------------ .../flambda2.0/types/type_grammar.rec.ml | 36 +- .../flambda2.0/types/type_grammar.rec.mli | 14 +- .../type_of_kind/type_of_kind_value0.rec.ml | 12 +- .../flambda2.0/types/type_system_intf.ml | 477 ---------- .../unboxing/unbox_continuation_params.ml | 9 +- 69 files changed, 3307 insertions(+), 2375 deletions(-) create mode 100644 flambdatest/mlexamples/tests0.ml create mode 100644 middle_end/flambda2.0/terms/function_declaration.ml rename middle_end/flambda2.0/terms/{function_declaration.rec.mli => function_declaration.mli} (82%) delete mode 100644 middle_end/flambda2.0/terms/function_declaration.rec.ml rename middle_end/flambda2.0/terms/{function_declarations.rec.ml => function_declarations.ml} (96%) rename middle_end/flambda2.0/terms/{function_declarations.rec.mli => function_declarations.mli} (100%) rename middle_end/flambda2.0/terms/{set_of_closures.rec.ml => set_of_closures.ml} (98%) rename middle_end/flambda2.0/terms/{set_of_closures.rec.mli => set_of_closures.mli} (100%) delete mode 100644 middle_end/flambda2.0/types/flambda_type.ml delete mode 100644 middle_end/flambda2.0/types/flambda_type0.mli create mode 100644 middle_end/flambda2.0/types/structures/code_age_relation.ml create mode 100644 middle_end/flambda2.0/types/structures/code_age_relation.mli create mode 100644 middle_end/flambda2.0/types/template/flambda_type.templ.ml delete mode 100644 middle_end/flambda2.0/types/template/flambda_type0.templ.ml delete mode 100644 middle_end/flambda2.0/types/type_system_intf.ml diff --git a/flambdatest/mlexamples/tests0.ml b/flambdatest/mlexamples/tests0.ml new file mode 100644 index 000000000000..6b3360535183 --- /dev/null +++ b/flambdatest/mlexamples/tests0.ml @@ -0,0 +1,12 @@ +type t = + | A + | B of int + | C of int + +let f () = + let x = A in + match x with + | A -> 0 + | B _ -> 1 + | C _ -> 2 + diff --git a/middle_end/flambda2.0/basic/code_id.ml b/middle_end/flambda2.0/basic/code_id.ml index 30b82acb4c9b..0a480aec8019 100644 --- a/middle_end/flambda2.0/basic/code_id.ml +++ b/middle_end/flambda2.0/basic/code_id.ml @@ -23,9 +23,26 @@ type t = Unit_id.t include Identifiable.Make (Unit_id) -let create = Unit_id.create +let create ~name comp_unit = Unit_id.create ~name comp_unit let get_compilation_unit = Unit_id.unit -let name = Unit_id.name + +let name t = + (* CR mshinwell: Id_types needs fixing to avoid this *) + match Unit_id.name t with + | Some name -> name + | None -> assert false + +let rename = Unit_id.rename let in_compilation_unit t cu = Compilation_unit.equal (get_compilation_unit t) cu + +let code_symbol t = + let linkage_name = Linkage_name.create (name t ^ "_code") in + Symbol.create (get_compilation_unit t) linkage_name + +let invert_map map = + Map.fold (fun older newer invert_map -> + Map.add newer older invert_map) + map + Map.empty diff --git a/middle_end/flambda2.0/basic/code_id.mli b/middle_end/flambda2.0/basic/code_id.mli index 3306bcc757aa..aa0bd9ad829e 100644 --- a/middle_end/flambda2.0/basic/code_id.mli +++ b/middle_end/flambda2.0/basic/code_id.mli @@ -18,7 +18,13 @@ include Identifiable.S -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option +val create : name:string -> Compilation_unit.t -> t +val name : t -> string val get_compilation_unit : t -> Compilation_unit.t val in_compilation_unit : t -> Compilation_unit.t -> bool +val rename : t -> t + +(** [Code_id]s uniquely determine function symbols. *) +val code_symbol : t -> Symbol.t + +val invert_map : t Map.t -> t Map.t diff --git a/middle_end/flambda2.0/basic/id_types.ml b/middle_end/flambda2.0/basic/id_types.ml index c9a3e711527b..17c97c48af69 100644 --- a/middle_end/flambda2.0/basic/id_types.ml +++ b/middle_end/flambda2.0/basic/id_types.ml @@ -26,6 +26,7 @@ module type BaseId = sig val to_string : t -> string val output : out_channel -> t -> unit val print : Format.formatter -> t -> unit + val rename : t -> t end module type Id = sig @@ -43,8 +44,9 @@ end module Id(_:sig end) : Id = struct type t = int * string let empty_string = "" - let create = let r = ref 0 in - fun ?(name=empty_string) () -> incr r; !r, name + let r = ref 0 + let create ?(name=empty_string) () = incr r; !r, name + let rename (_stamp, name) = create ~name () let equal (t1,_) (t2,_) = (t1:int) = t2 let compare (t1,_) (t2,_) = t1 - t2 let hash (t,_) = t @@ -82,6 +84,12 @@ module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : let hash off = Hashtbl.hash off let equal o1 o2 = compare o1 o2 = 0 let name o = Innerid.name o.id + + let rename t = + { id = Innerid.rename t.id; + unit = t.unit; + } + let to_string x = Format.asprintf "%a.%a" Compilation_unit.print x.unit diff --git a/middle_end/flambda2.0/basic/id_types.mli b/middle_end/flambda2.0/basic/id_types.mli index d9bc7a6aea09..29c8ee845bb4 100644 --- a/middle_end/flambda2.0/basic/id_types.mli +++ b/middle_end/flambda2.0/basic/id_types.mli @@ -16,7 +16,7 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] -(* CR-soon mshinwell: This module should be removed. *) +(* CR-soon mshinwell: This module should be removed... maybe? *) (** Generic identifier type *) module type BaseId = @@ -29,6 +29,7 @@ sig val to_string : t -> string val output : out_channel -> t -> unit val print : Format.formatter -> t -> unit + val rename : t -> t end module type Id = diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index 54c426575017..ec01417d969b 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -22,6 +22,7 @@ module Env = Closure_conversion_aux.Env module Expr = Flambda.Expr module Function_decls = Closure_conversion_aux.Function_decls module Function_decl = Function_decls.Function_decl +module Function_params_and_body = Flambda.Function_params_and_body module Named = Flambda.Named module Program_body = Flambda_static.Program_body module Static_part = Flambda_static.Static_part @@ -40,6 +41,7 @@ type t = { mutable imported_symbols : Symbol.Set.t; (* All symbols in [imported_symbols] are to be of kind [Value]. *) mutable declared_symbols : (Symbol.t * K.value Static_part.t) list; + mutable code : (Code_id.t * Function_params_and_body.t) list; } let symbol_for_ident t id = @@ -53,7 +55,7 @@ let symbol_for_ident t id = let tupled_function_call_stub (original_params : (Variable.t * Lambda.value_kind) list) (unboxed_version : Closure_id.t) - ~(closure_id : Closure_id.t) + code_id ~(closure_id : Closure_id.t) recursive = let dbg = Debuginfo.none in let return_continuation = Continuation.create ~sort:Return () in @@ -73,7 +75,8 @@ let tupled_function_call_stub let unboxed_version_var = Variable.create "unboxed_version" in let call = let call_kind = - Call_kind.direct_function_call unboxed_version ~return_arity:[K.value] + Call_kind.direct_function_call code_id unboxed_version + ~return_arity:[K.value] in let apply = Flambda.Apply.create ~callee:(Simple.var unboxed_version_var) @@ -129,14 +132,21 @@ let tupled_function_call_stub ~body ~my_closure in - Flambda.Function_declaration.create - ~params_and_body - ~result_arity:[K.value] - ~stub:true - ~dbg - ~inline:Default_inline - ~is_a_functor:false - ~recursive + let code_id = + Code_id.create ~name:((Closure_id.to_string closure_id) ^ "_tuple_stub") + (Compilation_unit.get_current_exn ()) + in + let func_decl = + Flambda.Function_declaration.create ~code_id + ~params_arity:[K.value] + ~result_arity:[K.value] + ~stub:true + ~dbg + ~inline:Default_inline + ~is_a_functor:false + ~recursive + in + func_decl, code_id, params_and_body let register_const0 t (constant : K.value Static_part.t) name = let current_compilation_unit = Compilation_unit.get_current_exn () in @@ -684,6 +694,9 @@ and close_one_function t ~external_env ~by_closure_id decl let closure_id = Function_decl.closure_id decl in let our_let_rec_ident = Function_decl.let_rec_ident decl in let compilation_unit = Compilation_unit.get_current_exn () in + let code_id = + Code_id.create ~name:(Closure_id.to_string closure_id) compilation_unit + in let unboxed_version = Closure_id.wrap compilation_unit (Variable.create ( Ident.name (Function_decl.let_rec_ident decl))) @@ -797,17 +810,18 @@ and close_one_function t ~external_env ~by_closure_id decl var_within_closures_to_bind body in + let exn_continuation = + close_exn_continuation external_env (Function_decl.exn_continuation decl) + in + let inline = LC.inline_attribute (Function_decl.inline decl) in + let params_and_body = + Flambda.Function_params_and_body.create + ~return_continuation:(Function_decl.return_continuation decl) + exn_continuation params ~body ~my_closure + in let fun_decl = - let exn_continuation = - close_exn_continuation external_env (Function_decl.exn_continuation decl) - in - let inline = LC.inline_attribute (Function_decl.inline decl) in - let params_and_body = - Flambda.Function_params_and_body.create - ~return_continuation:(Function_decl.return_continuation decl) - exn_continuation params ~body ~my_closure - in - Flambda.Function_declaration.create ~params_and_body + Flambda.Function_declaration.create ~code_id + ~params_arity:(Kinded_parameter.List.arity params) ~result_arity:[LC.value_kind return] ~stub ~dbg @@ -815,13 +829,15 @@ and close_one_function t ~external_env ~by_closure_id decl ~is_a_functor:(Function_decl.is_a_functor decl) ~recursive in + t.code <- (code_id, params_and_body) :: t.code; match Function_decl.kind decl with | Curried -> Closure_id.Map.add my_closure_id fun_decl by_closure_id | Tupled -> - let generic_function_stub = - tupled_function_call_stub param_vars unboxed_version ~closure_id + let generic_function_stub, code_id, params_and_body = + tupled_function_call_stub param_vars unboxed_version code_id ~closure_id recursive in + t.code <- (code_id, params_and_body) :: t.code; Closure_id.Map.add unboxed_version fun_decl (Closure_id.Map.add closure_id generic_function_stub by_closure_id) @@ -836,6 +852,7 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename filename; imported_symbols = Symbol.Set.empty; declared_symbols = []; + code = []; } in let module_symbol = Backend.symbol_for_global' module_ident in @@ -939,6 +956,40 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename in Program_body.define_symbol definition ~body:(Program_body.root module_symbol) + Code_age_relation.empty + in + let program_body = + List.fold_left + (fun program_body (code_id, params_and_body) : Program_body.t -> + let bound_symbols : K.fabricated Program_body.Bound_symbols.t = + Code_and_set_of_closures { + code_ids = Code_id.Set.singleton code_id; + closure_symbols = Closure_id.Map.empty; + } + in + let static_part : K.fabricated Static_part.t = + let code : Static_part.code = + { params_and_body = Present params_and_body; + newer_version_of = None; + } + in + Code_and_set_of_closures { + code = Code_id.Map.singleton code_id code; + set_of_closures = None; + } + in + let static_structure : Program_body.Static_structure.t = + [S (bound_symbols, static_part)] + in + let definition : Program_body.Definition.t = + { computation = None; + static_structure; + } + in + Program_body.define_symbol definition ~body:program_body + Code_age_relation.empty) + program_body + t.code in let program_body = (* CR mshinwell: Share with [Simplify_program] *) @@ -954,7 +1005,7 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename static_structure; } in - Program_body.define_symbol definition ~body) + Program_body.define_symbol definition ~body Code_age_relation.empty) program_body t.declared_symbols in diff --git a/middle_end/flambda2.0/inlining/inlining_cost.ml b/middle_end/flambda2.0/inlining/inlining_cost.ml index ef7980a075d7..0deadd383943 100644 --- a/middle_end/flambda2.0/inlining/inlining_cost.ml +++ b/middle_end/flambda2.0/inlining/inlining_cost.ml @@ -18,6 +18,8 @@ open! Flambda.Import +module DE = Simplify_env_and_result.Downwards_env + (* Simple approximation of the space cost of a primitive. *) let prim_size (_prim : Flambda_primitive.t) = 1 (* CR mshinwell: Implement this function @@ -73,27 +75,27 @@ let prim_size (_prim : Flambda_primitive.t) = 1 let direct_call_size = 4 let _project_size = 1 -let smaller' expr ~than:threshold = +let smaller' denv expr ~than:threshold = let size = ref 0 in - let rec expr_size expr = + let rec expr_size denv expr = if !size > threshold then raise Exit; match Expr.descr expr with | Let let_expr -> - named_size (Let.defining_expr let_expr); + named_size denv (Let.defining_expr let_expr); Let.pattern_match let_expr - ~f:(fun ~bound_vars:_ ~body -> expr_size body) + ~f:(fun ~bound_vars:_ ~body -> expr_size denv body) | Let_cont (Non_recursive { handler; _ }) -> Non_recursive_let_cont_handler.pattern_match handler - ~f:(fun _cont ~body -> expr_size body); - continuation_handler_size + ~f:(fun _cont ~body -> expr_size denv body); + continuation_handler_size denv (Non_recursive_let_cont_handler.handler handler) | Let_cont (Recursive handlers) -> Recursive_let_cont_handlers.pattern_match handlers ~f:(fun ~body handlers -> - expr_size body; + expr_size denv body; let handlers = Continuation_handlers.to_map handlers in Continuation.Map.iter (fun _cont handler -> - continuation_handler_size handler) + continuation_handler_size denv handler) handlers) | Apply apply -> let call_cost = @@ -109,7 +111,7 @@ let smaller' expr ~than:threshold = | Apply_cont _ -> incr size | Switch switch -> size := !size + (5 * Switch.num_arms switch) | Invalid _ -> () - and named_size (named : Named.t) = + and named_size denv (named : Named.t) = if !size > threshold then raise Exit; match named with | Simple simple -> @@ -121,28 +123,29 @@ let smaller' expr ~than:threshold = let func_decls = Set_of_closures.function_decls set_of_closures in let funs = Function_declarations.funs func_decls in Closure_id.Map.iter (fun _ func_decl -> - Function_params_and_body.pattern_match - (Function_declaration.params_and_body func_decl) + let code_id = Function_declaration.code_id func_decl in + let params_and_body = DE.find_code denv code_id in + Function_params_and_body.pattern_match params_and_body ~f:(fun ~return_continuation:_ _exn_continuation _params ~body ~my_closure:_ -> - expr_size body)) + expr_size denv body)) funs | Prim (prim, _dbg) -> size := !size + prim_size prim - and continuation_handler_size handler = + and continuation_handler_size denv handler = let params_and_handler = Continuation_handler.params_and_handler handler in Continuation_params_and_handler.pattern_match params_and_handler - ~f:(fun _params ~handler -> expr_size handler) + ~f:(fun _params ~handler -> expr_size denv handler) in try - expr_size expr; + expr_size denv expr; if !size <= threshold then Some !size else None with Exit -> None -let size expr = - match smaller' expr ~than:max_int with +let size denv expr = + match smaller' denv expr ~than:max_int with | Some size -> size | None -> (* There is no way that an expression of size max_int could fit in @@ -182,14 +185,14 @@ module Threshold = struct Can_inline_if_no_larger_than (min i1 i2) end -let smaller lam ~than = - smaller' lam ~than <> None +let smaller denv lam ~than = + smaller' denv lam ~than <> None -let can_inline lam inlining_threshold ~bonus = +let can_inline denv lam inlining_threshold ~bonus = match inlining_threshold with | Threshold.Never_inline -> false | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - smaller + smaller denv lam ~than:(inlining_threshold + bonus) @@ -239,8 +242,8 @@ module Benefit = struct let direct_call_of_indirect_unknown_arity t = { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; } - let requested_inline t ~size_of = - let size = size size_of in + let requested_inline denv t ~size_of = + let size = size denv size_of in { t with requested_inline = t.requested_inline + size; } let print ppf b = diff --git a/middle_end/flambda2.0/inlining/inlining_cost.mli b/middle_end/flambda2.0/inlining/inlining_cost.mli index 1a3ed6481860..47dfb5d987de 100644 --- a/middle_end/flambda2.0/inlining/inlining_cost.mli +++ b/middle_end/flambda2.0/inlining/inlining_cost.mli @@ -37,7 +37,8 @@ end cost so as to fit under the given [inlining_threshold]. The [bonus] is added to the threshold before evaluation. *) val can_inline - : Expr.t + : Simplify_env_and_result.Downwards_env.t + -> Expr.t -> Threshold.t -> bonus:int -> bool @@ -65,7 +66,11 @@ module Benefit : sig val remove_branch : t -> t val direct_call_of_indirect_unknown_arity : t -> t val direct_call_of_indirect_known_arity : t -> t - val requested_inline : t -> size_of:Expr.t -> t + val requested_inline + : Simplify_env_and_result.Downwards_env.t + -> t + -> size_of:Expr.t + -> t val print : Format.formatter -> t -> unit end diff --git a/middle_end/flambda2.0/inlining/inlining_decision.ml b/middle_end/flambda2.0/inlining/inlining_decision.ml index 61e4e884be89..9a29b3c7241d 100644 --- a/middle_end/flambda2.0/inlining/inlining_decision.ml +++ b/middle_end/flambda2.0/inlining/inlining_decision.ml @@ -44,8 +44,9 @@ let make_decision_for_function_declaration denv function_decl | Always_inline | Default_inline | Unroll _ -> if Function_declaration.stub function_decl then Stub else - Function_params_and_body.pattern_match - (Function_declaration.params_and_body function_decl) + let code_id = Function_declaration.code_id function_decl in + let params_and_body = DE.find_code denv code_id in + Function_params_and_body.pattern_match params_and_body ~f:(fun ~return_continuation:_ _exn_continuation _params ~body ~my_closure:_ : Function_declaration_decision.t -> let inlining_threshold : Inlining_cost.Threshold.t = @@ -60,7 +61,7 @@ let make_decision_for_function_declaration denv function_decl (unscaled *. (float_of_int Inlining_cost.scale_inline_threshold_by))) in - if Inlining_cost.can_inline body inlining_threshold ~bonus:0 + if Inlining_cost.can_inline denv body inlining_threshold ~bonus:0 then Inline else Function_body_too_large) diff --git a/middle_end/flambda2.0/inlining/inlining_transforms.ml b/middle_end/flambda2.0/inlining/inlining_transforms.ml index 777aebdb1bfe..652c5ee5a0a5 100644 --- a/middle_end/flambda2.0/inlining/inlining_transforms.ml +++ b/middle_end/flambda2.0/inlining/inlining_transforms.ml @@ -20,16 +20,17 @@ open! Simplify_import module DA = Downwards_acc module DE = Simplify_env_and_result.Downwards_env +module I = Flambda_type.Function_declaration_type.Inlinable module T = Flambda_type module VB = Var_in_binding_pos let inline dacc ~callee ~args function_decl ~apply_return_continuation ~apply_exn_continuation ~apply_inlining_depth ~unroll_to dbg = - Function_params_and_body.pattern_match - (Function_declaration.params_and_body function_decl) + let denv = DA.denv dacc in + let params_and_body = DE.find_code denv (I.code_id function_decl) in + Function_params_and_body.pattern_match params_and_body ~f:(fun ~return_continuation exn_continuation params ~body ~my_closure -> - let denv = DA.denv dacc in let typing_env = DE.typing_env denv in (* XXX The following is a hack until we work out more of the theory about [Rec_info] *) diff --git a/middle_end/flambda2.0/inlining/inlining_transforms.mli b/middle_end/flambda2.0/inlining/inlining_transforms.mli index a6193e4414a0..69191d54d1f2 100644 --- a/middle_end/flambda2.0/inlining/inlining_transforms.mli +++ b/middle_end/flambda2.0/inlining/inlining_transforms.mli @@ -22,7 +22,7 @@ val inline : Downwards_acc.t -> callee:Simple.t -> args:Simple.t list - -> Flambda.Function_declaration.t + -> Flambda_type.Function_declaration_type.Inlinable.t -> apply_return_continuation:Continuation.t -> apply_exn_continuation:Exn_continuation.t -> apply_inlining_depth:int diff --git a/middle_end/flambda2.0/naming/name_occurrences.ml b/middle_end/flambda2.0/naming/name_occurrences.ml index 6978fd97be1d..c2985780e9fc 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.ml +++ b/middle_end/flambda2.0/naming/name_occurrences.ml @@ -293,30 +293,47 @@ module For_closure_vars = For_one_variety_of_names (struct let apply_name_permutation t _perm = t end) +module For_code_ids = For_one_variety_of_names (struct + include Code_id + (* We never bind [Code_id]s using [Name_abstraction]. *) + let apply_name_permutation t _perm = t +end) + type t = { variables : For_variables.t; continuations : For_continuations.t; symbols : For_symbols.t; closure_vars : For_closure_vars.t; + code_ids : For_code_ids.t; + newer_version_of_code_ids : For_code_ids.t; + (* [newer_version_of_code_ids] tracks those code IDs that occur in + "newer version of" fields (e.g. in [Flambda_static.Static_part.code]). *) } -let print ppf { variables; continuations; symbols; closure_vars; } = +let print ppf { variables; continuations; symbols; closure_vars; + code_ids; newer_version_of_code_ids; } = Format.fprintf ppf "@[\ @[(variables %a)@]@ \ @[(continuations %a)@]@ \ @[(symbols %a)@]@ \ - @[(closure_vars %a)@]\ + @[(closure_vars %a)@]@ \ + @[(code_ids %a)@]\ + @[(newer_version_of_code_ids %a)@]\ @]" For_variables.print variables For_continuations.print continuations For_symbols.print symbols For_closure_vars.print closure_vars + For_code_ids.print code_ids + For_code_ids.print newer_version_of_code_ids let empty = { variables = For_variables.empty; continuations = For_continuations.empty; symbols = For_symbols.empty; closure_vars = For_closure_vars.empty; + code_ids = For_code_ids.empty; + newer_version_of_code_ids = For_code_ids.empty; } let singleton_continuation cont = @@ -360,6 +377,17 @@ let add_closure_var t clos_var kind = closure_vars = For_closure_vars.add t.closure_vars clos_var kind; } +let add_code_id t id kind = + { t with + code_ids = For_code_ids.add t.code_ids id kind; + } + +let add_newer_version_of_code_id t id kind = + { t with + newer_version_of_code_ids = + For_code_ids.add t.newer_version_of_code_ids id kind; + } + let singleton_symbol sym kind = { empty with symbols = For_symbols.singleton sym kind; @@ -395,7 +423,9 @@ let create_closure_vars clos_vars = { empty with closure_vars; } let apply_name_permutation - ({ variables; continuations; symbols; closure_vars; } as t) perm = + ({ variables; continuations; symbols; closure_vars; code_ids; + newer_version_of_code_ids; } as t) + perm = if Name_permutation.is_empty perm then t else let variables = @@ -404,50 +434,69 @@ let apply_name_permutation let continuations = For_continuations.apply_name_permutation continuations perm in - (* [Symbol]s and [Var_within_closure]s are never bound using + (* [Symbol]s, [Var_within_closure]s and [Code_id]s are never bound using [Name_abstraction]. *) { variables; continuations; symbols; closure_vars; + code_ids; + newer_version_of_code_ids; } let binary_predicate ~for_variables ~for_continuations ~for_symbols - ~for_closure_vars + ~for_closure_vars ~for_code_ids { variables = variables1; continuations = continuations1; symbols = symbols1; closure_vars = closure_vars1; + code_ids = code_ids1; + newer_version_of_code_ids = newer_version_of_code_ids1; } { variables = variables2; continuations = continuations2; symbols = symbols2; closure_vars = closure_vars2; + code_ids = code_ids2; + newer_version_of_code_ids = newer_version_of_code_ids2; } = for_variables variables1 variables2 && for_continuations continuations1 continuations2 && for_symbols symbols1 symbols2 && for_closure_vars closure_vars1 closure_vars2 + && for_code_ids code_ids1 code_ids2 + && for_code_ids newer_version_of_code_ids1 newer_version_of_code_ids2 let binary_op ~for_variables ~for_continuations ~for_symbols ~for_closure_vars + ~for_code_ids { variables = variables1; continuations = continuations1; symbols = symbols1; closure_vars = closure_vars1; + code_ids = code_ids1; + newer_version_of_code_ids = newer_version_of_code_ids1; } { variables = variables2; continuations = continuations2; symbols = symbols2; closure_vars = closure_vars2; + code_ids = code_ids2; + newer_version_of_code_ids = newer_version_of_code_ids2; } = let variables = for_variables variables1 variables2 in let continuations = for_continuations continuations1 continuations2 in let symbols = for_symbols symbols1 symbols2 in let closure_vars = for_closure_vars closure_vars1 closure_vars2 in + let code_ids = for_code_ids code_ids1 code_ids2 in + let newer_version_of_code_ids = + for_code_ids newer_version_of_code_ids1 newer_version_of_code_ids2 + in { variables; continuations; symbols; closure_vars; + code_ids; + newer_version_of_code_ids; } let diff t1 t2 = @@ -455,6 +504,7 @@ let diff t1 t2 = ~for_continuations:For_continuations.diff ~for_symbols:For_symbols.diff ~for_closure_vars:For_closure_vars.diff + ~for_code_ids:For_code_ids.diff t1 t2 let union t1 t2 = @@ -462,6 +512,7 @@ let union t1 t2 = ~for_continuations:For_continuations.union ~for_symbols:For_symbols.union ~for_closure_vars:For_closure_vars.union + ~for_code_ids:For_code_ids.union t1 t2 let equal t1 t2 = @@ -469,13 +520,17 @@ let equal t1 t2 = ~for_continuations:For_continuations.equal ~for_symbols:For_symbols.equal ~for_closure_vars:For_closure_vars.equal + ~for_code_ids:For_code_ids.equal t1 t2 +let is_empty t = equal t empty + let subset_domain t1 t2 = binary_predicate ~for_variables:For_variables.subset_domain ~for_continuations:For_continuations.subset_domain ~for_symbols:For_symbols.subset_domain ~for_closure_vars:For_closure_vars.subset_domain + ~for_code_ids:For_code_ids.subset_domain t1 t2 let rec union_list ts = @@ -487,6 +542,8 @@ let variables t = For_variables.keys t.variables let symbols t = For_symbols.keys t.symbols let closure_vars t = For_closure_vars.keys t.closure_vars let continuations t = For_continuations.keys t.continuations +let code_ids t = For_code_ids.keys t.code_ids +let newer_version_of_code_ids t = For_code_ids.keys t.newer_version_of_code_ids let names t = Name.Set.union (Name.set_of_var_set (variables t)) @@ -513,7 +570,9 @@ let greatest_name_mode_var t var = For_variables.greatest_name_mode t.variables var let downgrade_occurrences_at_strictly_greater_kind - { variables; continuations; symbols; closure_vars; } max_kind = + { variables; continuations; symbols; closure_vars; code_ids; + newer_version_of_code_ids; } + max_kind = let variables = For_variables.downgrade_occurrences_at_strictly_greater_kind variables max_kind @@ -530,8 +589,18 @@ let downgrade_occurrences_at_strictly_greater_kind For_closure_vars.downgrade_occurrences_at_strictly_greater_kind closure_vars max_kind in + let code_ids = + For_code_ids.downgrade_occurrences_at_strictly_greater_kind + code_ids max_kind + in + let newer_version_of_code_ids = + For_code_ids.downgrade_occurrences_at_strictly_greater_kind + newer_version_of_code_ids max_kind + in { variables; continuations; symbols; closure_vars; + code_ids; + newer_version_of_code_ids; } diff --git a/middle_end/flambda2.0/naming/name_occurrences.mli b/middle_end/flambda2.0/naming/name_occurrences.mli index f0e10b9553d5..8f81f849bc3a 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.mli +++ b/middle_end/flambda2.0/naming/name_occurrences.mli @@ -38,6 +38,8 @@ type t val empty : t +val is_empty : t -> bool + val print : Format.formatter -> t -> unit val equal : t -> t -> bool @@ -60,6 +62,14 @@ val add_name : t -> Name.t -> Name_mode.t -> t val add_closure_var : t -> Var_within_closure.t -> Name_mode.t -> t +(** If the use of the code ID is in a "newer version of" field, use + [add_newer_version_of_code_id], not this function -- see below. *) +val add_code_id : t -> Code_id.t -> Name_mode.t -> t + +(** [add_newer_version_of_code_id] registers a use of a code ID occurring in a + "newer version of" field (e.g. in [Flambda_static.Static_part.code]). *) +val add_newer_version_of_code_id : t -> Code_id.t -> Name_mode.t -> t + val singleton_name : Name.t -> Name_mode.t -> t val singleton_symbol : Symbol.t -> Name_mode.t -> t @@ -94,6 +104,10 @@ val continuations : t -> Continuation.Set.t val closure_vars : t -> Var_within_closure.Set.t +val code_ids : t -> Code_id.Set.t + +val newer_version_of_code_ids : t -> Code_id.Set.t + val mem_var : t -> Variable.t -> bool val mem_name : t -> Name.t -> bool diff --git a/middle_end/flambda2.0/parser/fexpr_to_flambda.ml b/middle_end/flambda2.0/parser/fexpr_to_flambda.ml index acda7ffc246a..30566e190279 100644 --- a/middle_end/flambda2.0/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2.0/parser/fexpr_to_flambda.ml @@ -4,6 +4,7 @@ module E = Flambda.Expr module I = Flambda_kind.Standard_int module P = Flambda_primitive module K = Flambda_kind +module KP = Kinded_parameter module C = struct type t = string @@ -393,15 +394,19 @@ let rec expr env (e : Fexpr.expr) : E.t = in let body = expr closure_env closure_expr in - let params_and_body = + let _params_and_body = Flambda.Function_params_and_body.create ~return_continuation exn_continuation params ~body ~my_closure in - + let code_id = + Code_id.create ~name:(Closure_id.to_string closure_id) + (Compilation_unit.get_current_exn ()) + in let function_declaration = Flambda.Function_declaration.create - ~params_and_body + ~code_id + ~params_arity:(KP.List.arity params) ~result_arity:[K.value] ~stub:false ~dbg:Debuginfo.none @@ -409,7 +414,10 @@ let rec expr env (e : Fexpr.expr) : E.t = ~is_a_functor:false ~recursive in - + let _ = + Misc.fatal_error "This needs fixing to register [params_and_body] \ + in the environment as a piece of code with [code_id]" + in let bound_closure_var, env = fresh_var env name in let closure_vars = Closure_id.Map.add closure_id @@ -505,10 +513,11 @@ let rec conv_top ~backend (func_env:func_env) (prog : Fexpr.program) : Program_b computed_values = []; } in let body = conv_top ~backend func_env tail in - Program_body.define_symbol ~body { - computation = Some computation; - static_structure = []; - } + Program_body.define_symbol ~body + { computation = Some computation; + static_structure = []; + } + Code_age_relation.empty | Define_symbol (Nonrecursive, { computation; @@ -571,10 +580,11 @@ let rec conv_top ~backend (func_env:func_env) (prog : Fexpr.program) : Program_b in let structure = List.rev structure in let body = conv_top ~backend func_env tail in - Program_body.define_symbol ~body { - computation; - static_structure = structure; - } + Program_body.define_symbol ~body + { computation; + static_structure = structure; + } + Code_age_relation.empty | Let_code code :: tail -> let (name, _loc) = code.name in diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 2677bb4fcec7..e4e2118f7adc 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -282,16 +282,26 @@ end = struct (* CR mshinwell: Convert [Typing_env] to map from [Simple]s. *) | Const _ -> () - let define_code t id code = - if Code_id.Map.mem id t.code then begin + let define_code t ?newer_version_of ~code_id ~params_and_body:code = + if Code_id.Map.mem code_id t.code then begin Misc.fatal_errorf "Code ID %a is already defined, cannot redefine to@ %a" - Code_id.print id + Code_id.print code_id Function_params_and_body.print code end; + let typing_env = + match newer_version_of with + | None -> t.typing_env + | Some older -> + TE.add_to_code_age_relation t.typing_env ~newer:code_id ~older + in { t with - code = Code_id.Map.add id code t.code; + typing_env; + code = Code_id.Map.add code_id code t.code; } + let mem_code t id = + Code_id.Map.mem id t.code + let find_code t id = match Code_id.Map.find id t.code with | exception Not_found -> @@ -299,6 +309,8 @@ end = struct | code -> code (* CR mshinwell: The label should state what order is expected. *) + (* CR mshinwell: Rework lifted constant handling so we don't try to add + lifted constants we already know about. *) let add_lifted_constants t ~lifted = (* Format.eprintf "Adding lifted:@ %a\n%!" @@ -317,23 +329,24 @@ end = struct Symbol.Set.filter (fun sym -> mem_symbol denv sym) being_defined in - if Symbol.Set.equal being_defined already_bound then denv - else if not (Symbol.Set.is_empty already_bound) then - Misc.fatal_errorf "Expected all or none of the following symbols \ - to be found:@ %a@ denv:@ %a" - LC.print lifted_constant - print denv - else - let typing_env = - Symbol.Map.fold (fun sym typ typing_env -> - let sym = - Name_in_binding_pos.create (Name.symbol sym) Name_mode.normal - in - TE.add_definition typing_env sym (T.kind typ)) - types_of_symbols - denv.typing_env - in - let typing_env = + let typing_env = + if Symbol.Set.equal being_defined already_bound then denv.typing_env + else if not (Symbol.Set.is_empty already_bound) then + Misc.fatal_errorf "Expected all or none of the following symbols \ + to be found:@ %a@ denv:@ %a" + LC.print lifted_constant + print denv + else + let typing_env = + Symbol.Map.fold (fun sym typ typing_env -> + let sym = + Name_in_binding_pos.create (Name.symbol sym) + Name_mode.normal + in + TE.add_definition typing_env sym (T.kind typ)) + types_of_symbols + denv.typing_env + in Symbol.Map.fold (fun sym typ typing_env -> let sym = Name.symbol sym in let env_extension = @@ -345,11 +358,14 @@ end = struct TE.add_env_extension typing_env ~env_extension) types_of_symbols typing_env - in - Code_id.Map.fold (fun code_id params_and_body denv -> - define_code denv code_id params_and_body) - (LC.pieces_of_code lifted_constant) - (with_typing_env denv typing_env)) + in + Code_id.Map.fold + (fun code_id (params_and_body, newer_version_of) denv -> + if mem_code denv code_id then denv + else define_code denv ?newer_version_of ~code_id ~params_and_body) + (Flambda_static.Program_body.Definition.get_pieces_of_code + definition) + (with_typing_env denv typing_env)) t (List.rev lifted) @@ -602,17 +618,15 @@ end = struct denv : Downwards_env.t; definition : Definition.t; types_of_symbols : Flambda_type.t Symbol.Map.t; - pieces_of_code : Function_params_and_body.t Code_id.Map.t; } - let print ppf - { denv = _ ; definition; types_of_symbols = _; pieces_of_code = _; } = + let print ppf { denv = _ ; definition; types_of_symbols = _; } = Format.fprintf ppf "@[(\ @[(definition@ %a)@]\ )@]" Definition.print definition - let create denv definition ~types_of_symbols ~pieces_of_code = + let create denv definition ~types_of_symbols = let being_defined = Definition.being_defined definition in if not (Symbol.Set.subset (Symbol.Map.keys types_of_symbols) being_defined) then begin @@ -621,23 +635,27 @@ end = struct (Symbol.Map.print T.print) types_of_symbols Definition.print definition end; - let code_being_defined = Definition.code_being_defined definition in - if not (Code_id.Set.subset (Code_id.Map.keys pieces_of_code) - code_being_defined) - then begin - Misc.fatal_errorf "[pieces_of_code]:@ %a@ does not cover all code IDs \ - in the [Definition]:@ %a" - (Code_id.Map.print Function_params_and_body.print) pieces_of_code - Definition.print definition - end; { denv; definition; types_of_symbols; - pieces_of_code; } + let create_pieces_of_code denv ?newer_versions_of code = + { denv; + definition = Definition.pieces_of_code ?newer_versions_of code; + types_of_symbols = Symbol.Map.empty; + } + + let create_piece_of_code denv ?newer_version_of code_id params_and_body = + let newer_versions_of = + match newer_version_of with + | None -> None + | Some older -> Some (Code_id.Map.singleton code_id older) + in + create_pieces_of_code denv ?newer_versions_of + (Code_id.Map.singleton code_id params_and_body) + let denv_at_definition t = t.denv let definition t = t.definition let types_of_symbols t = t.types_of_symbols - let pieces_of_code t = t.pieces_of_code end diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index f5100dfe199e..160a494ea2a5 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -123,7 +123,12 @@ module type Downwards_env = sig result structure. *) val add_lifted_constants_from_r : t -> result -> t - val define_code : t -> Code_id.t -> Function_params_and_body.t -> t + val define_code + : t + -> ?newer_version_of:Code_id.t + -> code_id:Code_id.t + -> params_and_body:Function_params_and_body.t + -> t val find_code : t -> Code_id.t -> Function_params_and_body.t @@ -270,11 +275,22 @@ module type Lifted_constant = sig : downwards_env -> Flambda_static.Program_body.Definition.t -> types_of_symbols:Flambda_type.t Symbol.Map.t - -> pieces_of_code:Function_params_and_body.t Code_id.Map.t + -> t + + val create_piece_of_code + : downwards_env + -> ?newer_version_of:Code_id.t + -> Code_id.t + -> Flambda.Function_params_and_body.t + -> t + + val create_pieces_of_code + : downwards_env + -> ?newer_versions_of:Code_id.t Code_id.Map.t + -> Flambda.Function_params_and_body.t Code_id.Map.t -> t val denv_at_definition : t -> downwards_env val definition : t -> Flambda_static.Program_body.Definition.t val types_of_symbols : t -> Flambda_type.t Symbol.Map.t - val pieces_of_code : t -> Function_params_and_body.t Code_id.Map.t end diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 0c16003b1cdb..1836702b81a7 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -56,7 +56,7 @@ let rec simplify_let let module L = Flambda.Let in (* CR mshinwell: Find out if we need the special fold function for lets. *) L.pattern_match let_expr ~f:(fun ~bound_vars ~body -> - let bindings, dacc = + let { Simplify_named. bindings_outermost_first = bindings; dacc; } = Simplify_named.simplify_named dacc ~bound_vars (L.defining_expr let_expr) in let body, user_data, uacc = simplify_expr dacc body k in @@ -258,7 +258,8 @@ and simplify_let_cont simplify_recursive_let_cont_handlers dacc handlers k and simplify_direct_full_application - : 'a. DA.t -> Apply.t -> (Function_declaration.t * Rec_info.t) option + : 'a. DA.t -> Apply.t + -> (T.Function_declaration_type.Inlinable.t * Rec_info.t) option -> result_arity:Flambda_arity.t -> 'a k -> Expr.t * 'a * UA.t = fun dacc apply function_decl_opt ~result_arity k -> @@ -327,11 +328,12 @@ Format.eprintf "Simplifying inlined body with DE depth delta = %d\n%!" expr, user_data, uacc and simplify_direct_partial_application - : 'a. DA.t -> Apply.t -> callee's_closure_id:Closure_id.t + : 'a. DA.t -> Apply.t -> callee's_code_id:Code_id.t + -> callee's_closure_id:Closure_id.t -> param_arity:Flambda_arity.t -> result_arity:Flambda_arity.t -> recursive:Recursive.t -> 'a k -> Expr.t * 'a * UA.t -= fun dacc apply ~callee's_closure_id ~param_arity ~result_arity - ~recursive k -> += fun dacc apply ~callee's_code_id ~callee's_closure_id + ~param_arity ~result_arity ~recursive k -> (* For simplicity, we disallow [@inline] attributes on partial applications. The user may always write an explicit wrapper instead with such an attribute. *) @@ -374,7 +376,7 @@ and simplify_direct_partial_application let wrapper_closure_id = Closure_id.wrap compilation_unit (Variable.create "closure") in - let wrapper_taking_remaining_args = + let wrapper_taking_remaining_args, dacc = let return_continuation = Continuation.create () in let remaining_params = List.map (fun kind -> @@ -384,7 +386,7 @@ and simplify_direct_partial_application in let args = applied_args @ (List.map KP.simple remaining_params) in let call_kind = - Call_kind.direct_function_call callee's_closure_id + Call_kind.direct_function_call callee's_code_id callee's_closure_id ~return_arity:result_arity in let applied_args_with_closure_vars = (* CR mshinwell: rename *) @@ -430,8 +432,14 @@ and simplify_direct_partial_application ~body ~my_closure in + let code_id = + Code_id.create + ~name:(Closure_id.to_string callee's_closure_id ^ "_partial") + (Compilation_unit.get_current_exn ()) + in let function_decl = - Function_declaration.create ~params_and_body + Function_declaration.create ~code_id + ~params_arity:(KP.List.arity remaining_params) ~result_arity ~stub:true ~dbg @@ -446,7 +454,18 @@ and simplify_direct_partial_application let closure_elements = Var_within_closure.Map.of_list applied_args_with_closure_vars in - Set_of_closures.create function_decls ~closure_elements + (* CR mshinwell: Factor out this next part into a helper function *) + let code = + Lifted_constant.create_piece_of_code (DA.denv dacc) code_id + params_and_body + in + let dacc = + dacc + |> DA.map_r ~f:(fun r -> R.new_lifted_constant r code) + |> DA.map_denv ~f:(fun denv -> + DE.add_lifted_constants denv ~lifted:[code]) + in + Set_of_closures.create function_decls ~closure_elements, dacc in let apply_cont = Apply_cont.create (Apply.continuation apply) @@ -513,13 +532,16 @@ and simplify_direct_over_application simplify_expr dacc expr k and simplify_direct_function_call - : 'a. DA.t -> Apply.t -> callee's_closure_id:Closure_id.t + : 'a. DA.t -> Apply.t -> callee's_code_id_from_type:Code_id.t + -> callee's_code_id_from_call_kind:Code_id.t option + -> callee's_closure_id:Closure_id.t -> param_arity:Flambda_arity.t -> result_arity:Flambda_arity.t -> recursive:Recursive.t -> arg_types:T.t list - -> (Function_declaration.t * Rec_info.t) option + -> (T.Function_declaration_type.Inlinable.t * Rec_info.t) option -> 'a k -> Expr.t * 'a * UA.t -= fun dacc apply ~callee's_closure_id ~param_arity ~result_arity - ~recursive ~arg_types:_ function_decl_opt k -> += fun dacc apply ~callee's_code_id_from_type ~callee's_code_id_from_call_kind + ~callee's_closure_id ~param_arity ~result_arity ~recursive ~arg_types:_ + function_decl_opt k -> let result_arity_of_application = Call_kind.return_arity (Apply.call_kind apply) in @@ -531,28 +553,41 @@ and simplify_direct_function_call Flambda_arity.print result_arity_of_application Apply.print apply end; - let call_kind = - Call_kind.direct_function_call callee's_closure_id - ~return_arity:result_arity + let callee's_code_id : _ Or_bottom.t = + match callee's_code_id_from_call_kind with + | None -> Ok callee's_code_id_from_type + | Some callee's_code_id_from_call_kind -> + let code_age_rel = TE.code_age_relation (DE.typing_env (DA.denv dacc)) in + Code_age_relation.meet code_age_rel callee's_code_id_from_call_kind + callee's_code_id_from_type in - let apply = Apply.with_call_kind apply call_kind in - let args = Apply.args apply in - let provided_num_args = List.length args in - let num_params = List.length param_arity in - if provided_num_args = num_params then - simplify_direct_full_application dacc apply function_decl_opt - ~result_arity k - else if provided_num_args > num_params then - simplify_direct_over_application dacc apply ~param_arity ~result_arity k - else if provided_num_args > 0 && provided_num_args < num_params then - simplify_direct_partial_application dacc apply - ~callee's_closure_id ~param_arity ~result_arity ~recursive k - else - Misc.fatal_errorf "Function with %d params when simplifying \ - direct OCaml function call with %d arguments: %a" - num_params - provided_num_args - Apply.print apply + match callee's_code_id with + | Bottom -> + let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + Expr.create_invalid (), user_data, uacc + | Ok callee's_code_id -> + let call_kind = + Call_kind.direct_function_call callee's_code_id callee's_closure_id + ~return_arity:result_arity + in + let apply = Apply.with_call_kind apply call_kind in + let args = Apply.args apply in + let provided_num_args = List.length args in + let num_params = List.length param_arity in + if provided_num_args = num_params then + simplify_direct_full_application dacc apply function_decl_opt + ~result_arity k + else if provided_num_args > num_params then + simplify_direct_over_application dacc apply ~param_arity ~result_arity k + else if provided_num_args > 0 && provided_num_args < num_params then + simplify_direct_partial_application dacc apply ~callee's_code_id + ~callee's_closure_id ~param_arity ~result_arity ~recursive k + else + Misc.fatal_errorf "Function with %d params when simplifying \ + direct OCaml function call with %d arguments: %a" + num_params + provided_num_args + Apply.print apply and simplify_function_call_where_callee's_type_unavailable : 'a. DA.t -> Apply.t -> Call_kind.Function_call.t -> arg_types:T.t list @@ -651,22 +686,26 @@ and simplify_function_call [closures_entry] structure in the type does indeed contain the closure in question. *) begin match func_decl_type with - | Known (Inlinable { function_decl; rec_info; }) -> - begin match call with - | Direct { closure_id; _ } -> - if not (Closure_id.equal closure_id callee's_closure_id) then begin - Misc.fatal_errorf "Closure ID %a in application doesn't match \ - closure ID %a discovered via typing.@ Application:@ %a" - Closure_id.print closure_id - Closure_id.print callee's_closure_id - Apply.print apply - end - | Indirect_unknown_arity - | Indirect_known_arity _ -> () - end; + | Ok (Inlinable inlinable) -> + let module I = T.Function_declaration_type.Inlinable in + let callee's_code_id_from_call_kind = + match call with + | Direct { code_id; closure_id; _ } -> + if not (Closure_id.equal closure_id callee's_closure_id) then begin + Misc.fatal_errorf "Closure ID %a in application doesn't match \ + closure ID %a discovered via typing.@ Application:@ %a" + Closure_id.print closure_id + Closure_id.print callee's_closure_id + Apply.print apply + end; + Some code_id + | Indirect_unknown_arity + | Indirect_known_arity _ -> None + in (* CR mshinwell: This should go in Typing_env (ditto logic for Rec_info in Simplify_simple *) let function_decl_rec_info = + let rec_info = I.rec_info inlinable in match Simple.rec_info (Apply.callee apply) with | None -> rec_info | Some newer -> Rec_info.merge rec_info ~newer @@ -677,17 +716,32 @@ Format.eprintf "For call to %a: callee's rec info is %a, rec info from type of f (Misc.Stdlib.Option.print Rec_info.print) (Simple.rec_info (Apply.callee apply)) Rec_info.print function_decl_rec_info; *) - simplify_direct_function_call dacc apply - ~callee's_closure_id ~arg_types - ~param_arity:(Function_declaration.params_arity function_decl) - ~result_arity:(Function_declaration.result_arity function_decl) - ~recursive:(Function_declaration.recursive function_decl) - (Some (function_decl, function_decl_rec_info)) k - | Known (Non_inlinable { param_arity; result_arity; recursive; }) -> - simplify_direct_function_call dacc apply + let callee's_code_id_from_type = I.code_id inlinable in + simplify_direct_function_call dacc apply ~callee's_code_id_from_type + ~callee's_code_id_from_call_kind ~callee's_closure_id ~arg_types + ~param_arity:(I.param_arity inlinable) + ~result_arity:(I.result_arity inlinable) + ~recursive:(I.recursive inlinable) + (Some (inlinable, function_decl_rec_info)) k + | Ok (Non_inlinable non_inlinable) -> + let module N = T.Function_declaration_type.Non_inlinable in + let callee's_code_id_from_type = N.code_id non_inlinable in + let callee's_code_id_from_call_kind = + match call with + | Direct { code_id; _ } -> Some code_id + | Indirect_unknown_arity + | Indirect_known_arity _ -> None + in + simplify_direct_function_call dacc apply ~callee's_code_id_from_type + ~callee's_code_id_from_call_kind ~callee's_closure_id ~arg_types - ~param_arity ~result_arity ~recursive + ~param_arity:(N.param_arity non_inlinable) + ~result_arity:(N.result_arity non_inlinable) + ~recursive:(N.recursive non_inlinable) None k + | Bottom -> + let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + Expr.create_invalid (), user_data, uacc | Unknown -> type_unavailable () end | Unknown -> type_unavailable () @@ -1149,7 +1203,7 @@ and simplify_switch Named.create_prim (Unary (Box_number Untagged_immediate, scrutinee)) Debuginfo.none in - let bindings, _dacc = + let { Simplify_named. bindings_outermost_first = bindings; dacc = _; } = Simplify_named.simplify_named dacc ~bound_vars named in let body = k ~tagged_scrutinee:(Simple.var bound_to) in diff --git a/middle_end/flambda2.0/simplify/simplify_import.ml b/middle_end/flambda2.0/simplify/simplify_import.ml index 411159b1f332..688291a970ce 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.ml +++ b/middle_end/flambda2.0/simplify/simplify_import.ml @@ -31,6 +31,7 @@ module Let = Flambda.Let module Lifted_constant = Simplify_env_and_result.Lifted_constant module Named = Flambda.Named module Non_recursive_let_cont_handler = Flambda.Non_recursive_let_cont_handler +module Program_body = Flambda_static.Program_body module Recursive_let_cont_handlers = Flambda.Recursive_let_cont_handlers module Set_of_closures = Flambda.Set_of_closures module Switch = Flambda.Switch diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index 411159b1f332..688291a970ce 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -31,6 +31,7 @@ module Let = Flambda.Let module Lifted_constant = Simplify_env_and_result.Lifted_constant module Named = Flambda.Named module Non_recursive_let_cont_handler = Flambda.Non_recursive_let_cont_handler +module Program_body = Flambda_static.Program_body module Recursive_let_cont_handlers = Flambda.Recursive_let_cont_handlers module Set_of_closures = Flambda.Set_of_closures module Switch = Flambda.Switch diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index fafc15b43f29..e2053a230a1d 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -48,21 +48,33 @@ let compute_closure_element_types_inside_function ~env_outside_function closure_element_types (env_inside_function, Var_within_closure.Map.empty) -let function_decl_type ~denv_outside_function:denv function_decl rec_info = +let function_decl_type ~denv_outside_function:denv function_decl ?code_id + rec_info = let decision = Inlining_decision.make_decision_for_function_declaration denv function_decl in + let code_id = Option.value code_id ~default:(FD.code_id function_decl) in if Inlining_decision.Function_declaration_decision.can_inline decision then - T.create_inlinable_function_declaration function_decl rec_info + T.create_inlinable_function_declaration + ~code_id + ~param_arity:(FD.params_arity function_decl) + ~result_arity:(FD.result_arity function_decl) + ~stub:(FD.stub function_decl) + ~dbg:(FD.dbg function_decl) + ~inline:(FD.inline function_decl) + ~is_a_functor:(FD.is_a_functor function_decl) + ~recursive:(FD.recursive function_decl) + ~rec_info else T.create_non_inlinable_function_declaration + ~code_id ~param_arity:(FD.params_arity function_decl) ~result_arity:(FD.result_arity function_decl) ~recursive:(FD.recursive function_decl) let compute_closure_types_inside_function ~denv_outside_function ~all_function_decls_in_set ~closure_bound_names - ~closure_element_types_inside_function = + ~closure_element_types_inside_function ~old_to_new_code_ids = let closure_bound_names_inside = Closure_id.Map.map Name_in_binding_pos.rename closure_bound_names in @@ -76,8 +88,11 @@ let compute_closure_types_inside_function ~denv_outside_function aren't the one being simplified (i.e. others in the same mutually-recursive set)? *) Closure_id.Map.map (fun function_decl -> + let new_code_id = + Code_id.Map.find (FD.code_id function_decl) old_to_new_code_ids + in function_decl_type ~denv_outside_function function_decl - (Rec_info.create ~depth:1 ~unroll_to:None)) + ~code_id:new_code_id (Rec_info.create ~depth:1 ~unroll_to:None)) all_function_decls_in_set in let closure_types_inside_function = @@ -92,11 +107,11 @@ let compute_closure_types_inside_function ~denv_outside_function let bind_closure_types_inside_function ~denv_outside_function ~denv_inside_function:denv ~all_function_decls_in_set ~closure_bound_names - ~closure_element_types_inside_function = + ~closure_element_types_inside_function ~old_to_new_code_ids = let closure_bound_names_inside, closure_types_inside_function = compute_closure_types_inside_function ~denv_outside_function ~all_function_decls_in_set ~closure_bound_names - ~closure_element_types_inside_function + ~closure_element_types_inside_function ~old_to_new_code_ids in let denv = Closure_id.Map.fold (fun _closure_id bound_name denv -> @@ -108,7 +123,7 @@ let bind_closure_types_inside_function ~denv_outside_function in (* The name may be bound already when reifying computed values at toplevel (see - [Flambda_static.simplify_return_continuation_handler]). *) + [Simplify_static.simplify_return_continuation_handler]). *) DE.define_name_if_undefined denv bound_name K.value) closure_bound_names_inside denv @@ -128,9 +143,17 @@ let bind_closure_types_inside_function ~denv_outside_function in closure_bound_names_inside, denv +let bind_existing_code_to_new_code_ids denv ~old_to_new_code_ids = + Code_id.Map.fold (fun old_code_id new_code_id denv -> + let params_and_body = DE.find_code denv old_code_id in + DE.define_code denv ~code_id:new_code_id ~newer_version_of:old_code_id + ~params_and_body) + old_to_new_code_ids + denv + let denv_inside_function ~denv_outside_function ~denv_after_enter_closure ~params ~my_closure closure_id ~all_function_decls_in_set - ~closure_bound_names ~closure_element_types = + ~closure_bound_names ~closure_element_types ~old_to_new_code_ids = let env_outside_function = DE.typing_env denv_outside_function in let denv = DE.increment_continuation_scope_level_twice denv_after_enter_closure @@ -139,11 +162,15 @@ let denv_inside_function ~denv_outside_function ~denv_after_enter_closure compute_closure_element_types_inside_function ~env_outside_function ~env_inside_function:(DE.typing_env denv) ~closure_element_types in - let denv = DE.with_typing_env denv env_inside_function in + let denv_inside_function = + env_inside_function + |> DE.with_typing_env denv + |> bind_existing_code_to_new_code_ids ~old_to_new_code_ids + in let closure_bound_names_inside, denv = bind_closure_types_inside_function ~denv_outside_function - ~denv_inside_function:denv ~all_function_decls_in_set ~closure_bound_names - ~closure_element_types_inside_function + ~denv_inside_function ~all_function_decls_in_set ~closure_bound_names + ~closure_element_types_inside_function ~old_to_new_code_ids in let denv = DE.add_parameters_with_unknown_types denv params in match Closure_id.Map.find closure_id closure_bound_names_inside with @@ -156,13 +183,23 @@ let denv_inside_function ~denv_outside_function ~denv_after_enter_closure (Var_in_binding_pos.create my_closure NM.normal) (T.alias_type_of K.value (Simple.name name)) +type simplify_function_result = { + function_decl : FD.t; + new_code_id : Code_id.t; + params_and_body : Function_params_and_body.t; + function_type : T.Function_declaration_type.t; + r : R.t; +} + let simplify_function dacc closure_id function_decl ~all_function_decls_in_set - ~closure_bound_names ~closure_element_types = + ~closure_bound_names ~closure_element_types ~old_to_new_code_ids = let name = Format.asprintf "%a" Closure_id.print closure_id in Profile.record_call ~accumulate:true name (fun () -> let denv_after_enter_closure = DE.enter_closure (DA.denv dacc) in + let code_id = FD.code_id function_decl in + let params_and_body = DE.find_code (DA.denv dacc) code_id in let params_and_body, r = - Function_params_and_body.pattern_match (FD.params_and_body function_decl) + Function_params_and_body.pattern_match params_and_body ~f:(fun ~return_continuation exn_continuation params ~body ~my_closure -> let dacc = @@ -170,7 +207,7 @@ let simplify_function dacc closure_id function_decl ~all_function_decls_in_set denv_inside_function ~denv_outside_function ~denv_after_enter_closure ~params ~my_closure closure_id ~all_function_decls_in_set ~closure_bound_names - ~closure_element_types) + ~closure_element_types ~old_to_new_code_ids) in match Simplify_toplevel.simplify_toplevel dacc body @@ -182,11 +219,11 @@ let simplify_function dacc closure_id function_decl ~all_function_decls_in_set with | body, _cont_uses, r -> (* CR mshinwell: Should probably look at [cont_uses]? *) - let function_decl = + let params_and_body = Function_params_and_body.create ~return_continuation exn_continuation params ~body ~my_closure in - function_decl, r + params_and_body, r | exception Misc.Fatal_error -> if !Clflags.flambda2_context_on_error then begin Format.eprintf "\n%sContext is:%s simplifying function \ @@ -205,36 +242,64 @@ let simplify_function dacc closure_id function_decl ~all_function_decls_in_set end; raise Misc.Fatal_error) in - let function_decl = - FD.update_params_and_body function_decl params_and_body - in - let ty = - function_decl_type ~denv_outside_function:(DA.denv dacc) function_decl - Rec_info.initial + let old_code_id = code_id in + let new_code_id = Code_id.Map.find old_code_id old_to_new_code_ids in + let function_decl = FD.update_code_id function_decl new_code_id in + let function_type = + let denv_outside_function = + DA.denv dacc + |> DE.define_code ~code_id:new_code_id ~newer_version_of:old_code_id + ~params_and_body + |> DE.add_lifted_constants ~lifted:(R.get_lifted_constants r) + in + function_decl_type ~denv_outside_function function_decl Rec_info.initial in - function_decl, ty, r) + { function_decl; + new_code_id; + params_and_body; + function_type; + r; + }) + +type simplify_set_of_closures0_result = { + set_of_closures : Flambda.Set_of_closures.t; + closure_types_by_bound_name : Flambda_type.t Name_in_binding_pos.Map.t; + newer_versions_of : Code_id.t Code_id.Map.t; + code : Flambda.Function_params_and_body.t Code_id.Map.t; + dacc : Downwards_acc.t; + result_dacc : Downwards_acc.t; +} let simplify_set_of_closures0 dacc ~result_dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types = let function_decls = Set_of_closures.function_decls set_of_closures in let all_function_decls_in_set = Function_declarations.funs function_decls in - let all_function_decls_in_set, fun_types, r = + let old_to_new_code_ids = + Closure_id.Map.fold (fun _ function_decl old_to_new_code_ids -> + let old_code_id = FD.code_id function_decl in + let new_code_id = Code_id.rename old_code_id in + Code_id.Map.add old_code_id new_code_id old_to_new_code_ids) + all_function_decls_in_set + Code_id.Map.empty + in + let all_function_decls_in_set, code, fun_types, r = Closure_id.Map.fold (fun closure_id function_decl - (result_function_decls_in_set, fun_types, r) -> - let function_decl, ty, r = + (result_function_decls_in_set, code, fun_types, r) -> + let { function_decl; new_code_id; params_and_body; function_type; r; } = simplify_function (DA.with_r dacc r) closure_id function_decl ~all_function_decls_in_set ~closure_bound_names - ~closure_element_types + ~closure_element_types ~old_to_new_code_ids in let result_function_decls_in_set = Closure_id.Map.add closure_id function_decl result_function_decls_in_set in - let fun_types = Closure_id.Map.add closure_id ty fun_types in - result_function_decls_in_set, fun_types, r) + let code = Code_id.Map.add new_code_id params_and_body code in + let fun_types = Closure_id.Map.add closure_id function_type fun_types in + result_function_decls_in_set, code, fun_types, r) all_function_decls_in_set - (Closure_id.Map.empty, Closure_id.Map.empty, DA.r dacc) + (Closure_id.Map.empty, Code_id.Map.empty, Closure_id.Map.empty, DA.r dacc) in let closure_types_by_bound_name = let closure_types_via_aliases = @@ -316,7 +381,14 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures (Function_declarations.create all_function_decls_in_set) ~closure_elements in - set_of_closures, closure_types_by_bound_name, dacc, result_dacc + let newer_versions_of = Code_id.invert_map old_to_new_code_ids in + { set_of_closures; + closure_types_by_bound_name; + newer_versions_of; + code; + dacc; + result_dacc; + } let simplify_and_lift_set_of_closures dacc ~closure_bound_vars set_of_closures ~closure_elements ~closure_element_types = @@ -347,7 +419,6 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars let lifted_constant = Lifted_constant.create (DA.denv dacc) definition ~types_of_symbols:static_structure_types - ~pieces_of_code:Code_id.Map.empty in R.new_lifted_constant (DA.r dacc) lifted_constant in @@ -377,23 +448,47 @@ let simplify_non_lifted_set_of_closures dacc ~bound_vars ~closure_bound_vars let closure_bound_names = Closure_id.Map.map Name_in_binding_pos.var closure_bound_vars in - let set_of_closures, _closure_types_by_bound_name, _dacc, result_dacc = + let { set_of_closures; + closure_types_by_bound_name = _; + newer_versions_of; + code; + dacc = _; + result_dacc; + } = simplify_set_of_closures0 dacc ~result_dacc:dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types in let defining_expr = Reachable.reachable (Named.create_set_of_closures set_of_closures) in + let result_dacc = + DA.map_r result_dacc ~f:(fun r -> + R.new_lifted_constant r + (Lifted_constant.create_pieces_of_code (DA.denv result_dacc) + code ~newer_versions_of)) + in let result_dacc = (* CR mshinwell: This seems weird. Should there ever be lifted constants in the [r] component of a [dacc] that are not in the [denv] component - of a dacc? If not maybe we could enforce that via a check. *) + of a dacc? If not maybe we could enforce that via a check. + (This comment predates the addition of the code to [result_dacc] + just above.) *) DA.map_denv result_dacc ~f:(fun denv -> DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants (DA.r result_dacc))) in [bound_vars, defining_expr], result_dacc +type can_lift = + | Can_lift + | Cannot_lift + +type type_closure_elements_and_make_lifting_decision_result = { + can_lift : can_lift; + closure_elements : Simple.t Var_within_closure.Map.t; + closure_element_types : T.t Var_within_closure.Map.t; +} + let type_closure_elements_and_make_lifting_decision dacc ~min_name_mode set_of_closures = (* By computing the types of the closure elements, attempt to show that @@ -424,10 +519,15 @@ let type_closure_elements_and_make_lifting_decision dacc ~min_name_mode (Var_within_closure.Map.empty, Var_within_closure.Map.empty) in let can_lift = - Var_within_closure.Map.for_all (fun _ simple -> Simple.is_symbol simple) + if Var_within_closure.Map.for_all (fun _ simple -> Simple.is_symbol simple) closure_elements + then Can_lift + else Cannot_lift in - can_lift, closure_elements, closure_element_types + { can_lift; + closure_elements; + closure_element_types; + } let simplify_set_of_closures dacc ~(bound_vars : Bindable_let_bound.t) set_of_closures = @@ -439,14 +539,15 @@ let simplify_set_of_closures dacc ~(bound_vars : Bindable_let_bound.t) let min_name_mode = Bindable_let_bound.name_mode bound_vars in - let can_lift, closure_elements, closure_element_types = + let { can_lift; closure_elements; closure_element_types; } = type_closure_elements_and_make_lifting_decision dacc ~min_name_mode set_of_closures in - if can_lift then + match can_lift with + | Can_lift -> simplify_and_lift_set_of_closures dacc ~closure_bound_vars set_of_closures ~closure_elements ~closure_element_types - else + | Cannot_lift -> simplify_non_lifted_set_of_closures dacc ~bound_vars ~closure_bound_vars set_of_closures ~closure_elements ~closure_element_types @@ -495,8 +596,19 @@ let simplify_named0 dacc ~(bound_vars : Bindable_let_bound.t) | Set_of_closures set_of_closures -> simplify_set_of_closures dacc ~bound_vars set_of_closures +type simplify_named_result = { + bindings_outermost_first : (Bindable_let_bound.t * Reachable.t) list; + dacc : Downwards_acc.t; +} + let simplify_named dacc ~bound_vars named = - try simplify_named0 dacc ~bound_vars named + try + let bindings_outermost_first, dacc = + simplify_named0 dacc ~bound_vars named + in + { bindings_outermost_first; + dacc; + } with Misc.Fatal_error -> begin if !Clflags.flambda2_context_on_error then begin Format.eprintf "\n%sContext is:%s simplifying [Let] binding@ %a =@ %a@ \ diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.mli b/middle_end/flambda2.0/simplify/simplify_named.rec.mli index 651bf3e51709..d28621a294f4 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.mli +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.mli @@ -14,18 +14,32 @@ (* *) (**************************************************************************) +(** Simplification of the right-hand sides of [Let] bindings. *) + [@@@ocaml.warning "+a-4-30-40-41-42"] -(** [simplify_named] returns the bindings in order (i.e. outermost first - in the list). *) +type simplify_named_result = private { + bindings_outermost_first : (Bindable_let_bound.t * Reachable.t) list; + dacc : Downwards_acc.t; +} + val simplify_named : Downwards_acc.t -> bound_vars:Bindable_let_bound.t -> Flambda.Named.t - -> (Bindable_let_bound.t * Reachable.t) list * Downwards_acc.t + -> simplify_named_result (** The following are only for the use of [Simplify_static]. *) +type simplify_set_of_closures0_result = private { + set_of_closures : Flambda.Set_of_closures.t; + closure_types_by_bound_name : Flambda_type.t Name_in_binding_pos.Map.t; + newer_versions_of : Code_id.t Code_id.Map.t; + code : Flambda.Function_params_and_body.t Code_id.Map.t; + dacc : Downwards_acc.t; + result_dacc : Downwards_acc.t; +} + val simplify_set_of_closures0 : Downwards_acc.t -> result_dacc:Downwards_acc.t @@ -33,13 +47,20 @@ val simplify_set_of_closures0 -> closure_bound_names:Name_in_binding_pos.t Closure_id.Map.t -> closure_elements:Simple.t Var_within_closure.Map.t -> closure_element_types:Flambda_type.t Var_within_closure.Map.t - -> Flambda.Set_of_closures.t - * Flambda_type.t Name_in_binding_pos.Map.t - * Downwards_acc.t * Downwards_acc.t + -> simplify_set_of_closures0_result + +type can_lift = private + | Can_lift + | Cannot_lift + +type type_closure_elements_and_make_lifting_decision_result = private { + can_lift : can_lift; + closure_elements : Simple.t Var_within_closure.Map.t; + closure_element_types : Flambda_type.t Var_within_closure.Map.t; +} val type_closure_elements_and_make_lifting_decision : Downwards_acc.t -> min_name_mode:Name_mode.t -> Flambda.Set_of_closures.t - -> bool * Simple.t Var_within_closure.Map.t - * Flambda_type.t Var_within_closure.Map.t + -> type_closure_elements_and_make_lifting_decision_result diff --git a/middle_end/flambda2.0/simplify/simplify_static.rec.ml b/middle_end/flambda2.0/simplify/simplify_static.rec.ml index 476ee3e6e9ab..5658963f3f66 100644 --- a/middle_end/flambda2.0/simplify/simplify_static.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static.rec.ml @@ -167,16 +167,36 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures let closure_bound_names = Closure_id.Map.map Name_in_binding_pos.symbol closure_symbols in - let set_of_closures, closure_types_by_bound_name, dacc, result_dacc = + let { Simplify_named. + set_of_closures; + closure_types_by_bound_name; + newer_versions_of; + code; + dacc; + result_dacc; + } = Simplify_named.simplify_set_of_closures0 dacc ~result_dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types in let static_structure : Program_body.Static_structure.t = + let code = + Code_id.Map.mapi (fun code_id params_and_body : Static_part.code -> + { params_and_body = Present params_and_body; + newer_version_of = Code_id.Map.find_opt code_id newer_versions_of; + }) + code + in let static_part : K.fabricated Static_part.t = - Set_of_closures set_of_closures + Code_and_set_of_closures { + code; + set_of_closures = Some set_of_closures; + } in let bound_symbols : K.fabricated Program_body.Bound_symbols.t = - Set_of_closures { closure_symbols; } + Code_and_set_of_closures { + code_ids = Code_id.Map.keys code; + closure_symbols; + } in [S (bound_symbols, static_part)] in @@ -192,7 +212,11 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures let simplify_set_of_closures dacc ~result_dacc set_of_closures ~closure_symbols = - let _can_lift, closure_elements, closure_element_types = + let { Simplify_named. + can_lift = _; + closure_elements; + closure_element_types; + } = Simplify_named.type_closure_elements_and_make_lifting_decision dacc ~min_name_mode:Name_mode.normal set_of_closures in @@ -204,10 +228,10 @@ let simplify_static_part_of_kind_value dacc ~result_dacc : K.value Static_part.t * DA.t * DA.t = (* [dacc] holds the environment for simplifying the [Static_part]; it contains bindings for any computed values in addition to the types of everything - prior to the current [Define_symbol]. + prior to the current [Definition]. [result_dacc] holds the environment, which we are computing, that will be - in effect immediately after the current [Define_symbol]. + in effect immediately after the current [Definition]. We have to return both a new [dacc] and a new [result_dacc] since there may be multiple (ordered) symbol bindings in any given [Static_structure]. For @@ -326,16 +350,48 @@ let simplify_static_part_of_kind_value dacc ~result_dacc let simplify_static_part_of_kind_fabricated dacc ~result_dacc (static_part : K.fabricated Static_part.t) - ~closure_symbols + ~code_ids ~closure_symbols : K.fabricated Static_part.t * DA.t * DA.t = match static_part with - | Set_of_closures set_of_closures -> - let set_of_closures, dacc, result_dacc, _static_structure_types, - _static_structure = - simplify_set_of_closures dacc ~result_dacc set_of_closures - ~closure_symbols - in - Set_of_closures set_of_closures, dacc, result_dacc + | Code_and_set_of_closures { code; set_of_closures; } -> + let code_ids' = Code_id.Map.keys code in + if not (Code_id.Set.equal code_ids code_ids') then begin + Misc.fatal_errorf "Mismatch on declared code IDs (%a and %a):@ %a" + Code_id.Set.print code_ids + Code_id.Set.print code_ids' + Static_part.print static_part + end; + let dacc, result_dacc = + Code_id.Map.fold + (fun code_id ({ params_and_body; newer_version_of; } : Static_part.code) + (dacc, result_dacc) -> + (* CR mshinwell: Add invariant check to ensure there are no + unbound names in the code, since we're not simplifying on the + way down. *) + let define_code denv = + match params_and_body with + | Deleted -> denv + | Present params_and_body -> + DE.define_code denv ?newer_version_of ~code_id ~params_and_body + in + let dacc = DA.map_denv dacc ~f:define_code in + let result_dacc = DA.map_denv result_dacc ~f:define_code in + dacc, result_dacc) + code + (dacc, result_dacc) + in + let set_of_closures, dacc, result_dacc = + match set_of_closures with + | None -> None, dacc, result_dacc + | Some set_of_closures -> + let set_of_closures, dacc, result_dacc, _static_structure_types, + _static_structure = + simplify_set_of_closures dacc ~result_dacc set_of_closures + ~closure_symbols + in + Some set_of_closures, dacc, result_dacc + in + Code_and_set_of_closures { code; set_of_closures; }, dacc, result_dacc let simplify_piece_of_static_structure (type k) dacc ~result_dacc (bound_syms : k Program_body.Bound_symbols.t) @@ -351,9 +407,9 @@ let simplify_piece_of_static_structure (type k) dacc ~result_dacc | Singleton result_sym -> simplify_static_part_of_kind_value dacc ~result_dacc static_part ~result_sym - | Set_of_closures { closure_symbols; } -> + | Code_and_set_of_closures { code_ids; closure_symbols; } -> simplify_static_part_of_kind_fabricated dacc ~result_dacc static_part - ~closure_symbols + ~code_ids ~closure_symbols let simplify_static_structure dacc ~result_dacc pieces : DA.t * Program_body.Static_structure.t = @@ -457,13 +513,53 @@ let reify_types_of_computed_values dacc ~result_dacc computed_values = (Name.var var) (T.alias_type_of K.value (Simple.symbol symbol))) in - let function_decls = Function_declarations.create function_decls in + let module I = T.Function_declaration_type.Inlinable in + (* The same code might be reified multiple times and we don't currently + dedup, so we must assign fresh code IDs. *) + let fresh_code_ids = + Closure_id.Map.map (fun inlinable -> + Code_id.rename (I.code_id inlinable)) + function_decls + in + let newer_versions_of = + Closure_id.Map.fold (fun closure_id inlinable newer_versions_of -> + let code_id = I.code_id inlinable in + let fresh_code_id = + Closure_id.Map.find closure_id fresh_code_ids + in + Code_id.Map.add fresh_code_id code_id newer_versions_of) + function_decls + Code_id.Map.empty + in let set_of_closures = + let function_decls = + Closure_id.Map.mapi (fun closure_id inlinable -> + let code_id = Closure_id.Map.find closure_id fresh_code_ids in + Function_declaration.create ~code_id + ~params_arity:(I.param_arity inlinable) + ~result_arity:(I.result_arity inlinable) + ~stub:(I.stub inlinable) + ~dbg:(I.dbg inlinable) + ~inline:(I.inline inlinable) + ~is_a_functor:(I.is_a_functor inlinable) + ~recursive:(I.recursive inlinable)) + function_decls + |> Function_declarations.create + in Set_of_closures.create function_decls ~closure_elements:closure_vars in - let static_structure_part : Static_structure.t0 = - S (Set_of_closures { closure_symbols; }, - Set_of_closures set_of_closures) + let by_code_id = + Closure_id.Map.fold (fun closure_id _inlinable by_code_id -> + let code_id = Closure_id.Map.find closure_id fresh_code_ids in + let params_and_body = DE.find_code (DA.denv dacc) code_id in + Code_id.Map.add code_id params_and_body by_code_id) + function_decls + Code_id.Map.empty + in + let static_structure_part = + Static_structure.pieces_of_code ~newer_versions_of + ~set_of_closures:(closure_symbols, set_of_closures) + by_code_id in result_dacc, dacc, (var, static_structure_part) :: reified_definitions | Simple _ | Cannot_reify | Invalid -> @@ -499,11 +595,8 @@ let simplify_return_continuation_handler dacc DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants r)) in let allowed_free_vars = - Variable.Set.union - (Variable.Set.of_list - (List.map KP.var return_cont_handler.computed_values)) - (Variable.Set.of_list - (List.map KP.var extra_params_and_args.extra_params)) + Variable.Set.union (KP.List.var_set return_cont_handler.computed_values) + (KP.List.var_set extra_params_and_args.extra_params) in let static_structure, result_dacc = let result_dacc, dacc, reified_definitions = @@ -700,14 +793,22 @@ let simplify_definition dacc (defn : Program_body.Definition.t) = in definition, dacc -let define_lifted_constants lifted_constants (body : Program_body.t) = +(* CR mshinwell: + - Need to delete unused code bindings. + - We should only delete code if the corresponding code-age graph is + linear. If it isn't linear then a subsequent join may need code that + is currently unused. + - We should simplify code on the way up if we don't delete it. *) + +let define_lifted_constants dacc lifted_constants (body : Program_body.t) = List.fold_left (fun body lifted_constant : Program_body.t -> let definition = Lifted_constant.definition lifted_constant in let static_structure = (* CR mshinwell: We should have deletion of unused symbols automatically -- needs to be done for non-lifted constants too *) Static_structure.delete_bindings definition.static_structure - ~allowed:(Name_occurrences.symbols (Program_body.free_names body)) + ~free_names_after:(Program_body.free_names body) + (TE.code_age_relation (DE.typing_env (DA.denv dacc))) in if Static_structure.is_empty static_structure then body else @@ -716,19 +817,23 @@ let define_lifted_constants lifted_constants (body : Program_body.t) = static_structure; } in - Program_body.define_symbol definition ~body) + Program_body.define_symbol definition ~body + (TE.code_age_relation (DE.typing_env (DA.denv dacc)))) body lifted_constants let rec simplify_program_body0 dacc (body : Program_body.t) k = match Program_body.descr body with - | Define_symbol (defn, body) -> + | Definition (defn, body) -> let dacc = DA.map_r dacc ~f:(fun r -> R.clear_lifted_constants r) in let defn, dacc = simplify_definition dacc defn in let r = DA.r dacc in simplify_program_body0 dacc body (fun body dacc -> - let body = Program_body.define_symbol defn ~body in - let body = define_lifted_constants (R.get_lifted_constants r) body in + let body = + Program_body.define_symbol defn ~body + (TE.code_age_relation (DE.typing_env (DA.denv dacc))) + in + let body = define_lifted_constants dacc (R.get_lifted_constants r) body in k body dacc) | Root _ -> k body dacc diff --git a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml b/middle_end/flambda2.0/simplify/typing_helpers/reification.ml index 13db18070ced..4d602d91feb5 100644 --- a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml +++ b/middle_end/flambda2.0/simplify/typing_helpers/reification.ml @@ -53,7 +53,6 @@ let lift dacc ty ~bound_to static_part = Definition.singleton_symbol symbol static_part |> Lifted_constant.create (DA.denv dacc) ~types_of_symbols:(Symbol.Map.singleton symbol ty) - ~pieces_of_code:Code_id.Map.empty |> R.new_lifted_constant r) in let symbol' = Simple.symbol symbol in diff --git a/middle_end/flambda2.0/terms/apply_expr.ml b/middle_end/flambda2.0/terms/apply_expr.ml index 4c4ea90160d5..3679f7437b3d 100644 --- a/middle_end/flambda2.0/terms/apply_expr.ml +++ b/middle_end/flambda2.0/terms/apply_expr.ml @@ -74,7 +74,7 @@ let invariant env *) E.check_simple_is_bound_and_of_kind env callee K.value; begin match call_kind with - | Function (Direct { closure_id = _; return_arity = _; }) -> + | Function (Direct { code_id = _; closure_id = _; return_arity = _; }) -> (* Note that [return_arity] is checked for all the cases below. *) E.check_simples_are_bound env args | Function Indirect_unknown_arity -> diff --git a/middle_end/flambda2.0/terms/call_kind.ml b/middle_end/flambda2.0/terms/call_kind.ml index b35bbeac591f..727df9b79641 100644 --- a/middle_end/flambda2.0/terms/call_kind.ml +++ b/middle_end/flambda2.0/terms/call_kind.ml @@ -14,7 +14,7 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "+a-30-40-41-42"] (* CR-someday xclerc: we could add annotations to external declarations (akin to [@@noalloc]) in order to be able to refine the computation of @@ -30,6 +30,7 @@ let fprintf = Format.fprintf module Function_call = struct type t = | Direct of { + code_id : Code_id.t; closure_id : Closure_id.t; return_arity : Flambda_arity.t; } @@ -41,8 +42,13 @@ module Function_call = struct let print ppf call = match call with - | Direct { closure_id; return_arity; } -> - fprintf ppf "@[(Direct %a %a)@]" + | Direct { code_id; closure_id; return_arity; } -> + fprintf ppf "@[(Direct@ \ + @[(code_id@ %a)@]@ \ + @[(closure_id@ %a)@]@ \ + @[(return_arity@ %a)@]\ + )@]" + Code_id.print code_id Closure_id.print closure_id Flambda_arity.print return_arity | Indirect_unknown_arity -> @@ -54,7 +60,8 @@ module Function_call = struct let invariant t = match t with - | Direct { closure_id = _; return_arity; } -> check_arity return_arity + | Direct { code_id = _; closure_id = _; return_arity; } -> + check_arity return_arity | Indirect_unknown_arity -> () | Indirect_known_arity { param_arity; return_arity; } -> check_arity param_arity; @@ -112,8 +119,8 @@ let invariant0 t = let invariant _env t = invariant0 t -let direct_function_call closure_id ~return_arity = - let t = Function (Direct { closure_id; return_arity; }) in +let direct_function_call code_id closure_id ~return_arity = + let t = Function (Direct { code_id; closure_id; return_arity; }) in invariant0 t; t @@ -139,7 +146,13 @@ let return_arity t : Flambda_arity.t = let free_names t = match t with - | Function _ | C_call _ -> Name_occurrences.empty + | Function (Direct { code_id; closure_id = _; return_arity = _; }) -> + Name_occurrences.add_code_id Name_occurrences.empty code_id + Name_mode.normal + | Function Indirect_unknown_arity + | Function (Indirect_known_arity { param_arity = _; return_arity = _; }) + | C_call { alloc = _; param_arity = _; return_arity = _; } -> + Name_occurrences.empty | Method { kind = _; obj; } -> match Simple.descr obj with | Name obj -> @@ -148,7 +161,10 @@ let free_names t = let apply_name_permutation t perm = match t with - | Function _ | C_call _ -> t + | Function (Direct { code_id = _; closure_id = _; return_arity = _; }) + | Function Indirect_unknown_arity + | Function (Indirect_known_arity { param_arity = _; return_arity = _; }) + | C_call { alloc = _; param_arity = _; return_arity = _; } -> t | Method { kind; obj; } -> let obj' = Simple.apply_name_permutation obj perm in if obj == obj' then t diff --git a/middle_end/flambda2.0/terms/call_kind.mli b/middle_end/flambda2.0/terms/call_kind.mli index ed46944fab33..19c9db19901b 100644 --- a/middle_end/flambda2.0/terms/call_kind.mli +++ b/middle_end/flambda2.0/terms/call_kind.mli @@ -21,11 +21,12 @@ module Function_call : sig type t = private | Direct of { + code_id : Code_id.t; + (** The [code_id] uniquely determines the function symbol that must + be called. *) closure_id : Closure_id.t; - (** The [closure_id] isn't actually sufficient to perform a direct - call. The set of closures involved has to be determined first - using reachability analysis. If such determination fails, then - we have to fall back to an indirect call. *) + (** The [closure_id] identifies which closure is to be passed to the + function. *) return_arity : Flambda_arity.t; (** [return_arity] describes what the callee returns. It matches up with the arity of [continuation] in the enclosing [Apply.t] @@ -53,7 +54,11 @@ type t = private include Expr_std.S with type t := t -val direct_function_call : Closure_id.t -> return_arity:Flambda_arity.t -> t +val direct_function_call + : Code_id.t + -> Closure_id.t + -> return_arity:Flambda_arity.t + -> t val indirect_function_call_unknown_arity : unit -> t diff --git a/middle_end/flambda2.0/terms/dune b/middle_end/flambda2.0/terms/dune index 6095a8fd1e40..f93bb6d4d518 100644 --- a/middle_end/flambda2.0/terms/dune +++ b/middle_end/flambda2.0/terms/dune @@ -11,10 +11,6 @@ continuation_params_and_handler.rec.mli expr.rec.ml expr.rec.mli - function_declaration.rec.ml - function_declaration.rec.mli - function_declarations.rec.ml - function_declarations.rec.mli function_params_and_body.rec.ml function_params_and_body.rec.mli let_cont_expr.rec.ml @@ -27,8 +23,6 @@ non_recursive_let_cont_handler.rec.mli recursive_let_cont_handlers.rec.ml recursive_let_cont_handlers.rec.mli - set_of_closures.rec.ml - set_of_closures.rec.mli ) (action (run ../scripts/assemble_rec_modules.sh template/flambda.templ.ml diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index fefe6459a464..d87b8ebb612b 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -376,71 +376,15 @@ end and Continuation_handlers : sig (** Whether any of the continuations are exception handlers. *) val contains_exn_handler : t -> bool -end and Set_of_closures : sig - type t - - (** Printing, invariant checks, name manipulation, etc. *) - include Expr_std.S with type t := t - - (** Create a set of closures given the code for its functions and the - closure variables. *) - val create - : Function_declarations.t - -> closure_elements:Simple.t Var_within_closure.Map.t - -> t - - (** The function declarations associated with the set of closures. *) - val function_decls : t -> Function_declarations.t - - (** The map from the closure's environment entries to their values. *) - val closure_elements : t -> Simple.t Var_within_closure.Map.t - - (** Returns true iff the given set of closures has an empty environment. *) - val has_empty_environment : t -> bool - - (** Returns true iff the given set of closures does not contain any variables - in its environment. (If this condition is satisfied, a set of closures - may be lifted.) *) - val environment_doesn't_mention_variables : t -> bool -end and Function_declarations : sig - (** The representation of a set of function declarations (possibly mutually - recursive). Such a set encapsulates the declarations themselves, - information about their defining environment, and information used - specifically for optimization. - Before a function can be applied it must be "projected" from a set of - closures to yield a "closure". This is done using [Project_closure] - (see above). Given a closure, not only can it be applied, but information - about its defining environment can be retrieved (using [Project_var], - see above). - At runtime, a [set_of_closures] corresponds to an OCaml value with tag - [Closure_tag] (possibly with inline [Infix_tag](s)). As an optimization, - an operation ([Select_closure]) is provided (see above) - which enables one closure within a set to be located given another - closure in the same set. This avoids keeping a pointer to the whole set - of closures alive when compiling, for example, mutually-recursive - functions. - *) - type t - - (** Printing, invariant checks, name manipulation, etc. *) - include Expr_std.S with type t := t - - (** Create a set of function declarations given the individual - declarations. *) - val create : Function_declaration.t Closure_id.Map.t -> t - - (** The function(s) defined by the set of function declarations, indexed - by closure ID. *) - val funs : t -> Function_declaration.t Closure_id.Map.t - - (** [find f t] raises [Not_found] if [f] is not in [t]. *) - val find : t -> Closure_id.t -> Function_declaration.t end and Function_params_and_body : sig (** A name abstraction that comprises a function's parameters (together with any relations between them), the code of the function, and the [my_closure] variable. It also includes the return and exception continuations. + These values are bound using [Define_symbol] constructs + (see [Flambda_static]). + From the body of the function, accesses to variables within the closure need to go via a [Project_var] (from [my_closure]); accesses to any other simultaneously-defined functions need to go likewise via a @@ -478,66 +422,13 @@ end and Function_params_and_body : sig -> my_closure:Variable.t -> 'a) -> 'a -end and Function_declaration : sig - type t - - (** Printing, invariant checks, name manipulation, etc. *) - include Expr_std.S with type t := t - - (** Create a function declaration. *) - val create - : params_and_body:Function_params_and_body.t - -> result_arity:Flambda_arity.t - -> stub:bool - -> dbg:Debuginfo.t - -> inline:Inline_attribute.t - -> is_a_functor:bool - -> recursive:Recursive.t - -> t - - (** The alpha-equivalence class of the function's continuations and - parameters bound over the code of the function. *) - val params_and_body : t -> Function_params_and_body.t - - (** An identifier to provide fast (conservative) equality checking for - function bodies. *) - val code_id : t -> Code_id.t - - (* CR mshinwell: Be consistent: "param_arity" or "params_arity" throughout. *) - val params_arity : t -> Flambda_arity.t - - (** The arity of the return continuation of the function. This provides the - number of results that the function produces and their kinds. *) - (* CR mshinwell: Be consistent everywhere as regards "result" vs "return" - arity. *) - val result_arity : t -> Flambda_arity.t - - (** A stub function is a generated function used to prepare arguments or - return values to allow indirect calls to functions with a special - calling convention. For instance indirect calls to tuplified functions - must go through a stub. Stubs will be unconditionally inlined. *) - val stub : t -> bool - - (** Debug info for the function declaration. *) - val dbg : t -> Debuginfo.t - - (** Inlining requirements from the source code. *) - val inline : t -> Inline_attribute.t - - (** Whether the function is known definitively to be a functor. *) - val is_a_functor : t -> bool - - (** Change the parameters and code of a function declaration. *) - val update_params_and_body : t -> Function_params_and_body.t -> t - - (** Whether the function is recursive, in the sense of the syntactic analysis - conducted during closure conversion. *) - val recursive : t -> Recursive.t -end and Flambda_type : Type_system_intf.S - with type term_language_function_declaration := Function_declaration.t +end +module Function_declaration = Function_declaration +module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr +module Set_of_closures = Set_of_closures (** The idea is that you should typically do "open! Flambda" at the top of files, thus bringing in the following standard set of module aliases. *) diff --git a/middle_end/flambda2.0/terms/flambda_static.ml b/middle_end/flambda2.0/terms/flambda_static.ml index 48de2afcfbf6..f0dd4542cfc7 100644 --- a/middle_end/flambda2.0/terms/flambda_static.ml +++ b/middle_end/flambda2.0/terms/flambda_static.ml @@ -61,11 +61,6 @@ module Of_kind_value = struct print (Format.formatter_of_out_channel chan) t end) - let needs_gc_root t = - match t with - | Symbol _ | Tagged_immediate _ -> false - | Dynamically_computed _ -> true - let free_names t = match t with | Dynamically_computed var -> @@ -74,6 +69,7 @@ module Of_kind_value = struct Name_occurrences.singleton_symbol sym Name_mode.normal | Tagged_immediate _ -> Name_occurrences.empty +(* let invariant env t = let module E = Invariant_env in match t with @@ -81,6 +77,7 @@ module Of_kind_value = struct | Tagged_immediate _ -> () | Dynamically_computed var -> E.check_variable_is_bound_and_of_kind env var K.value +*) end module Static_part = struct @@ -90,13 +87,27 @@ module Static_part = struct type mutable_or_immutable = Mutable | Immutable + type code = { + params_and_body : Flambda.Function_params_and_body.t or_deleted; + newer_version_of : Code_id.t option; + } + and 'a or_deleted = + | Present of 'a + | Deleted + + type code_and_set_of_closures = { + code : code Code_id.Map.t; + set_of_closures : Flambda.Set_of_closures.t option; + } + type 'k t = | Block : Tag.Scannable.t * mutable_or_immutable * (Of_kind_value.t list) -> K.value t | Fabricated_block : Variable.t -> K.value t (* CR mshinwell: This used to say K.fabricated. Use a different index from [K.t]? *) - | Set_of_closures : Flambda.Set_of_closures.t -> K.fabricated t + | Code_and_set_of_closures : code_and_set_of_closures + -> Flambda_kind.fabricated t | Boxed_float : Numbers.Float_by_bit_pattern.t or_variable -> K.value t | Boxed_int32 : Int32.t or_variable -> K.value t @@ -108,26 +119,23 @@ module Static_part = struct -> K.value t | Immutable_string : string or_variable -> K.value t - let _needs_gc_root (type k) (t : k t) = + let get_pieces_of_code (type k) (t : k t) = match t with - | Block (_tag, mut, fields) -> - begin match mut with - | Mutable -> - (* CR mshinwell: The GC does not support this case yet. There is an - old unfinished patch from Damien. *) - true - | Immutable -> List.exists Of_kind_value.needs_gc_root fields - end - | Fabricated_block _ -> true - | Set_of_closures set -> - not (Flambda.Set_of_closures.has_empty_environment set) + | Code_and_set_of_closures { code; set_of_closures = _; } -> + Code_id.Map.filter_map code + ~f:(fun _code_id { params_and_body; newer_version_of; } -> + match params_and_body with + | Present params_and_body -> Some (params_and_body, newer_version_of) + | Deleted -> None) + | Block _ + | Fabricated_block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ - | Immutable_string _ -> false + | Immutable_string _ -> Code_id.Map.empty let free_names (type k) (t : k t) = match t with @@ -138,7 +146,36 @@ module Static_part = struct fields | Fabricated_block v -> Name_occurrences.singleton_variable v Name_mode.normal - | Set_of_closures set -> Flambda.Set_of_closures.free_names set + | Code_and_set_of_closures { code; set_of_closures; } -> + let from_set_of_closures = + match set_of_closures with + | None -> Name_occurrences.empty + | Some set -> Flambda.Set_of_closures.free_names set + in + Code_id.Map.fold + (fun code_id { params_and_body; newer_version_of; } free_names -> + let from_newer_version_of = + match newer_version_of with + | None -> Name_occurrences.empty + | Some older -> + Name_occurrences.add_newer_version_of_code_id + Name_occurrences.empty older Name_mode.normal + in + let from_params_and_body = + match params_and_body with + | Deleted -> Name_occurrences.empty + | Present params_and_body -> + Flambda.Function_params_and_body.free_names params_and_body + in + Name_occurrences.union_list [ + (Name_occurrences.add_code_id Name_occurrences.empty + code_id Name_mode.normal); + from_params_and_body; + from_newer_version_of; + free_names; + ]) + code + from_set_of_closures | Boxed_float (Var v) | Boxed_int32 (Var v) | Boxed_int64 (Var v) @@ -161,6 +198,22 @@ module Static_part = struct (Name_occurrences.empty) fields + let print_params_and_body_with_cache ~cache ppf params_and_body = + match params_and_body with + | Deleted -> Format.fprintf ppf "@[(params_and_body@ Deleted)@]" + | Present params_and_body -> + Flambda.Function_params_and_body.print_with_cache ~cache ppf + params_and_body + + let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = + (* CR mshinwell: elide "newer_version_of" when None *) + Format.fprintf ppf "@[(\ + @[(newer_version_of@ %a)@]@ \ + %a\ + )@]" + (Misc.Stdlib.Option.print Code_id.print) newer_version_of + (print_params_and_body_with_cache ~cache) params_and_body + let print_with_cache (type k) ~cache ppf (t : k t) = let print_float_array_field ppf = function | Const f -> fprintf ppf "%a" Numbers.Float_by_bit_pattern.print f @@ -180,11 +233,17 @@ module Static_part = struct (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Variable.print field - | Set_of_closures set_of_closures -> - fprintf ppf "@[(@<0>%sSet_of_closures@<0>%s@ (%a))@]" + | Code_and_set_of_closures { code; set_of_closures; } -> + fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ + @[(code@ (%a))@]@ \ + @[(set_of_closures@ (%a))@]\ + ))@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) - (Flambda.Set_of_closures.print_with_cache ~cache) set_of_closures + (Code_id.Map.print (print_code_with_cache ~cache)) code + (Misc.Stdlib.Option.print + (Flambda.Set_of_closures.print_with_cache ~cache)) + set_of_closures | Boxed_float (Const f) -> fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" (Flambda_colours.static_part ()) @@ -257,6 +316,7 @@ module Static_part = struct let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t +(* let _invariant (type k) env (t : k t) = try let module E = Invariant_env in @@ -294,6 +354,7 @@ module Static_part = struct fields with Misc.Fatal_error -> Misc.fatal_errorf "(during invariant checks) Context is:@ %a" print t +*) end type static_part_iterator = { @@ -339,7 +400,8 @@ module Program_body = struct module Bound_symbols = struct type 'k t = | Singleton : Symbol.t -> K.value t - | Set_of_closures : { + | Code_and_set_of_closures : { + code_ids : Code_id.Set.t; closure_symbols : Symbol.t Closure_id.Map.t; } -> K.fabricated t @@ -357,8 +419,12 @@ module Program_body = struct K.print K.value (Flambda_colours.elide ()) (Flambda_colours.normal ()) - | Set_of_closures { closure_symbols; } -> - Format.fprintf ppf "@[(closure_symbols@ %a)@]" + | Code_and_set_of_closures { code_ids; closure_symbols; } -> + Format.fprintf ppf "@[\ + @[(code_ids@ %a)@]@ \ + @[(closure_symbols@ {%a})@]\ + @]" + Code_id.Set.print code_ids (Format.pp_print_list ~pp_sep:Format.pp_print_space print_closure_binding) (Closure_id.Map.bindings closure_symbols) @@ -369,17 +435,13 @@ module Program_body = struct let being_defined (type k) (t : k t) = match t with | Singleton sym -> Symbol.Set.singleton sym - | Set_of_closures { closure_symbols; } -> + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> Symbol.Set.of_list (Closure_id.Map.data closure_symbols) let code_being_defined (type k) (t : k t) = match t with | Singleton _ -> Code_id.Set.empty - | Set_of_closures { closure_symbols = _; } -> - (* To be continued... *) - Code_id.Set.empty - - let _gc_roots (type k) (_t : k t) = Misc.fatal_error "NYI" + | Code_and_set_of_closures { code_ids; closure_symbols = _; } -> code_ids end module Static_structure = struct @@ -429,12 +491,43 @@ module Program_body = struct Name_occurrences.empty t - let delete_bindings t ~allowed = - List.filter (fun (S (bound_syms, _static_part)) -> - not (Symbol.Set.is_empty ( - Symbol.Set.inter (Bound_symbols.being_defined bound_syms) - allowed))) - t + let delete_bindings t ~free_names_after code_age_relation = + let rec delete t ~free_names_after ~result = + match t with + | [] -> result + | ((S (bound_syms, static_part)) as part)::t -> + let symbols_after = Name_occurrences.symbols free_names_after in + let can_delete_symbols = + Symbol.Set.is_empty ( + Symbol.Set.inter (Bound_symbols.being_defined bound_syms) + symbols_after) + in + let code_ids_being_defined = + Bound_symbols.code_being_defined bound_syms + in + let code_ids_after = Name_occurrences.code_ids free_names_after in + let code_unused = + Code_id.Set.is_empty + (Code_id.Set.inter code_ids_being_defined code_ids_after) + in + let can_delete_code = + code_unused + && + Code_id.Set.for_all (fun code_id -> + Code_age_relation.newer_versions_form_linear_chain + code_age_relation code_id) + code_ids_being_defined + in + let free_names_after = + Name_occurrences.union free_names_after + (Static_part.free_names static_part) + in + if can_delete_code && can_delete_symbols then + delete t ~free_names_after ~result + else + delete t ~free_names_after ~result:(part :: result) + in + delete (List.rev t) ~free_names_after ~result:[] let iter_static_parts t (iter : static_part_iterator) = List.iter (fun (S (_bound_syms, static_part)) -> @@ -445,6 +538,51 @@ module Program_body = struct List.map (fun (S (bound_syms, static_part)) -> S (bound_syms, mapper.f static_part)) t + + let get_pieces_of_code t = + let code = + List.fold_left (fun code (S (_bound_syms, static_part)) -> + Code_id.Map.disjoint_union code + (Static_part.get_pieces_of_code static_part)) + Code_id.Map.empty + t + in + assert (Code_id.Set.equal (Code_id.Map.keys code) + (code_being_defined t)); + code + + let pieces_of_code ?newer_versions_of ?set_of_closures code = + let newer_versions_of = + Option.value newer_versions_of ~default:Code_id.Map.empty + in + let code = + Code_id.Map.mapi (fun id params_and_body : Static_part.code -> + let newer_version_of = + Code_id.Map.find_opt id newer_versions_of + in + { params_and_body = Present params_and_body; + newer_version_of; + }) + code + in + let static_part : K.fabricated Static_part.t = + let set_of_closures = Option.map snd set_of_closures in + Code_and_set_of_closures { + code; + set_of_closures; + } + in + let bound_symbols : K.fabricated Bound_symbols.t = + let closure_symbols = + Option.value (Option.map fst set_of_closures) + ~default:Closure_id.Map.empty + in + Code_and_set_of_closures { + code_ids = Code_id.Map.keys code; + closure_symbols; + } + in + S (bound_symbols, static_part) end module Definition = struct @@ -478,11 +616,21 @@ module Program_body = struct in Name_occurrences.union free_in_computation free_in_static_structure + let static_structure t = t.static_structure + let singleton_symbol symbol static_part = { computation = None; static_structure = [S (Singleton symbol, static_part)]; } + let pieces_of_code ?newer_versions_of code = + let static_structure_part : Static_structure.t0 = + Static_structure.pieces_of_code ?newer_versions_of code + in + { computation = None; + static_structure = [static_structure_part]; + } + let iter_computation t ~f = match t.computation with | None -> () @@ -510,10 +658,22 @@ module Program_body = struct let code_being_defined t = Static_structure.code_being_defined t.static_structure + + let get_pieces_of_code t = + Static_structure.get_pieces_of_code t.static_structure + + let delete_bindings t ~free_names_after code_age_relation = + let static_structure = + Static_structure.delete_bindings t.static_structure ~free_names_after + code_age_relation + in + { computation = t.computation; + static_structure; + } end type t = - | Define_symbol of { + | Definition of { free_names : Name_occurrences.t; defn : Definition.t; body : t; @@ -522,8 +682,8 @@ module Program_body = struct let rec print_with_cache ~cache ppf t = match t with - | Define_symbol { free_names = _; defn; body; } -> - Format.fprintf ppf "@[(@<0>%sDefine_symbol@<0>%s@ %a)@]@;" + | Definition { free_names = _; defn; body; } -> + Format.fprintf ppf "@[(@<0>%sDefinition@<0>%s@ %a)@]@;" (Flambda_colours.static_keyword ()) (Flambda_colours.normal ()) (Definition.print_with_cache ~cache) defn; @@ -541,22 +701,24 @@ module Program_body = struct let free_names t = match t with - | Define_symbol { free_names; _ } -> free_names + | Definition { free_names; _ } -> free_names | Root sym -> Name_occurrences.singleton_symbol sym Name_mode.normal let used_closure_vars t = match t with - | Define_symbol { free_names; _ } -> + | Definition { free_names; _ } -> Name_occurrences.closure_vars free_names | Root _ -> Var_within_closure.Set.empty - let define_symbol defn ~body = - let being_defined = Definition.being_defined defn in + let define_symbol defn ~body code_age_relation = let free_names_of_body = free_names body in - let free_syms_of_body = Name_occurrences.symbols free_names_of_body in + let defn = + Definition.delete_bindings defn ~free_names_after:free_names_of_body + code_age_relation + in let can_delete = - Symbol.Set.is_empty (Symbol.Set.inter being_defined free_syms_of_body) - && Definition.only_generative_effects defn + Definition.only_generative_effects defn + && Static_structure.is_empty (Definition.static_structure defn) in if can_delete then body else @@ -564,49 +726,25 @@ module Program_body = struct Name_occurrences.union (Definition.free_names defn) free_names_of_body in - Define_symbol { free_names; defn; body; } + Definition { free_names; defn; body; } let root sym = Root sym -(* - let gc_roots t = - let rec gc_roots t roots = - match t with - | Root _ -> roots - | Define_symbol { defn; body; _; } -> - let roots = - match defn.static_structure with - | S pieces -> - List.fold_left (fun roots (bound_symbols, static_part) -> - (* CR mshinwell: check [kind] against the result of - [needs_gc_root] *) - if Static_part.needs_gc_root static_part then - Symbol.Set.union (Bound_symbols.gc_roots bound_symbols) roots - else - roots) - roots - pieces - in - gc_roots body roots - in - gc_roots t Symbol.Set.empty -*) - let rec iter_definitions t ~f = match t with - | Define_symbol { defn; body; _ } -> + | Definition { defn; body; _ } -> f defn; iter_definitions body ~f | Root _ -> () type descr = - | Define_symbol of Definition.t * t + | Definition of Definition.t * t | Root of Symbol.t let descr (t : t) : descr = match t with - | Define_symbol { defn; body; free_names = _; } -> - Define_symbol (defn, body) + | Definition { defn; body; free_names = _; } -> + Definition (defn, body) | Root sym -> Root sym end @@ -621,23 +759,6 @@ module Program = struct (Symbol.Map.print K.print) t.imported_symbols Program_body.print t.body -(* - let gc_roots t = - let syms = Program_body.gc_roots t.body in - if !Clflags.flambda_invariant_checks then begin - Symbol.Set.iter (fun sym -> - if not (Compilation_unit.equal (Compilation_unit.get_current_exn ()) - (Symbol.compilation_unit sym)) - then begin - Misc.fatal_errorf "Symbol %a deemed as needing a GC root yet it \ - comes from another compilation unit" - Symbol.print sym - end) - syms; - end; - syms -*) - let free_names t = (* N.B. [imported_symbols] are not treated as free. *) Program_body.free_names t.body @@ -650,7 +771,7 @@ module Program = struct let root_symbol t = let rec loop (body : Program_body.t) = match body with - | Define_symbol { body; _ } -> loop body + | Definition { body; _ } -> loop body | Root root -> root in loop t.body diff --git a/middle_end/flambda2.0/terms/flambda_static.mli b/middle_end/flambda2.0/terms/flambda_static.mli index 3c78d1d74184..ea49498f69c1 100644 --- a/middle_end/flambda2.0/terms/flambda_static.mli +++ b/middle_end/flambda2.0/terms/flambda_static.mli @@ -40,14 +40,37 @@ module Static_part : sig (** The mutability status of a block field. *) type mutable_or_immutable = Mutable | Immutable + (** A piece of code, comprising of the parameters and body of a function, + together with a field indicating whether the piece of code is a newer + version of one that existed previously (and may still exist), for + example after a round of simplification. *) + type code = { + params_and_body : Flambda.Function_params_and_body.t or_deleted; + newer_version_of : Code_id.t option; + } + and 'a or_deleted = + | Present of 'a + | Deleted + + (* CR mshinwell: Code_id.t to Symbol.t needs to be doable without any + state *) + + (** The possibly-recursive declaration of pieces of code and any associated + set of closures. *) + type code_and_set_of_closures = { + code : code Code_id.Map.t; + (* CR mshinwell: Check the free names of the set of closures *) + set_of_closures : Flambda.Set_of_closures.t option; + } + (** The static structure of a symbol, possibly with holes, ready to be filled with values computed at runtime. *) type 'k t = | Block : Tag.Scannable.t * mutable_or_immutable * (Of_kind_value.t list) -> Flambda_kind.value t | Fabricated_block : Variable.t -> Flambda_kind.value t - (* CR mshinwell: Check the free names of the set of closures *) - | Set_of_closures : Flambda.Set_of_closures.t -> Flambda_kind.fabricated t + | Code_and_set_of_closures : code_and_set_of_closures + -> Flambda_kind.fabricated t | Boxed_float : Numbers.Float_by_bit_pattern.t or_variable -> Flambda_kind.value t | Boxed_int32 : Int32.t or_variable -> Flambda_kind.value t @@ -105,11 +128,13 @@ module Program_body : sig type 'k t = | Singleton : Symbol.t -> Flambda_kind.value t (** A binding of a single symbol of kind [Value]. *) - | Set_of_closures : { + | Code_and_set_of_closures : { + code_ids : Code_id.Set.t; closure_symbols : Symbol.t Closure_id.Map.t; } -> Flambda_kind.fabricated t - (** A binding of possibly multiple symbols to the individual closures - within a set of closures. *) + (** A recursive binding of possibly multiple symbols to the individual + closures within a set of closures; and/or bindings of code to + code IDs. *) val print : Format.formatter -> _ t -> unit @@ -136,9 +161,22 @@ module Program_body : sig val being_defined : t -> Symbol.Set.t - val delete_bindings : t -> allowed:Symbol.Set.t -> t + val delete_bindings + : t + -> free_names_after:Name_occurrences.t + -> Code_age_relation.t + -> t val free_names : t -> Name_occurrences.t + + (** If [newer_versions_of] maps [id1] to [id2] then [id1] is a newer + version of [id2]. *) + val pieces_of_code + : ?newer_versions_of:Code_id.t Code_id.Map.t + -> ?set_of_closures: + (Symbol.t Closure_id.Map.t * Flambda.Set_of_closures.t) + -> Flambda.Function_params_and_body.t Code_id.Map.t + -> t0 end module Definition : sig @@ -158,6 +196,17 @@ module Program_body : sig val singleton_symbol : Symbol.t -> Flambda_kind.value Static_part.t -> t + (** If [newer_versions_of] maps [id1] to [id2] then [id1] is a newer + version of [id2]. *) + val pieces_of_code + : ?newer_versions_of:Code_id.t Code_id.Map.t + -> Flambda.Function_params_and_body.t Code_id.Map.t + -> t + + val get_pieces_of_code + : t + -> (Flambda.Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t + val being_defined : t -> Symbol.Set.t val code_being_defined : t -> Code_id.Set.t @@ -179,7 +228,7 @@ module Program_body : sig (** Define the given symbol(s). No symbol defined by the [definition] may be referenced by the same definition, only by subsequent [define_symbol] constructs. *) - val define_symbol : Definition.t -> body:t -> t + val define_symbol : Definition.t -> body:t -> Code_age_relation.t -> t (** The module block symbol for the compilation unit. *) val root : Symbol.t -> t @@ -189,7 +238,9 @@ module Program_body : sig val iter_definitions : t -> f:(Definition.t -> unit) -> unit type descr = private - | Define_symbol of Definition.t * t + (* CR mshinwell: Rename [Definition] to [Definition]. It doesn't + always define a symbol now. *) + | Definition of Definition.t * t | Root of Symbol.t val descr : t -> descr @@ -209,12 +260,6 @@ module Program : sig (** Print a program to a formatter. *) val print : Format.formatter -> t -> unit -(* - (** All symbols from the given program which must be registered as roots - with the GC. (This does not count any imported symbols.) *) - val gc_roots : t -> Symbol.Set.t -*) - (** All free names in the given program. Imported symbols are not treated as free. *) val free_names : t -> Name_occurrences.t diff --git a/middle_end/flambda2.0/terms/function_declaration.ml b/middle_end/flambda2.0/terms/function_declaration.ml new file mode 100644 index 000000000000..ac5e2b6f1974 --- /dev/null +++ b/middle_end/flambda2.0/terms/function_declaration.ml @@ -0,0 +1,135 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 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-30-40-41-42"] + +type t = { + code_id : Code_id.t; + params_arity : Flambda_arity.t; + result_arity : Flambda_arity.t; + stub : bool; + dbg : Debuginfo.t; + inline : Inline_attribute.t; + is_a_functor : bool; + recursive : Recursive.t; +} + +let invariant _env _t = () + +let create ~code_id ~params_arity ~result_arity ~stub ~dbg + ~(inline : Inline_attribute.t) + ~is_a_functor ~recursive : t = + begin match stub, inline with + | true, (Never_inline | Default_inline) + | false, (Never_inline | Default_inline | Always_inline | Unroll _) -> () + | true, (Always_inline | Unroll _) -> + Misc.fatal_error "Stubs may not be annotated as [Always_inline] or [Unroll]" + end; + { code_id; + params_arity; + result_arity; + stub; + dbg; + inline; + is_a_functor; + recursive; + } + +let print_with_cache ~cache:_ ppf + { code_id; + params_arity; + result_arity; + stub; + dbg; + inline; + is_a_functor; + recursive; + } = + let module C = Flambda_colours in + Format.fprintf ppf "@[(\ + @[(code_id@ %a)@]@ \ + @[@<0>%s(stub@ %b)@<0>%s@]@ \ + @[@<0>%s(dbg@ %a)@<0>%s@]@ \ + @[@<0>%s(inline@ %a)@<0>%s@]@ \ + @[@<0>%s(is_a_functor@ %b)@<0>%s@]@ \ + @[@<0>%s(params_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ + @[@<0>%s(result_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ + @[@<0>%s(recursive@ %a)@<0>%s@]@ " + Code_id.print code_id + (if not stub then Flambda_colours.elide () else C.normal ()) + stub + (Flambda_colours.normal ()) + (Flambda_colours.debuginfo ()) + Debuginfo.print_compact dbg + (Flambda_colours.normal ()) + (if Inline_attribute.is_default inline + then Flambda_colours.elide () + else C.normal ()) + Inline_attribute.print inline + (Flambda_colours.normal ()) + (if not is_a_functor then Flambda_colours.elide () else C.normal ()) + is_a_functor + (Flambda_colours.normal ()) + (if Flambda_arity.is_singleton_value params_arity + then Flambda_colours.elide () + else Flambda_colours.normal ()) + (Flambda_colours.normal ()) + Flambda_arity.print params_arity + (if Flambda_arity.is_singleton_value params_arity + then Flambda_colours.elide () + else Flambda_colours.normal ()) + (Flambda_colours.normal ()) + (if Flambda_arity.is_singleton_value result_arity + then Flambda_colours.elide () + else Flambda_colours.normal ()) + (Flambda_colours.normal ()) + Flambda_arity.print result_arity + (if Flambda_arity.is_singleton_value result_arity + then Flambda_colours.elide () + else Flambda_colours.normal ()) + (Flambda_colours.normal ()) + (match recursive with + | Non_recursive -> Flambda_colours.elide () + | Recursive -> Flambda_colours.normal ()) + Recursive.print recursive + (Flambda_colours.normal ()) + +let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t + +let code_id t = t.code_id +let params_arity t = t.params_arity +let result_arity t = t.result_arity +let stub t = t.stub +let dbg t = t.dbg +let inline t = t.inline +let is_a_functor t = t.is_a_functor +let recursive t = t.recursive + +let free_names + { code_id; + params_arity = _; + result_arity = _; + stub = _; + dbg = _; + inline = _; + is_a_functor = _; + recursive = _; + } = + Name_occurrences.add_code_id Name_occurrences.empty code_id Name_mode.normal + +let apply_name_permutation t _perm = t + +let update_code_id t code_id = { t with code_id; } diff --git a/middle_end/flambda2.0/terms/function_declaration.rec.mli b/middle_end/flambda2.0/terms/function_declaration.mli similarity index 82% rename from middle_end/flambda2.0/terms/function_declaration.rec.mli rename to middle_end/flambda2.0/terms/function_declaration.mli index 176e0e9b141f..566c5be5d1f9 100644 --- a/middle_end/flambda2.0/terms/function_declaration.rec.mli +++ b/middle_end/flambda2.0/terms/function_declaration.mli @@ -21,12 +21,10 @@ type t (** Printing, invariant checks, name manipulation, etc. *) include Expr_std.S with type t := t -(** Compact printer for use when printing types. *) -val print_compact : Format.formatter -> t -> unit - (** Create a function declaration. *) val create - : params_and_body:Function_params_and_body.t + : code_id:Code_id.t + -> params_arity:Flambda_arity.t -> result_arity:Flambda_arity.t -> stub:bool -> dbg:Debuginfo.t @@ -35,12 +33,8 @@ val create -> recursive:Recursive.t -> t -(** The alpha-equivalence class of the function's continuations and - parameters bound over the code of the function. *) -val params_and_body : t -> Function_params_and_body.t - -(** An identifier to provide fast (conservative) equality checking for - function bodies. *) +(** The identifier of the code of the function (which must be bound using + [Define_symbol]). *) val code_id : t -> Code_id.t (* CR mshinwell: Be consistent: "param_arity" or "params_arity" throughout. *) @@ -67,8 +61,9 @@ val inline : t -> Inline_attribute.t (** Whether the function is known definitively to be a functor. *) val is_a_functor : t -> bool -(** Change the parameters and code of a function declaration. *) -val update_params_and_body : t -> Function_params_and_body.t -> t +(** Return a function declaration that is like the supplied one except + that it has a new code ID. *) +val update_code_id : t -> Code_id.t -> t (** Whether the function is recursive, in the sense of the syntactic analysis conducted during closure conversion. *) diff --git a/middle_end/flambda2.0/terms/function_declaration.rec.ml b/middle_end/flambda2.0/terms/function_declaration.rec.ml deleted file mode 100644 index d6c73a5e9ca8..000000000000 --- a/middle_end/flambda2.0/terms/function_declaration.rec.ml +++ /dev/null @@ -1,188 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2019 OCamlPro SAS *) -(* Copyright 2014--2019 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-30-40-41-42"] - -type t = { - params_and_body : Function_params_and_body.t; - (* CR mshinwell: Need to document that [code_id] is used for equality - checking, so it must be updated. Maybe it's a misnomer in fact. *) - code_id : Code_id.t; - result_arity : Flambda_arity.t; - stub : bool; - dbg : Debuginfo.t; - inline : Inline_attribute.t; - is_a_functor : bool; - recursive : Recursive.t; -} - -let invariant _env _t = () - -let create ~params_and_body ~result_arity ~stub ~dbg - ~(inline : Inline_attribute.t) - ~is_a_functor ~recursive : t = - begin match stub, inline with - | true, (Never_inline | Default_inline) - | false, (Never_inline | Default_inline | Always_inline | Unroll _) -> () - | true, (Always_inline | Unroll _) -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_inline] or [Unroll]: %a" - Function_params_and_body.print params_and_body - end; - { params_and_body; - code_id = Code_id.create (Compilation_unit.get_current_exn ()); - result_arity; - stub; - dbg; - inline; - is_a_functor; - recursive; - } - -let print_with_cache0 ~compact ~cache ppf - { params_and_body; - code_id = _; - result_arity; - stub; - dbg; - inline; - is_a_functor; - recursive; - } = - (* CR mshinwell: It's a bit strange that this doesn't use - [Function_params_and_body.print_with_cache]. However a proper - function to print in a more human-readable form will probably look more - like this code. *) - let module C = Flambda_colours in - Function_params_and_body.pattern_match params_and_body - ~f:(fun ~return_continuation exn_continuation params ~body ~my_closure -> - let my_closure = - Kinded_parameter.create (Parameter.wrap my_closure) Flambda_kind.value - in - fprintf ppf "@[(\ - @[@<0>%s(stub@ %b)@<0>%s@]@ \ - @[@<0>%s(dbg@ %a)@<0>%s@]@ \ - @[@<0>%s(inline@ %a)@<0>%s@]@ \ - @[@<0>%s(is_a_functor@ %b)@<0>%s@]@ \ - @[@<0>%s(result_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ - @[@<0>%s(recursive@ %a)@<0>%s@]@ " - (if not stub then Flambda_colours.elide () else C.normal ()) - stub - (Flambda_colours.normal ()) - (Flambda_colours.debuginfo ()) - Debuginfo.print_compact dbg - (Flambda_colours.normal ()) - (if Inline_attribute.is_default inline - then Flambda_colours.elide () - else C.normal ()) - Inline_attribute.print inline - (Flambda_colours.normal ()) - (if not is_a_functor then Flambda_colours.elide () else C.normal ()) - is_a_functor - (Flambda_colours.normal ()) - (if Flambda_arity.is_singleton_value result_arity - then Flambda_colours.elide () - else Flambda_colours.normal ()) - (Flambda_colours.normal ()) - Flambda_arity.print result_arity - (if Flambda_arity.is_singleton_value result_arity - then Flambda_colours.elide () - else Flambda_colours.normal ()) - (Flambda_colours.normal ()) - (match recursive with - | Non_recursive -> Flambda_colours.elide () - | Recursive -> Flambda_colours.normal ()) - Recursive.print recursive - (Flambda_colours.normal ()); - if compact then begin - fprintf ppf "@[(params_and_body@ )@])@]" - end else begin - fprintf ppf - "@[(@<0>%s@<1>\u{03bb}@<0>%s@[\ - @<1>\u{3008}%a@<1>\u{3009}@<1>\u{300a}%a@<1>\u{300b}\ - %a %a @<0>%s.@<0>%s@]@ %a)@])@]" - (Flambda_colours.lambda ()) - (Flambda_colours.normal ()) - Continuation.print return_continuation - Exn_continuation.print exn_continuation - Kinded_parameter.List.print params - Kinded_parameter.print my_closure - (Flambda_colours.elide ()) - (Flambda_colours.normal ()) - (Expr.print_with_cache ~cache) body - end) - -let print_with_cache ~cache ppf t = - print_with_cache0 ~compact:false ~cache ppf t - -let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t - -let print_compact ppf t = - print_with_cache0 ~compact:true ~cache:(Printing_cache.create ()) ppf t - -let params_and_body t = t.params_and_body -let code_id t = t.code_id -let result_arity t = t.result_arity -let stub t = t.stub -let dbg t = t.dbg -let inline t = t.inline -let is_a_functor t = t.is_a_functor -let recursive t = t.recursive - -let update_params_and_body t params_and_body = - { t with - params_and_body; - code_id = Code_id.create (Compilation_unit.get_current_exn ()); - } - -let free_names - { params_and_body; - code_id = _; - result_arity = _; - stub = _; - dbg = _; - inline = _; - is_a_functor = _; - recursive = _; - } = - Function_params_and_body.free_names params_and_body - -let apply_name_permutation - ({ params_and_body; - code_id; - result_arity; - stub; - dbg; - inline; - is_a_functor; - recursive; - } as t) perm = - let params_and_body' = - Function_params_and_body.apply_name_permutation params_and_body perm - in - if params_and_body == params_and_body' then t - else - { params_and_body = params_and_body'; - code_id; - result_arity; - stub; - dbg; - inline; - is_a_functor; - recursive; - } - -let params_arity t = Function_params_and_body.params_arity t.params_and_body \ No newline at end of file diff --git a/middle_end/flambda2.0/terms/function_declarations.rec.ml b/middle_end/flambda2.0/terms/function_declarations.ml similarity index 96% rename from middle_end/flambda2.0/terms/function_declarations.rec.ml rename to middle_end/flambda2.0/terms/function_declarations.ml index 241e9f31cbe8..dd03fd7a0765 100644 --- a/middle_end/flambda2.0/terms/function_declarations.rec.ml +++ b/middle_end/flambda2.0/terms/function_declarations.ml @@ -31,12 +31,8 @@ let funs t = t.funs let find ({ funs; } : t) closure_id = Closure_id.Map.find closure_id funs -let update _function_decls ~funs = - { funs; - } - let print_with_cache ~cache ppf { funs; } = - fprintf ppf "@[(%a)@]" + Format.fprintf ppf "@[(%a)@]" (Closure_id.Map.print (Function_declaration.print_with_cache ~cache)) funs let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t diff --git a/middle_end/flambda2.0/terms/function_declarations.rec.mli b/middle_end/flambda2.0/terms/function_declarations.mli similarity index 100% rename from middle_end/flambda2.0/terms/function_declarations.rec.mli rename to middle_end/flambda2.0/terms/function_declarations.mli diff --git a/middle_end/flambda2.0/terms/function_params_and_body.rec.ml b/middle_end/flambda2.0/terms/function_params_and_body.rec.ml index 06640a47d22c..5fb02c7e5de1 100644 --- a/middle_end/flambda2.0/terms/function_params_and_body.rec.ml +++ b/middle_end/flambda2.0/terms/function_params_and_body.rec.ml @@ -50,10 +50,6 @@ type t = { let invariant _env _t = () -let print ppf t : unit = A.print ppf t.abst - -let print_with_cache ~cache ppf t : unit = A.print_with_cache ~cache ppf t.abst - let create ~return_continuation exn_continuation params ~body ~my_closure = let t0 : T0.t = { body; @@ -82,6 +78,29 @@ let pattern_match t ~f = f ~return_continuation exn_continuation params ~body:t0.body ~my_closure))) +let print_with_cache ~cache ppf t = + pattern_match t + ~f:(fun ~return_continuation exn_continuation params ~body ~my_closure -> + let my_closure = + Kinded_parameter.create (Parameter.wrap my_closure) Flambda_kind.value + in + fprintf ppf + "@[(@<0>%s@<1>\u{03bb}@<0>%s@[\ + @<1>\u{3008}%a@<1>\u{3009}@<1>\u{300a}%a@<1>\u{300b}\ + %a %a @<0>%s.@<0>%s@]@ %a)@])@]" + (Flambda_colours.lambda ()) + (Flambda_colours.normal ()) + Continuation.print return_continuation + Exn_continuation.print exn_continuation + Kinded_parameter.List.print params + Kinded_parameter.print my_closure + (Flambda_colours.elide ()) + (Flambda_colours.normal ()) + (Expr.print_with_cache ~cache) body) + +let print ppf t = + print_with_cache ~cache:(Printing_cache.create ()) ppf t + let params_arity t = t.params_arity let apply_name_permutation ({ abst; params_arity; } as t) perm = @@ -89,4 +108,4 @@ let apply_name_permutation ({ abst; params_arity; } as t) perm = if abst == abst' then t else { abst = abst'; params_arity; } -let free_names { abst; params_arity = _; } = A.free_names abst \ No newline at end of file +let free_names { abst; params_arity = _; } = A.free_names abst diff --git a/middle_end/flambda2.0/terms/rec_modules b/middle_end/flambda2.0/terms/rec_modules index db2acd647edd..c7da7fa6e01d 100644 --- a/middle_end/flambda2.0/terms/rec_modules +++ b/middle_end/flambda2.0/terms/rec_modules @@ -2,12 +2,9 @@ continuation_handler.rec.ml continuation_handlers.rec.ml continuation_params_and_handler.rec.ml expr.rec.ml -function_declaration.rec.ml -function_declarations.rec.ml function_params_and_body.rec.ml let_cont_expr.rec.ml let_expr.rec.ml named.rec.ml non_recursive_let_cont_handler.rec.ml recursive_let_cont_handlers.rec.ml -set_of_closures.rec.ml diff --git a/middle_end/flambda2.0/terms/set_of_closures.rec.ml b/middle_end/flambda2.0/terms/set_of_closures.ml similarity index 98% rename from middle_end/flambda2.0/terms/set_of_closures.rec.ml rename to middle_end/flambda2.0/terms/set_of_closures.ml index db92666d0fb4..771aa0b5f05e 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.rec.ml +++ b/middle_end/flambda2.0/terms/set_of_closures.ml @@ -48,7 +48,7 @@ let print_with_cache ~cache ppf { function_decls; closure_elements; } = - fprintf ppf "@[(%sset_of_closures%s@ \ + Format.fprintf ppf "@[(%sset_of_closures%s@ \ @[(function_decls@ %a)@]@ \ @[(closure_elements@ %a)@]\ )@]" diff --git a/middle_end/flambda2.0/terms/set_of_closures.rec.mli b/middle_end/flambda2.0/terms/set_of_closures.mli similarity index 100% rename from middle_end/flambda2.0/terms/set_of_closures.rec.mli rename to middle_end/flambda2.0/terms/set_of_closures.mli diff --git a/middle_end/flambda2.0/terms/template/flambda.templ.ml b/middle_end/flambda2.0/terms/template/flambda.templ.ml index 678d37bdcd6c..391eca2b560c 100644 --- a/middle_end/flambda2.0/terms/template/flambda.templ.ml +++ b/middle_end/flambda2.0/terms/template/flambda.templ.ml @@ -29,9 +29,6 @@ module Switch = Switch_expr let fprintf = Format.fprintf (* -- module rec binding here -- *) -and Flambda_type : Type_system_intf.S - with type term_language_function_declaration := Function_declaration.t - = Flambda_type0.Make (Function_declaration) (* CR mshinwell: Consider counting numbers of names in Name_occurrences *) (* CR mshinwell: Check that apply_cont is well-formed when there is a @@ -42,8 +39,11 @@ and Flambda_type : Type_system_intf.S overapplication" be an invariant throughout. At the moment I think this is only true after [Simplify] has split overapplications. *) +module Function_declaration = Function_declaration +module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr +module Set_of_closures = Set_of_closures module Import = struct module Apply = Apply diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 0d0cf4635dbc..36595351f240 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -14,6 +14,8 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "-32"] (* FIXME Let_code -- just remove this *) + open! Flambda.Import module Env = Un_cps_env @@ -849,13 +851,16 @@ and apply_call env e = match Apply_expr.call_kind e with (* Effects from arguments are ignored since a function call will always be given arbitrary effects and coeffects. *) - | Call_kind.Function - Call_kind.Function_call.Direct { closure_id; return_arity; } -> + | Call_kind.Function (* FIXME Let code *) + Call_kind.Function_call.Direct { code_id = _; closure_id = _; return_arity = _; } -> + assert false +(* let f_code = Un_cps_closure.(closure_code (closure_name closure_id)) in let f, env, _ = simple env f in let args, env, _ = arg_list env (Apply_expr.args e) in let ty = machtype_of_return_arity return_arity in C.direct_call ~dbg ty (C.symbol f_code) args f, env, effs +*) | Call_kind.Function Call_kind.Function_call.Indirect_unknown_arity -> let f, env, _ = simple env f in @@ -1325,11 +1330,14 @@ let static_structure_item env r | Singleton _, Fabricated_block _ -> (* CR Gbury: What are those ? *) todo() - | Set_of_closures s, Set_of_closures set -> + | Code_and_set_of_closures _ (* s *), Code_and_set_of_closures _ (* set *) -> + assert false (* FIXME Let code *) +(* let data, updates = static_set_of_closures env s.closure_symbols set in R.wrap_init (C.sequence updates) (R.add_data data r) +*) | Singleton s, Boxed_float v -> let default = Numbers.Float_by_bit_pattern.zero in let transl = Numbers.Float_by_bit_pattern.to_float in @@ -1465,9 +1473,11 @@ let function_flags () = else [ Cmm.Reduce_code_size ] -let function_decl offsets used_closure_vars fun_name _ d = +let function_decl _offsets _used_closure_vars fun_name _ d = Profile.record_call ~accumulate:true fun_name (fun () -> - let fun_dbg = Function_declaration.dbg d in + let _fun_dbg = Function_declaration.dbg d in + assert false (* FIXME Let code *) ) +(* let p = Function_declaration.params_and_body d in Function_params_and_body.pattern_match p ~f:(fun ~return_continuation:k k_exn vars ~body ~my_closure -> @@ -1490,6 +1500,7 @@ let function_decl offsets used_closure_vars fun_name _ d = fun_name Expr.print body; raise e)) +*) (* Programs *) @@ -1501,7 +1512,7 @@ let rec program_body offsets ~used_closure_vars acc body = if if has an associated computation, then it will already be included in the list of gc_roots, else it does not *have* to be a root. *) List.fold_left (fun acc r -> R.combine r acc) R.empty acc - | Flambda_static.Program_body.Define_symbol (def, rest) -> + | Flambda_static.Program_body.Definition (def, rest) -> let r = definition offsets ~used_closure_vars def in program_body offsets ~used_closure_vars (r :: acc) rest diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml index 74b51e3db4fa..de81fc3566f1 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml @@ -633,23 +633,25 @@ module Iter_on_sets_of_closures = struct let map = Function_declarations.funs decls in Closure_id.Map.iter (fun_decl f) map - and fun_decl f _ decl = + and fun_decl _f _ _decl = assert false (* FIXME Let code *) +(* let t = Function_declaration.params_and_body decl in Function_params_and_body.pattern_match t ~f:(fun ~return_continuation:_ _exn_k _args ~body ~my_closure:_ -> expr f body ) +*) let computation f c = Flambda_static.Program_body.Computation.iter_expr c ~f:(expr f) - let static_structure_aux f + let static_structure_aux _ _ = assert false (* f ((S (symbs, st)) : Flambda_static.Program_body.Static_structure.t0) = match symbs, st with | Set_of_closures r, Set_of_closures s -> f (Some r.closure_symbols) s; set_of_closures f s - | _ -> () + | _ -> () *) (* FIXME Let code *) let static_structure f s = List.iter (static_structure_aux f) s diff --git a/middle_end/flambda2.0/types/basic/or_unknown.mli b/middle_end/flambda2.0/types/basic/or_unknown.mli index 6e9ec2c6a665..2c6dc2dddd65 100644 --- a/middle_end/flambda2.0/types/basic/or_unknown.mli +++ b/middle_end/flambda2.0/types/basic/or_unknown.mli @@ -41,3 +41,19 @@ module Lift (I : Identifiable.S) : sig include Identifiable.S with type t := t end +(* +module Make_meet_or_join + (Known : functor (E1 : Lattice_ops_intf.S) + -> sig + val meet : meet_env -> t -> t -> (t * typing_env_extension) Or_bottom.t + end + + end) + (E : Lattice_ops_intf.S + with type meet_env := E1.meet_env + with type typing_env := E1.typing_env + with type typing_env_extension := E1.typing_env_extension) +: sig + +end +*) \ No newline at end of file diff --git a/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.ml b/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.ml index fa8598955251..079bca4cfa3a 100644 --- a/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.ml +++ b/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.ml @@ -47,3 +47,8 @@ let map_sharing t ~f = let contents' = f contents in if contents == contents' then t else Ok contents' + +let of_or_unknown (unk : _ Or_unknown.t) : _ t = + match unk with + | Known contents -> Ok contents + | Unknown -> Unknown \ No newline at end of file diff --git a/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.mli b/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.mli index f6a79d447e3f..69e95629af13 100644 --- a/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.mli +++ b/middle_end/flambda2.0/types/basic/or_unknown_or_bottom.mli @@ -32,3 +32,5 @@ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val map : 'a t -> f:('a -> 'b) -> 'b t val map_sharing : 'a t -> f:('a -> 'a) -> 'a t + +val of_or_unknown : 'a Or_unknown.t -> 'a t \ No newline at end of file diff --git a/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml b/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml index 6bcc64f3b0eb..af2f918065f8 100644 --- a/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml +++ b/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml @@ -21,3 +21,7 @@ module type S = sig val print_compact : Format.formatter -> t -> unit val code_id : t -> Code_id.t end + +module type S_code = sig + include Expr_std.S +end \ No newline at end of file diff --git a/middle_end/flambda2.0/types/dune b/middle_end/flambda2.0/types/dune index bf27af20cfb3..d1c4be5559fc 100644 --- a/middle_end/flambda2.0/types/dune +++ b/middle_end/flambda2.0/types/dune @@ -1,8 +1,8 @@ (rule - (targets flambda_type0.ml) + (targets flambda_type.ml) (deps rec_modules - template/flambda_type0.templ.ml + template/flambda_type.templ.ml type_descr.rec.ml type_grammar.rec.ml type_of_kind/variant.rec.ml @@ -55,7 +55,7 @@ structures/row_like.rec.mli ) (action (run ../scripts/assemble_rec_modules.sh - template/flambda_type0.templ.ml + template/flambda_type.templ.ml rec_modules - flambda_type0.ml)) + flambda_type.ml)) ) diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.ml b/middle_end/flambda2.0/types/env/typing_env.rec.ml index a5ad8b110d75..29e89c808f0f 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.ml +++ b/middle_end/flambda2.0/types/env/typing_env.rec.ml @@ -208,6 +208,7 @@ end type t = { resolver : (Export_id.t -> Type_grammar.t option); defined_symbols : Flambda_kind.t Symbol.Map.t; + code_age_relation : Code_age_relation.t; prev_levels : One_level.t Scope.Map.t; (* CR mshinwell: hold list of symbol definitions, then change defined_names to variables, then remove artificial symbol precedence *) @@ -224,7 +225,7 @@ let is_empty t = (* CR mshinwell: Add option to print [aliases] *) let print_with_cache ~cache ppf ({ resolver = _; prev_levels; current_level; next_binding_time = _; - defined_symbols; + defined_symbols; code_age_relation; } as t) = if is_empty t then Format.pp_print_string ppf "Empty" @@ -240,9 +241,11 @@ let print_with_cache ~cache ppf Format.fprintf ppf "@[(\ @[(defined_symbols@ %a)@]@ \ + @[(code_age_relation@ %a)@]@ \ @[(levels@ %a)@]\ )@]" (Symbol.Map.print K.print) defined_symbols + Code_age_relation.print code_age_relation (Scope.Map.print (One_level.print_with_cache ~cache)) levels) let print ppf t = @@ -299,6 +302,7 @@ let create ~resolver = current_level = One_level.create_empty Scope.initial; next_binding_time = Binding_time.earliest_var; defined_symbols = Symbol.Map.empty; + code_age_relation = Code_age_relation.empty; } let create_using_resolver_from t = create ~resolver:t.resolver @@ -739,6 +743,14 @@ let meet_equations_on_params t ~params ~param_types = t params param_types +let add_to_code_age_relation t ~newer ~older = + let code_age_relation = + Code_age_relation.add t.code_age_relation ~newer ~older + in + { t with code_age_relation; } + +let code_age_relation t = t.code_age_relation + let cut t ~unknown_if_defined_at_or_later_than:min_scope = let current_scope = current_scope t in let original_t = t in @@ -777,6 +789,7 @@ let cut t ~unknown_if_defined_at_or_later_than:min_scope = current_level; next_binding_time = t.next_binding_time; defined_symbols = t.defined_symbols; + code_age_relation = t.code_age_relation; } in let symbols_still_defined = diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.mli b/middle_end/flambda2.0/types/env/typing_env.rec.mli index 6702fe953a5e..853c47ee758e 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.mli +++ b/middle_end/flambda2.0/types/env/typing_env.rec.mli @@ -118,6 +118,10 @@ val earliest_alias_of_simple_satisfying -> Simple.t -> Simple.t option +val add_to_code_age_relation : t -> newer:Code_id.t -> older:Code_id.t -> t + +val code_age_relation : t -> Code_age_relation.t + (* CR mshinwell: Consider labelling arguments e.g. [definition_typing_env] *) val cut_and_n_way_join : t diff --git a/middle_end/flambda2.0/types/env/typing_env_extension.rec.ml b/middle_end/flambda2.0/types/env/typing_env_extension.rec.ml index a74b3acba4d3..fd385c1d8ad5 100644 --- a/middle_end/flambda2.0/types/env/typing_env_extension.rec.ml +++ b/middle_end/flambda2.0/types/env/typing_env_extension.rec.ml @@ -83,6 +83,11 @@ let meet env (t1 : t) (t2 : t) : t = in { abst; } +let rec n_way_meet env ts = + match ts with + | [] -> empty () + | t::ts -> meet env t (n_way_meet env ts) + let n_way_join ~initial_env_at_join envs_with_extensions : t * _ = let abst, extra_cse_bindings = let rec open_binders envs_with_extensions envs_with_levels = diff --git a/middle_end/flambda2.0/types/env/typing_env_extension.rec.mli b/middle_end/flambda2.0/types/env/typing_env_extension.rec.mli index 026c78194c50..7d484f9a9f49 100644 --- a/middle_end/flambda2.0/types/env/typing_env_extension.rec.mli +++ b/middle_end/flambda2.0/types/env/typing_env_extension.rec.mli @@ -45,6 +45,8 @@ val add_cse val meet : Meet_env.t -> t -> t -> t +val n_way_meet : Meet_env.t -> t list -> t + val n_way_join : initial_env_at_join:Typing_env.t (* CR mshinwell: Introduce "continuation use summary" type or somesuch *) diff --git a/middle_end/flambda2.0/types/flambda_type.ml b/middle_end/flambda2.0/types/flambda_type.ml deleted file mode 100644 index 0199bd25682f..000000000000 --- a/middle_end/flambda2.0/types/flambda_type.ml +++ /dev/null @@ -1,21 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2018 OCamlPro SAS *) -(* Copyright 2014--2018 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. *) -(* *) -(**************************************************************************) - -(** The type system of Flambda. *) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -include Flambda.Flambda_type diff --git a/middle_end/flambda2.0/types/flambda_type.mli b/middle_end/flambda2.0/types/flambda_type.mli index 0e83310a7aad..a7d8e4bd6f7e 100644 --- a/middle_end/flambda2.0/types/flambda_type.mli +++ b/middle_end/flambda2.0/types/flambda_type.mli @@ -5,8 +5,8 @@ (* Pierre Chambart, OCamlPro *) (* Mark Shinwell and Leo White, Jane Street Europe *) (* *) -(* Copyright 2013--2018 OCamlPro SAS *) -(* Copyright 2014--2018 Jane Street Group LLC *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 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 *) @@ -14,8 +14,485 @@ (* *) (**************************************************************************) -(** The type system of Flambda. *) +(** The interface to the Flambda type system. This is parameterised over + the expression language via [Code_id]. *) [@@@ocaml.warning "+a-4-30-40-41-42"] -include module type of struct include Flambda.Flambda_type end +(* CR mshinwell: Add invariant checks, including e.g. on the bodies of + functions in types. *) + +module Float = Numbers.Float_by_bit_pattern +module Int32 = Numbers.Int32 +module Int64 = Numbers.Int64 + +type t +type flambda_type = t + +val print : Format.formatter -> t -> unit + +val print_with_cache : cache:Printing_cache.t -> Format.formatter -> t -> unit + +val invariant : Invariant_env.t -> t -> unit + +val arity_of_list : t list -> Flambda_arity.t + +type typing_env +type typing_env_extension + +module Typing_env_extension : sig + type t = typing_env_extension + + val print : Format.formatter -> t -> unit + + val invariant : t -> unit + + val empty : unit -> t + + val one_equation : Name.t -> flambda_type -> t + + val add_or_replace_equation : t -> Name.t -> flambda_type -> t + + val add_cse + : t + -> Flambda_primitive.Eligible_for_cse.t + -> bound_to:Simple.t + -> t +end + +module Typing_env : sig + type t = typing_env + + val invariant : t -> unit + + val print : Format.formatter -> t -> unit + + val create : resolver:(Export_id.t -> flambda_type option) -> t + + val create_using_resolver_and_symbol_bindings_from : t -> t + + val resolver : t -> (Export_id.t -> flambda_type option) + + val var_domain : t -> Variable.Set.t + + val current_scope : t -> Scope.t + + val increment_scope : t -> t + + val add_definition : t -> Name_in_binding_pos.t -> Flambda_kind.t -> t + + val add_definitions_of_params : t -> params:Kinded_parameter.t list -> t + + val add_equation : t -> Name.t -> flambda_type -> t + + val add_equations_on_params + : t + -> params:Kinded_parameter.t list + -> param_types:flambda_type list + -> t + + val meet_equations_on_params + : t + -> params:Kinded_parameter.t list + -> param_types:flambda_type list + -> t + + val add_cse + : t + -> Flambda_primitive.Eligible_for_cse.t + -> bound_to:Simple.t + -> t + + val mem : t -> Name.t -> bool + + val find : t -> Name.t -> flambda_type + + val find_params : t -> Kinded_parameter.t list -> flambda_type list + + val find_cse : t -> Flambda_primitive.Eligible_for_cse.t -> Simple.t option + + val find_cse_rev + : t + -> bound_to:Simple.t + -> Flambda_primitive.Eligible_for_cse.t option + + val add_env_extension + : t + -> env_extension:Typing_env_extension.t + -> t + + val get_canonical_simple + : t + -> ?min_name_mode:Name_mode.t + -> Simple.t + -> Simple.t option Or_bottom.t + + val get_canonical_simple_with_kind + : t + -> ?min_name_mode:Name_mode.t + -> Simple.t + -> Simple.t option Or_bottom.t * Flambda_kind.t + + val add_to_code_age_relation : t -> newer:Code_id.t -> older:Code_id.t -> t + + val code_age_relation : t -> Code_age_relation.t + + val cut_and_n_way_join + : t + -> (t * Apply_cont_rewrite_id.t * Continuation_use_kind.t + * Variable.Set.t) list + -> unknown_if_defined_at_or_later_than:Scope.t + -> Typing_env_extension.t * Continuation_extra_params_and_args.t + + val free_variables_transitive : t -> flambda_type -> Variable.Set.t +end + +val meet : Typing_env.t -> t -> t -> (t * Typing_env_extension.t) Or_bottom.t + +val meet_shape + : Typing_env.t + -> t + -> shape:t + -> result_var:Var_in_binding_pos.t + -> result_kind:Flambda_kind.t + -> Typing_env_extension.t Or_bottom.t + +val join : Typing_env.t -> t -> t -> t + +(* CR mshinwell: Substitute out this alias once it's finalised *) +type 'a type_accessor = Typing_env.t -> 'a + +module Function_declaration_type : sig + module Inlinable : sig + type t + + val code_id : t -> Code_id.t + val param_arity : t -> Flambda_arity.t + val result_arity : t -> Flambda_arity.t + val stub : t -> bool + val dbg : t -> Debuginfo.t + val inline : t -> Inline_attribute.t + val is_a_functor : t -> bool + val recursive : t -> Recursive.t + val rec_info : t -> Rec_info.t + end + + module Non_inlinable : sig + type t + + val code_id : t -> Code_id.t + val param_arity : t -> Flambda_arity.t + val result_arity : t -> Flambda_arity.t + val recursive : t -> Recursive.t + end + + type t0 = private + | Inlinable of Inlinable.t + | Non_inlinable of Non_inlinable.t + + type t = t0 Or_unknown_or_bottom.t +end + +module Closures_entry : sig + type t + + val closure_var_types : t -> flambda_type Var_within_closure.Map.t +end + +(** This function takes a type [t] and an environment [env] that assigns types + to all the free names of [t]. It also takes an environment, called + [suitable_for], in which we would like to use [t]. The function + identifies which free names (if any) of [t] would be unbound in + [suitable_for]. For each such name a fresh variable is assigned and + irrelevantly bound in [suitable_for]; the returned type is like [t] + except that the names that would otherwise be unbound are replaced by + these fresh variables. The fresh variables are assigned types in the + returned environment extension on a best effort basis. *) +(* CR mshinwell: update comment *) +val make_suitable_for_environment + : t + -> Typing_env.t + -> suitable_for:Typing_env.t + -> bind_to:Name.t + -> Typing_env_extension.t + +val apply_rec_info : flambda_type -> Rec_info.t -> flambda_type Or_bottom.t + +(** Construct a bottom type of the given kind. *) +val bottom : Flambda_kind.t -> t + +(** Construct a top ("unknown") type of the given kind. *) +val unknown : Flambda_kind.t -> t + +(** Create an bottom type with the same kind as the given type. *) +val bottom_like : t -> t + +(** Create an "unknown" type with the same kind as the given type. *) +val unknown_like : t -> t + +val any_value : unit -> t + +val any_tagged_immediate : unit -> t +val any_tagged_bool : unit -> t + +val any_boxed_float : unit -> t +val any_boxed_int32 : unit -> t +val any_boxed_int64 : unit -> t +val any_boxed_nativeint : unit -> t + +val any_naked_immediate : unit -> t +val any_naked_float : unit -> t +val any_naked_int32 : unit -> t +val any_naked_int64 : unit -> t +val any_naked_nativeint : unit -> t + +(** Building of types representing tagged / boxed values from specified + constants. *) +val this_tagged_immediate : Immediate.t -> t +val this_boxed_float : Numbers.Float_by_bit_pattern.t -> t +val this_boxed_int32 : Int32.t -> t +val this_boxed_int64 : Int64.t -> t +val this_boxed_nativeint : Targetint.t -> t + +val these_tagged_immediates : Immediate.Set.t -> t +val these_boxed_floats : Numbers.Float_by_bit_pattern.Set.t -> t +val these_boxed_int32s : Int32.Set.t -> t +val these_boxed_int64s : Int64.Set.t -> t +val these_boxed_nativeints : Targetint.Set.t -> t + +(** Building of types representing untagged / unboxed values from + specified constants. *) +val this_naked_immediate : Immediate.t -> t +val this_naked_float : Numbers.Float_by_bit_pattern.t -> t +val this_naked_int32 : Int32.t -> t +val this_naked_int64 : Int64.t -> t +val this_naked_nativeint : Targetint.t -> t + +val these_naked_immediates : Immediate.Set.t -> t +val these_naked_floats : Numbers.Float_by_bit_pattern.Set.t -> t +val these_naked_int32s : Int32.Set.t -> t +val these_naked_int64s : Int64.Set.t -> t +val these_naked_nativeints : Targetint.Set.t -> t + +val boxed_float_alias_to : naked_float:Variable.t -> t +val boxed_int32_alias_to : naked_int32:Variable.t -> t +val boxed_int64_alias_to : naked_int64:Variable.t -> t +val boxed_nativeint_alias_to : naked_nativeint:Variable.t -> t + +val box_float : t -> t +val box_int32 : t -> t +val box_int64 : t -> t +val box_nativeint : t -> t + +val tagged_immediate_alias_to : naked_immediate:Variable.t -> t +val tag_immediate : t -> t + +val is_int_for_scrutinee : scrutinee:Simple.t -> t +val get_tag_for_block : block:Simple.t -> t + +(* CR mshinwell: decide on exact strategy for mutable blocks *) + +(** The type of an immutable block with a known tag, size and field types. *) +val immutable_block : Tag.t -> field_kind:Flambda_kind.t -> fields:t list -> t + +(** The type of an immutable block with at least [n] fields and an unknown + tag. The type of the [n - 1]th field is taken to be an [Equals] to the + given variable. *) +val immutable_block_with_size_at_least + : n:Targetint.OCaml.t + -> field_kind:Flambda_kind.t + -> field_n_minus_one:Variable.t + -> t + +val this_immutable_string : string -> t + +val mutable_string : size:int -> t + +(** Create a description of a function declaration whose code is known. *) +val create_inlinable_function_declaration + : code_id:Code_id.t + -> param_arity:Flambda_arity.t + -> result_arity:Flambda_arity.t + -> stub:bool + -> dbg:Debuginfo.t + -> inline:Inline_attribute.t + -> is_a_functor:bool + -> recursive:Recursive.t + -> rec_info:Rec_info.t + -> Function_declaration_type.t + +(** Create a description of a function declaration whose code is unknown. + Such declarations cannot be inlined, but can be direct called. *) +val create_non_inlinable_function_declaration + : code_id:Code_id.t + -> param_arity:Flambda_arity.t + -> result_arity:Flambda_arity.t + -> recursive:Recursive.t + -> Function_declaration_type.t + +val exactly_this_closure + : Closure_id.t + -> all_function_decls_in_set:Function_declaration_type.t Closure_id.Map.t + -> all_closures_in_set:t Closure_id.Map.t + -> all_closure_vars_in_set:flambda_type Var_within_closure.Map.t + -> flambda_type + +val at_least_the_closures_with_ids + : this_closure:Closure_id.t + -> Simple.t Closure_id.Map.t + -> flambda_type + +val closure_with_at_least_this_closure_var + : Var_within_closure.t + -> closure_element_var:Variable.t + -> flambda_type + +val array_of_length : length:flambda_type -> flambda_type + +(** Construct a type equal to the type of the given name. (The name + must be present in the given environment when calling e.g. [join].) *) +val alias_type_of : Flambda_kind.t -> Simple.t -> t + +(** Determine the (unique) kind of a type. *) +val kind : t -> Flambda_kind.t + +(** For each of the kinds in an arity, create an "unknown" type. *) +val unknown_types_from_arity : Flambda_arity.t -> t list + +(** For each of the kinds in an arity, create an "bottom" type. *) +val bottom_types_from_arity : Flambda_arity.t -> t list + +(** Whether the given type says that a term of that type can never be + constructed (in other words, it is [Invalid]). *) +val is_bottom : (t -> bool) type_accessor + +val type_for_const : Simple.Const.t -> t +val kind_for_const : Simple.Const.t -> Flambda_kind.t + +type 'a proof = private + | Proved of 'a + | Unknown + | Invalid + +type 'a proof_allowing_kind_mismatch = private + | Proved of 'a + | Unknown + | Invalid + | Wrong_kind + +(* CR mshinwell: Should remove "_equals_" from these names *) +val prove_equals_tagged_immediates + : Typing_env.t + -> t + -> Immediate.Set.t proof + +val prove_naked_immediates + : Typing_env.t + -> t + -> Immediate.Set.t proof + +val prove_equals_single_tagged_immediate + : Typing_env.t + -> t + -> Immediate.t proof + +val prove_naked_floats + : Typing_env.t + -> t + -> Numbers.Float_by_bit_pattern.Set.t proof + +val prove_naked_int32s : Typing_env.t -> t -> Numbers.Int32.Set.t proof + +val prove_naked_int64s : Typing_env.t -> t -> Numbers.Int64.Set.t proof + +val prove_naked_nativeints : Typing_env.t -> t -> Targetint.Set.t proof + +val prove_is_a_tagged_immediate + : Typing_env.t + -> t + -> unit proof_allowing_kind_mismatch + +val prove_is_a_boxed_float + : Typing_env.t + -> t + -> unit proof_allowing_kind_mismatch + +val prove_is_a_boxed_int32 + : Typing_env.t + -> t + -> unit proof_allowing_kind_mismatch + +val prove_is_a_boxed_int64 + : Typing_env.t + -> t + -> unit proof_allowing_kind_mismatch + +val prove_is_a_boxed_nativeint + : Typing_env.t + -> t + -> unit proof_allowing_kind_mismatch + +val prove_boxed_floats : Typing_env.t -> t -> Float.Set.t proof +val prove_boxed_int32s : Typing_env.t -> t -> Numbers.Int32.Set.t proof +val prove_boxed_int64s : Typing_env.t -> t -> Numbers.Int64.Set.t proof +val prove_boxed_nativeints : Typing_env.t -> t -> Targetint.Set.t proof + +val prove_tags_and_sizes + : Typing_env.t + -> t + -> Targetint.OCaml.t Tag.Map.t proof + +val prove_unique_tag_and_size + : Typing_env.t + -> t + -> (Tag.t * Targetint.OCaml.t) proof_allowing_kind_mismatch + +val prove_is_int : Typing_env.t -> t -> bool proof + +(** Prove that the given type, of kind [Value], is a closures type + describing exactly one closure. The function declaration type corresponding + to such closure is returned together with its closure ID, if it is + known. *) +val prove_single_closures_entry + : Typing_env.t + -> t + -> (Closure_id.t * Closures_entry.t * Function_declaration_type.t) proof + +val prove_single_closures_entry' + : Typing_env.t + -> t + -> (Closure_id.t * Closures_entry.t * Function_declaration_type.t) + proof_allowing_kind_mismatch + +val prove_strings : Typing_env.t -> t -> String_info.Set.t proof + +type var_or_symbol_or_tagged_immediate = private + | Var of Variable.t + | Symbol of Symbol.t + | Tagged_immediate of Immediate.t + +type to_lift = (* private *) (* CR mshinwell: resurrect *) + | Immutable_block of + Tag.Scannable.t * (var_or_symbol_or_tagged_immediate list) + | Boxed_float of Float.t + | Boxed_int32 of Int32.t + | Boxed_int64 of Int64.t + | Boxed_nativeint of Targetint.t + +type reification_result = private + | Lift of to_lift (* CR mshinwell: rename? *) + | Lift_set_of_closures of { + closure_id : Closure_id.t; + function_decls : Function_declaration_type.Inlinable.t Closure_id.Map.t; + closure_vars : Simple.t Var_within_closure.Map.t; + } + | Simple of Simple.t + | Cannot_reify + | Invalid + +val reify + : ?allowed_free_vars:Variable.Set.t + -> Typing_env.t + -> min_name_mode:Name_mode.t + -> t + -> reification_result diff --git a/middle_end/flambda2.0/types/flambda_type0.mli b/middle_end/flambda2.0/types/flambda_type0.mli deleted file mode 100644 index 89b021375092..000000000000 --- a/middle_end/flambda2.0/types/flambda_type0.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2019 OCamlPro SAS *) -(* Copyright 2014--2019 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. *) -(* *) -(**************************************************************************) - -(** The type system of Flambda. *) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -(** The type system is parameterised over the expression language. *) -module Make (Function_declaration : Term_language_function_declaration.S) - : Type_system_intf.S - with type term_language_function_declaration := Function_declaration.t diff --git a/middle_end/flambda2.0/types/structures/closures_entry.rec.ml b/middle_end/flambda2.0/types/structures/closures_entry.rec.ml index 8595fea5cc0c..ac62c0b52026 100644 --- a/middle_end/flambda2.0/types/structures/closures_entry.rec.ml +++ b/middle_end/flambda2.0/types/structures/closures_entry.rec.ml @@ -16,12 +16,15 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] +module FDT = Function_declaration_type +module PC = Product.Closure_id_indexed +module PV = Product.Var_within_closure_indexed module TEE = Typing_env_extension type t = { - function_decls : Function_declaration_type.t Or_unknown.t Closure_id.Map.t; - closure_types : Product.Closure_id_indexed.t; - closure_var_types : Product.Var_within_closure_indexed.t; + function_decls : FDT.t Closure_id.Map.t; + closure_types : PC.t; + closure_var_types : PV.t; } let create ~function_decls ~closure_types ~closure_var_types = @@ -32,10 +35,15 @@ let create ~function_decls ~closure_types ~closure_var_types = let create_bottom () = { function_decls = Closure_id.Map.empty; - closure_types = Product.Closure_id_indexed.create_bottom (); - closure_var_types = Product.Var_within_closure_indexed.create_bottom (); + closure_types = PC.create_bottom (); + closure_var_types = PV.create_bottom (); } +let is_bottom { function_decls; closure_types; closure_var_types; } = + Closure_id.Map.is_empty function_decls + && PC.is_bottom closure_types + && PV.is_bottom closure_var_types + let print_with_cache ~cache ppf { function_decls; closure_types; closure_var_types; } = Format.fprintf ppf @@ -44,12 +52,9 @@ let print_with_cache ~cache ppf @[(closure_types@ %a)@]@ \ @[(closure_var_types@ %a)@]\ )@]" - (Closure_id.Map.print - (Or_unknown.print - (Function_declaration_type.print_with_cache ~cache))) - function_decls - (Product.Closure_id_indexed.print_with_cache ~cache) closure_types - (Product.Var_within_closure_indexed.print_with_cache ~cache) closure_var_types + (Closure_id.Map.print (FDT.print_with_cache ~cache)) function_decls + (PC.print_with_cache ~cache) closure_types + (PV.print_with_cache ~cache) closure_var_types let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t @@ -60,17 +65,16 @@ let widen t ~to_match = in let function_decls = Closure_id.Set.fold (fun closure_id function_decls -> - Closure_id.Map.add closure_id Or_unknown.Unknown function_decls) + Closure_id.Map.add closure_id Or_unknown_or_bottom.Unknown + function_decls) missing_function_decls t.function_decls in let closure_types = - Product.Closure_id_indexed.widen t.closure_types - ~to_match:to_match.closure_types + PC.widen t.closure_types ~to_match:to_match.closure_types in let closure_var_types = - Product.Var_within_closure_indexed.widen t.closure_var_types - ~to_match:to_match.closure_var_types + PV.widen t.closure_var_types ~to_match:to_match.closure_var_types in { function_decls; closure_types; @@ -91,160 +95,102 @@ struct { function_decls = function_decls2; closure_types = closure_types2; closure_var_types = closure_var_types2; - } = - let meet_or_join_function_decl - (function_decl1 : Function_declaration_type.t Or_unknown.t) - (function_decl2 : Function_declaration_type.t Or_unknown.t) - : Function_declaration_type.t Or_unknown.t = - match function_decl1, function_decl2 with - | Unknown, Unknown -> Unknown - | Known _, Unknown -> - begin match E.op () with - | Join -> Unknown - | Meet -> function_decl1 - end - | Unknown, Known _ -> - begin match E.op () with - | Join -> Unknown - | Meet -> function_decl2 - end - | Known decl1, Known decl2 -> - match decl1, decl2 with - | Non_inlinable { - param_arity = param_arity1; result_arity = result_arity1; - recursive = recursive1; - }, Non_inlinable { - param_arity = param_arity2; result_arity = result_arity2; - recursive = recursive2; - } -> - (* CR mshinwell: Are fatal errors right here? Given the arbitrary - choice below, it would seem so, but unsure. Also, the error - message is currently poor. *) - if Flambda_arity.equal param_arity1 param_arity2 - && Flambda_arity.equal result_arity1 result_arity2 - && Recursive.equal recursive1 recursive2 - then - Known decl1 - else - Misc.fatal_error "Mismatched Non_inlinable arities" - | Non_inlinable _ , Inlinable _ - | Inlinable _, Non_inlinable _ -> - (* CR mshinwell: This should presumably return [Non_inlinable] if - the arities match. *) - Unknown - | Inlinable { function_decl = decl1; rec_info = _rec_info1; }, - Inlinable { function_decl = decl2; rec_info = _rec_info2; } -> - (* CR mshinwell: Assertions about other properties of - [decl1] versus [decl2]? *) - (* CR mshinwell: What about [rec_info]? *) - let module TFD = Term_language_function_declaration in - match E.op () with - | Join -> - (* CR mshinwell: As mentioned in [Function_declaration], [Code_id] - is a misnomer at present. *) - if Code_id.equal (TFD.code_id decl1) (TFD.code_id decl2) - then function_decl1 - else Unknown - | Meet -> - (* We can arbitrarily pick one of the functions, since they must - both behave in the same way, even if we cannot prove it. *) - function_decl1 - in + } : _ Or_bottom.t = + let env_extensions = ref [] in let function_decls = Closure_id.Map.merge (fun _closure_id func_decl1 func_decl2 -> match func_decl1, func_decl2 with | None, None | Some _, None | None, Some _ -> None | Some func_decl1, Some func_decl2 -> - let func_decl = meet_or_join_function_decl func_decl1 func_decl2 in - Some func_decl) + match E.switch FDT.meet FDT.join env func_decl1 func_decl2 with + | Bottom -> None + | Ok (func_decl, env_extension) -> + env_extensions := env_extension :: !env_extensions; + Some func_decl) function_decls1 function_decls2 in - let closure_types = - E.switch Product.Closure_id_indexed.meet Product.Closure_id_indexed.join - env closure_types1 closure_types2 - in - let closure_var_types = - E.switch Product.Var_within_closure_indexed.meet Product.Var_within_closure_indexed.join - env closure_var_types1 closure_var_types2 - in - Or_bottom.both closure_types closure_var_types - ~f:(fun (closure_types, env_extension1) - (closure_var_types, env_extension2) -> - let closures_entry = - { function_decls; - closure_types; - closure_var_types; - } - in - let env_extension = - (* XXX This should use the proper environments from both sides, no? - See if we can avoid needing that *) - let left_env = Meet_env.env env in - let right_env = Meet_env.env env in - (* CR mshinwell: Move to [TEE]. Also used in [Type_of_kind_value0] *) - let join_extensions env ext1 ext2 = - let env_extension, _ = - TEE.n_way_join ~initial_env_at_join:env [ - left_env, Apply_cont_rewrite_id.create (), Non_inlinable, - Variable.Set.empty, ext1; - right_env, Apply_cont_rewrite_id.create (), Non_inlinable, - Variable.Set.empty, ext2; - ] - in - env_extension + if Closure_id.Map.is_empty function_decls then Bottom + else + Or_bottom.both + (E.switch PC.meet PC.join env closure_types1 closure_types2) + (E.switch PV.meet PV.join env closure_var_types1 closure_var_types2) + ~f:(fun (closure_types, env_extension1) + (closure_var_types, env_extension2) -> + let closures_entry = + { function_decls; + closure_types; + closure_var_types; + } in - E.switch0 TEE.meet join_extensions env - env_extension1 env_extension2 - in - closures_entry, env_extension) + let env_extension = + match E.op () with + | Join -> TEE.empty () + | Meet -> + TEE.n_way_meet env + (env_extension1 :: env_extension2 :: !env_extensions) + in + closures_entry, env_extension) end module Meet = Make_meet_or_join (Lattice_ops.For_meet) module Join = Make_meet_or_join (Lattice_ops.For_join) let meet env t1 t2 : _ Or_bottom.t = - (* CR mshinwell: Move the code to here *) - Meet.meet_or_join env t1 t2 + match Meet.meet_or_join env t1 t2 with + | Bottom -> Bottom + | Ok (t, env_extension) -> + if is_bottom t then Bottom + else Ok (t, env_extension) let join env t1 t2 = let env = Meet_env.create env in match Join.meet_or_join env t1 t2 with - | Ok (t, _env_extension) -> t + | Ok (t, env_extension) -> + assert (TEE.is_empty env_extension); + t | Bottom -> create_bottom () let apply_name_permutation { function_decls; closure_types; closure_var_types; } perm = - { function_decls; (* XXX is this correct? *) - closure_types = - Product.Closure_id_indexed.apply_name_permutation closure_types perm; - closure_var_types = - Product.Var_within_closure_indexed.apply_name_permutation closure_var_types perm; + { function_decls = + Closure_id.Map.map_sharing (fun function_decl -> + FDT.apply_name_permutation function_decl perm) + function_decls; + closure_types = PC.apply_name_permutation closure_types perm; + closure_var_types = PV.apply_name_permutation closure_var_types perm; } -let free_names { function_decls = _; closure_types; closure_var_types; } = - Name_occurrences.union - (Product.Closure_id_indexed.free_names closure_types) - (Product.Var_within_closure_indexed.free_names closure_var_types) +let free_names { function_decls; closure_types; closure_var_types; } = + let function_decls_free_names = + Closure_id.Map.fold (fun _closure_id function_decl free_names -> + Name_occurrences.union free_names (FDT.free_names function_decl)) + function_decls + Name_occurrences.empty + in + Name_occurrences.union function_decls_free_names + (Name_occurrences.union (PC.free_names closure_types) + (PV.free_names closure_var_types)) + +let closure_var_types t = PV.to_map t.closure_var_types + +let find_function_declaration t closure_id : _ Or_bottom.t = + match Closure_id.Map.find closure_id t.function_decls with + | exception Not_found -> Bottom + | func_decl -> Ok func_decl let map_function_decl_types { function_decls; closure_types; closure_var_types; } - ~(f : Function_declaration_type.t - -> Function_declaration_type.t Or_bottom.t) - : _ Or_bottom.t = + ~(f : FDT.t -> FDT.t Or_bottom.t) : _ Or_bottom.t = (* CR mshinwell: This needs to deal with [closure_types] too. Deferring until new approach for [Rec_info] is sorted out. *) let bottom = ref false in let function_decls = - Closure_id.Map.map (fun (function_decl : _ Or_unknown.t) : _ Or_unknown.t -> - match function_decl with - | Unknown -> Unknown - | Known function_decl -> - match f function_decl with - | Bottom -> - bottom := true; - Unknown - | Ok function_decl -> - Known function_decl) + Closure_id.Map.map (fun function_decl -> + match f function_decl with + | Ok function_decl -> function_decl + | Bottom -> + bottom := true; + function_decl) function_decls in if !bottom then Bottom @@ -256,16 +202,3 @@ let map_function_decl_types } in Ok t - -let closure_var_types t = - Product.Var_within_closure_indexed.to_map t.closure_var_types - -let find_function_declaration t closure_id = - match Closure_id.Map.find closure_id t.function_decls with - | exception Not_found -> - (* CR mshinwell: Add [invariant] check. *) - Misc.fatal_errorf "[Closures_entry] doesn't contain function declaration \ - for closure ID %a:@ %a" - Closure_id.print closure_id - print t - | func_decl -> func_decl diff --git a/middle_end/flambda2.0/types/structures/closures_entry.rec.mli b/middle_end/flambda2.0/types/structures/closures_entry.rec.mli index b43428672a6c..7f8bcf5b3df4 100644 --- a/middle_end/flambda2.0/types/structures/closures_entry.rec.mli +++ b/middle_end/flambda2.0/types/structures/closures_entry.rec.mli @@ -19,7 +19,7 @@ type t val create - : function_decls : Function_declaration_type.t Or_unknown.t Closure_id.Map.t + : function_decls : Function_declaration_type.t Closure_id.Map.t -> closure_types : Product.Closure_id_indexed.t -> closure_var_types : Product.Var_within_closure_indexed.t -> t @@ -37,7 +37,7 @@ val map_function_decl_types val find_function_declaration : t -> Closure_id.t - -> Function_declaration_type.t Or_unknown.t + -> Function_declaration_type.t Or_bottom.t val closure_var_types : t -> Type_grammar.t Var_within_closure.Map.t diff --git a/middle_end/flambda2.0/types/structures/code_age_relation.ml b/middle_end/flambda2.0/types/structures/code_age_relation.ml new file mode 100644 index 000000000000..2a25ba763fa6 --- /dev/null +++ b/middle_end/flambda2.0/types/structures/code_age_relation.ml @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2019 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-30-40-41-42"] + +(* If a value of type [t] maps [id1] to [id2], it means that [id1] is a + newer version of [id2]. The relation forms a partial order. + These relations are expected to be small in the majority of cases. *) +type t = Code_id.t Code_id.Map.t + +let print ppf t = Code_id.Map.print Code_id.print ppf t + +let empty = Code_id.Map.empty + +(* CR mshinwell: There should be a well-formedness check during [add], otherwise + the functions below may not work correctly. *) + +let add t ~newer ~older = Code_id.Map.add newer older t + +let rec all_ids_up_to_root t id = + match Code_id.Map.find id t with + | exception Not_found -> Code_id.Set.empty + | older -> Code_id.Set.add older (all_ids_up_to_root t older) + +let num_ids_up_to_root t id = + Code_id.Set.cardinal (all_ids_up_to_root t id) + +(* CR mshinwell: There are no doubt better implementations than the below. *) + +let meet t id1 id2 : _ Or_bottom.t = + (* Whichever of [id1] and [id2] is newer (or the same as the other one), + in the case where they are comparable; otherwise bottom. *) + if Code_id.equal id1 id2 then Ok id1 + else + let id1_to_root = all_ids_up_to_root t id1 in + let id2_to_root = all_ids_up_to_root t id2 in + if Code_id.Set.mem id1 id2_to_root then Ok id2 + else if Code_id.Set.mem id2 id1_to_root then Ok id1 + else Bottom + +let join t id1 id2 : _ Or_unknown.t = + (* Lowest ("newest") common ancestor, if such exists. *) + if Code_id.equal id1 id2 then Known id1 + else + let id1_to_root = all_ids_up_to_root t id1 in + let id2_to_root = all_ids_up_to_root t id2 in + let shared_ids = Code_id.Set.inter id1_to_root id2_to_root in + if Code_id.Set.is_empty shared_ids then Unknown + else + let newest_shared_id, _ = + shared_ids + |> Code_id.Set.elements + |> List.map (fun id -> id, num_ids_up_to_root t id) + |> List.sort (fun (_, len1) (_, len2) -> - (Int.compare len1 len2)) + |> List.hd + in + Known newest_shared_id + +type at_most_one_newer = + | No_newer_version + | Exactly_one_newer_version of Code_id.t + | More_than_one_newer_version + +let has_at_most_one_newer_version t id = + let newer_to_id = + Code_id.Map.filter (fun _newer older -> Code_id.equal older id) t + in + if Code_id.Map.is_empty newer_to_id then No_newer_version + else + match Code_id.Map.get_singleton newer_to_id with + | Some (newer, id') -> + assert (Code_id.equal id id'); + Exactly_one_newer_version newer + | None -> More_than_one_newer_version + +let rec newer_versions_form_linear_chain t id = + match has_at_most_one_newer_version t id with + | No_newer_version -> true + | Exactly_one_newer_version id -> newer_versions_form_linear_chain t id + | More_than_one_newer_version -> false diff --git a/middle_end/flambda2.0/types/structures/code_age_relation.mli b/middle_end/flambda2.0/types/structures/code_age_relation.mli new file mode 100644 index 000000000000..55f2a6b8b628 --- /dev/null +++ b/middle_end/flambda2.0/types/structures/code_age_relation.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2019 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-30-40-41-42"] + +(** Tracking of new versions of code such that it can be determined, for + any two pieces of code, which one is newer (or that the pieces of code + are unrelated). *) + +type t + +val print : Format.formatter -> t -> unit + +val empty : t + +val add : t -> newer:Code_id.t -> older:Code_id.t -> t + +(** [meet] calculates which of the given pieces of code is older, or + identifies that the pieces of code are unrelated. *) +val meet : t -> Code_id.t -> Code_id.t -> Code_id.t Or_bottom.t + +(** [join] calculates which of the given pieces of code is newer, or + identifies that the pieces of code are unrelated. *) +val join : t -> Code_id.t -> Code_id.t -> Code_id.t Or_unknown.t + +(** Returns [true] iff there is no branching in the elements of the code age + relation newer than the given code ID. *) +val newer_versions_form_linear_chain : t -> Code_id.t -> bool diff --git a/middle_end/flambda2.0/types/structures/function_declaration_type.rec.ml b/middle_end/flambda2.0/types/structures/function_declaration_type.rec.ml index 9bb2ac21ab2b..4d5852b27449 100644 --- a/middle_end/flambda2.0/types/structures/function_declaration_type.rec.ml +++ b/middle_end/flambda2.0/types/structures/function_declaration_type.rec.ml @@ -16,41 +16,296 @@ [@@@ocaml.warning "+a-30-40-41-42"] -type inlinable = { - function_decl : Term_language_function_declaration.t; - rec_info : Rec_info.t; -} - -type t = - | Non_inlinable of { - param_arity : Flambda_arity.t; - result_arity : Flambda_arity.t; - recursive : Recursive.t; - } - | Inlinable of inlinable +module TE = Typing_env +module TEE = Typing_env_extension + +module Inlinable = struct + type t = { + code_id : Code_id.t; + param_arity : Flambda_arity.t; + result_arity : Flambda_arity.t; + stub : bool; + dbg : Debuginfo.t; + inline : Inline_attribute.t; + is_a_functor : bool; + recursive : Recursive.t; + rec_info : Rec_info.t; + } -let print_inlinable_with_cache ~cache ppf - ({ function_decl; rec_info; } as decl) = - Printing_cache.with_cache cache ppf "inlinable_fundecl" decl (fun ppf () -> + let print ppf { code_id; param_arity; result_arity; stub; dbg; + inline; is_a_functor; recursive; rec_info; } = Format.fprintf ppf - "@[(Inlinable@ \ - @[(function_decl@ %a)@]@ \ + "@[(Inlinable@ \ + @[(code_id@ %a)@]@ \ + @[(param_arity@ %a)@]@ \ + @[(result_arity@ %a)@] \ + @[(stub@ %b)@] \ + @[(dbg@ %a)@] \ + @[(inline@ %a)@] \ + @[(is_a_functor@ %b)@] \ + @[(recursive@ %a)@]@ \ @[(rec_info@ %a)@]\ )@]" - Term_language_function_declaration.print_compact function_decl - Rec_info.print rec_info) + Code_id.print code_id + Flambda_arity.print param_arity + Flambda_arity.print result_arity + stub + Debuginfo.print_compact dbg + Inline_attribute.print inline + is_a_functor + Recursive.print recursive + Rec_info.print rec_info -let print_with_cache ~cache ppf t = - match t with - | Inlinable decl -> - print_inlinable_with_cache ~cache ppf decl - | Non_inlinable { param_arity; result_arity; recursive; } -> + let create ~code_id ~param_arity ~result_arity ~stub ~dbg ~inline + ~is_a_functor ~recursive ~rec_info = + { code_id; + param_arity; + result_arity; + stub; + dbg; + inline; + is_a_functor; + recursive; + rec_info; + } + + let code_id t = t.code_id + let param_arity t = t.param_arity + let result_arity t = t.result_arity + let stub t = t.stub + let dbg t = t.dbg + let inline t = t.inline + let is_a_functor t = t.is_a_functor + let recursive t = t.recursive + let rec_info t = t.rec_info +end + +module Non_inlinable = struct + type t = { + code_id : Code_id.t; + param_arity : Flambda_arity.t; + result_arity : Flambda_arity.t; + recursive : Recursive.t; + } + + let print ppf { code_id; param_arity; result_arity; recursive; } = Format.fprintf ppf "@[(Non_inlinable@ \ - @[(param_arity@ %a)@]@ \ - @[(result_arity@ %a)@] \ - @[(recursive@ %a)@]\ - )@]" + @[(code_id@ %a)@]@ \ + @[(param_arity@ %a)@]@ \ + @[(result_arity@ %a)@] \ + @[(recursive@ %a)@]\ + )@]" + Code_id.print code_id Flambda_arity.print param_arity Flambda_arity.print result_arity Recursive.print recursive + + let create ~code_id ~param_arity ~result_arity ~recursive = + { code_id; + param_arity; + result_arity; + recursive; + } + + let code_id t = t.code_id + let param_arity t = t.param_arity + let result_arity t = t.result_arity + let recursive t = t.recursive +end + +type t0 = + | Inlinable of Inlinable.t + | Non_inlinable of Non_inlinable.t + +type t = t0 Or_unknown_or_bottom.t + +let print_t0 ppf t0 = + match t0 with + | Inlinable inlinable -> Inlinable.print ppf inlinable + | Non_inlinable non_inlinable -> Non_inlinable.print ppf non_inlinable + +let print_with_cache ~cache:_ ppf t = + Or_unknown_or_bottom.print print_t0 ppf t + +let print ppf t = + Or_unknown_or_bottom.print print_t0 ppf t + +let free_names (t : t) = + match t with + | Bottom | Unknown -> Name_occurrences.empty + | Ok (Inlinable { code_id; param_arity = _; result_arity = _; stub = _; + dbg = _; inline = _; is_a_functor = _; recursive = _; + rec_info = _; }) + | Ok (Non_inlinable { code_id; param_arity = _; result_arity = _; + recursive = _; }) -> + Name_occurrences.add_code_id Name_occurrences.empty code_id + Name_mode.in_types + +let apply_name_permutation t _perm = t + +module Make_meet_or_join + (E : Lattice_ops_intf.S + with type meet_env := Meet_env.t + with type typing_env := Typing_env.t + with type typing_env_extension := Typing_env_extension.t) = +struct + let meet_or_join env (t1 : t) (t2 : t) : (t * TEE.t) Or_bottom.t = + match t1, t2 with + (* CR mshinwell: Try to factor out "Or_unknown_or_bottom" handling from here + and elsewhere *) + | Bottom, Bottom -> Ok (Bottom, TEE.empty ()) + | Bottom, _ -> + begin match E.op () with + | Meet -> Ok (Bottom, TEE.empty ()) + | Join -> Ok (t2, TEE.empty ()) + end + | _, Bottom -> + begin match E.op () with + | Meet -> Ok (Bottom, TEE.empty ()) + | Join -> Ok (t1, TEE.empty ()) + end + | Unknown, Unknown -> Ok (Unknown, TEE.empty ()) + | Unknown, _ -> + begin match E.op () with + | Meet -> Ok (t2, TEE.empty ()) + | Join -> Ok (Unknown, TEE.empty ()) + end + | _, Unknown -> + begin match E.op () with + | Meet -> Ok (t1, TEE.empty ()) + | Join -> Ok (Unknown, TEE.empty ()) + end + | Ok (Non_inlinable { + code_id = code_id1; + param_arity = param_arity1; result_arity = result_arity1; + recursive = recursive1; + }), Ok (Non_inlinable { + code_id = code_id2; + param_arity = param_arity2; result_arity = result_arity2; + recursive = recursive2; + }) -> + let typing_env = Meet_env.env env in + let code_age_rel = TE.code_age_relation typing_env in + let check_other_things_and_return code_id : (t * TEE.t) Or_bottom.t = + assert (Flambda_arity.equal param_arity1 param_arity2); + assert (Flambda_arity.equal result_arity1 result_arity2); + assert (Recursive.equal recursive1 recursive2); + Ok (Ok (Non_inlinable { + code_id; + param_arity = param_arity1; + result_arity = result_arity1; + recursive = recursive1; + }), + TEE.empty ()) + in + begin match E.op () with + | Meet -> + begin match Code_age_relation.meet code_age_rel code_id1 code_id2 with + | Ok code_id -> check_other_things_and_return code_id + | Bottom -> Bottom + end + | Join -> + begin match Code_age_relation.join code_age_rel code_id1 code_id2 with + | Known code_id -> check_other_things_and_return code_id + | Unknown -> Ok (Unknown, TEE.empty ()) + end + end + | Ok (Non_inlinable _), Ok (Inlinable _) + | Ok (Inlinable _), Ok (Non_inlinable _) -> + (* CR mshinwell: This should presumably return [Non_inlinable] if + the arities match. *) + Ok (Unknown, TEE.empty ()) + | Ok (Inlinable { + code_id = code_id1; + param_arity = param_arity1; + result_arity = result_arity1; + stub = stub1; + dbg = dbg1; + inline = inline1; + is_a_functor = is_a_functor1; + recursive = recursive1; + rec_info = _rec_info1; + }), + Ok (Inlinable { + code_id = code_id2; + param_arity = param_arity2; + result_arity = result_arity2; + stub = stub2; + dbg = dbg2; + inline = inline2; + is_a_functor = is_a_functor2; + recursive = recursive2; + rec_info = _rec_info2; + }) -> + let typing_env = Meet_env.env env in + let code_age_rel = TE.code_age_relation typing_env in + let check_other_things_and_return code_id : (t * TEE.t) Or_bottom.t = + assert (Flambda_arity.equal param_arity1 param_arity2); + assert (Flambda_arity.equal result_arity1 result_arity2); + assert (Bool.equal stub1 stub2); + assert (Int.equal (Debuginfo.compare dbg1 dbg2) 0); + assert (Inline_attribute.equal inline1 inline2); + assert (Bool.equal is_a_functor1 is_a_functor2); + assert (Recursive.equal recursive1 recursive2); + Ok (Ok (Inlinable { + code_id; + param_arity = param_arity1; + result_arity = result_arity1; + stub = stub1; + dbg = dbg1; + inline = inline1; + is_a_functor = is_a_functor1; + recursive = recursive1; + rec_info = _rec_info1; + }), + TEE.empty ()) + in + (* CR mshinwell: What about [rec_info]? *) + match E.op () with + | Meet -> + begin match Code_age_relation.meet code_age_rel code_id1 code_id2 with + | Ok code_id -> check_other_things_and_return code_id + | Bottom -> Bottom + end + | Join -> + begin match Code_age_relation.join code_age_rel code_id1 code_id2 with + | Known code_id -> check_other_things_and_return code_id + | Unknown -> Ok (Unknown, TEE.empty ()) + end +end + +module Meet = Make_meet_or_join (Lattice_ops.For_meet) +module Join = Make_meet_or_join (Lattice_ops.For_join) + +let meet env t1 t2 : _ Or_bottom.t = + match Meet.meet_or_join env t1 t2 with + | Bottom | Ok (Bottom, _) -> Bottom + | Ok ((Ok _ | Unknown) as t, env_extension) -> Ok (t, env_extension) + +let join env t1 t2 : t = + let env = Meet_env.create env in + match Join.meet_or_join env t1 t2 with + | Bottom | Ok (Bottom, _) -> Bottom + | Ok ((Ok _ | Unknown) as t, env_extension) -> + assert (TEE.is_empty env_extension); + t + +let apply_rec_info (t : t) rec_info : t Or_bottom.t = + match t with + | Ok (Inlinable { code_id; param_arity; result_arity; stub; dbg; inline; + is_a_functor; recursive; rec_info = rec_info'; }) -> + let rec_info = Rec_info.merge rec_info' ~newer:rec_info in + Ok (Ok (Inlinable { code_id; + param_arity; + result_arity; + stub; + dbg; + inline; + is_a_functor; + recursive; + rec_info; + })) + | Ok (Non_inlinable { code_id = _; param_arity = _; result_arity = _; + recursive = _; }) -> Ok t + | Unknown | Bottom -> Ok t diff --git a/middle_end/flambda2.0/types/structures/function_declaration_type.rec.mli b/middle_end/flambda2.0/types/structures/function_declaration_type.rec.mli index 1fe8020126f1..a5fe1e8c2900 100644 --- a/middle_end/flambda2.0/types/structures/function_declaration_type.rec.mli +++ b/middle_end/flambda2.0/types/structures/function_declaration_type.rec.mli @@ -16,19 +16,61 @@ [@@@ocaml.warning "+a-30-40-41-42"] -type inlinable = { - function_decl : Term_language_function_declaration.t; - rec_info : Rec_info.t; -} - -type t = - | Non_inlinable of { - param_arity : Flambda_arity.t; - result_arity : Flambda_arity.t; - recursive : Recursive.t; - } - | Inlinable of inlinable +module Inlinable : sig + type t + + val create + : code_id:Code_id.t + -> param_arity:Flambda_arity.t + -> result_arity:Flambda_arity.t + -> stub:bool + -> dbg:Debuginfo.t + -> inline:Inline_attribute.t + -> is_a_functor:bool + -> recursive:Recursive.t + -> rec_info:Rec_info.t + -> t + + val code_id : t -> Code_id.t + val param_arity : t -> Flambda_arity.t + val result_arity : t -> Flambda_arity.t + val stub : t -> bool + val dbg : t -> Debuginfo.t + val inline : t -> Inline_attribute.t + val is_a_functor : t -> bool + val recursive : t -> Recursive.t + val rec_info : t -> Rec_info.t +end + +module Non_inlinable : sig + type t + + val create + : code_id:Code_id.t + -> param_arity:Flambda_arity.t + -> result_arity:Flambda_arity.t + -> recursive:Recursive.t + -> t + + val code_id : t -> Code_id.t + val param_arity : t -> Flambda_arity.t + val result_arity : t -> Flambda_arity.t + val recursive : t -> Recursive.t +end + +type t0 = + | Inlinable of Inlinable.t + | Non_inlinable of Non_inlinable.t + +type t = t0 Or_unknown_or_bottom.t (* CR mshinwell: Add [create] and make [private]. *) -val print_with_cache : cache:Printing_cache.t -> Format.formatter -> t -> unit +include Type_structure_intf.S + with type t := t + with type flambda_type := Type_grammar.t + with type typing_env := Typing_env.t + with type meet_env := Meet_env.t + with type typing_env_extension := Typing_env_extension.t + +val apply_rec_info : t -> Rec_info.t -> t Or_bottom.t diff --git a/middle_end/flambda2.0/types/structures/product.rec.ml b/middle_end/flambda2.0/types/structures/product.rec.ml index 9211cb39be39..0dc06a23b2e4 100644 --- a/middle_end/flambda2.0/types/structures/product.rec.ml +++ b/middle_end/flambda2.0/types/structures/product.rec.ml @@ -46,6 +46,8 @@ module Make (Index : Identifiable.S) = struct { components_by_index = Index.Map.empty; } + let is_bottom t = Index.Map.is_empty t.components_by_index + let indexes t = Index.Map.keys t.components_by_index let width t = diff --git a/middle_end/flambda2.0/types/structures/product_intf.ml b/middle_end/flambda2.0/types/structures/product_intf.ml index 172598d6f3a8..9433f0163a59 100644 --- a/middle_end/flambda2.0/types/structures/product_intf.ml +++ b/middle_end/flambda2.0/types/structures/product_intf.ml @@ -27,9 +27,10 @@ module type S = sig (** Create a product value given the indexes with associated components. *) val create : flambda_type Index.Map.t -> t - (* CR mshinwell: Change all of these to just [bottom : t]? *) val create_bottom : unit -> t + val is_bottom : t -> bool + (** Widen the product by adding as many fields, after any existing fields, so that the product has the same number of fields as [to_match]. If the supplied product already has at least that many fields then it is diff --git a/middle_end/flambda2.0/types/template/flambda_type.templ.ml b/middle_end/flambda2.0/types/template/flambda_type.templ.ml new file mode 100644 index 000000000000..b3bccb7eb0bf --- /dev/null +++ b/middle_end/flambda2.0/types/template/flambda_type.templ.ml @@ -0,0 +1,880 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2018--2019 OCamlPro SAS *) +(* Copyright 2018--2019 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-30-40-41-42"] + +(* CR mshinwell: Decide on doc or non-doc comments in here. There are some + modules which aren't exposed in the interface but probably require + documentation. *) + +(* CR mshinwell: Remove when warning 60 fixed *) +[@@@ocaml.warning "-60"] + +module Float = Numbers.Float_by_bit_pattern +module Int32 = Numbers.Int32 +module Int64 = Numbers.Int64 + +module K = Flambda_kind + +(* -- module rec binding here -- *) + +include Type_grammar + +type flambda_type = t + +let meet env t1 t2 : _ Or_bottom.t = + let meet_env = Meet_env.create env in + meet meet_env t1 t2 + +let meet_shape env t ~shape ~result_var ~result_kind : _ Or_bottom.t = + let result = Name_in_binding_pos.var result_var in + let env = Typing_env.add_definition env result result_kind in + match meet env t shape with + | Bottom -> Bottom + | Ok (_meet_ty, env_extension) -> Ok env_extension + +let arity_of_list ts = + Flambda_arity.create (List.map kind ts) + +type typing_env = Typing_env.t +type typing_env_extension = Typing_env_extension.t + +let invariant _env _t = () (* CR mshinwell: implement *) + +type 'a type_accessor = Typing_env.t -> 'a + +let unknown_types_from_arity arity = + List.map (fun kind -> unknown kind) arity + +let bottom_types_from_arity arity = + List.map (fun kind -> bottom kind) arity + +let is_bottom env t = + match expand_head t env with + | Resolved (Value Bottom) + | Resolved (Naked_immediate Bottom) + | Resolved (Naked_float Bottom) + | Resolved (Naked_int32 Bottom) + | Resolved (Naked_int64 Bottom) + | Resolved (Naked_nativeint Bottom) -> true + | Const _ + | Resolved (Value _) + | Resolved (Naked_immediate _) + | Resolved (Naked_float _) + | Resolved (Naked_int32 _) + | Resolved (Naked_int64 _) + | Resolved (Naked_nativeint _) -> false + +type 'a proof = + | Proved of 'a + | Unknown + | Invalid + +type 'a proof_allowing_kind_mismatch = + | Proved of 'a + | Unknown + | Invalid + | Wrong_kind + +type var_or_symbol_or_tagged_immediate = + | Var of Variable.t + | Symbol of Symbol.t + | Tagged_immediate of Immediate.t + +let prove_equals_to_var_or_symbol_or_tagged_immediate env t + : var_or_symbol_or_tagged_immediate proof = + let original_kind = kind t in + if not (K.equal original_kind K.value) then begin + Misc.fatal_errorf "Type %a is not of kind value" + print t + end; + (* XXX This probably shouldn't be using [get_alias] *) + (* XXX This needs to match the equal-to-tagged-immediates function below *) + match get_alias t with + | None -> Unknown + | Some simple -> + match Simple.descr simple with + | Const (Tagged_immediate imm) -> Proved (Tagged_immediate imm) + | Const _ -> + Misc.fatal_errorf "[Simple] %a in the [Equals] field has a kind \ + different from that returned by [kind] (%a):@ %a" + Simple.print simple + K.print original_kind + print t + | Name _ -> + match + Typing_env.get_canonical_simple env simple + ~min_name_mode:Name_mode.normal + with + | Bottom -> Invalid + | Ok None -> Unknown + | Ok (Some simple) -> + (* CR mshinwell: Instead, get all aliases and find a Symbol, + to avoid relying on the fact that if there is a Symbol alias then + it will be canonical *) + match Simple.descr simple with + | Name (Symbol sym) -> Proved (Symbol sym) + | Name (Var var) -> Proved (Var var) + | Const (Tagged_immediate imm) -> Proved (Tagged_immediate imm) + | Const _ -> + let kind = kind t in + Misc.fatal_errorf "Kind returned by [get_canonical_simple] (%a) \ + doesn't match the kind of the returned [Simple] %a:@ %a" + K.print kind + Simple.print simple + print t + +let prove_single_closures_entry' env t : _ proof_allowing_kind_mismatch = + match expand_head t env with + | Const _ -> Invalid + | Resolved resolved -> + match resolved with + | Value (Ok (Closures closures)) -> + begin match + Row_like.For_closures_entry_by_set_of_closures_contents. + get_singleton closures.by_closure_id + with + | None -> Unknown + | Some ((closure_id, set_of_closures_contents), closures_entry) -> + let closure_id' = + Set_of_closures_contents.closures set_of_closures_contents + |> Closure_id.Set.get_singleton + in + match closure_id' with + | None -> Unknown + | Some closure_id' -> + assert (Closure_id.equal closure_id closure_id'); + let function_decl = + Closures_entry.find_function_declaration closures_entry closure_id + in + match function_decl with + | Bottom -> Invalid + | Ok function_decl -> + Proved (closure_id, closures_entry, function_decl) + end + | Value (Ok _) -> Invalid + | Value Unknown -> Unknown + | Value Bottom -> Invalid + | Naked_immediate _ -> Wrong_kind + | Naked_float _ -> Wrong_kind + | Naked_int32 _ -> Wrong_kind + | Naked_int64 _ -> Wrong_kind + | Naked_nativeint _ -> Wrong_kind + +let prove_single_closures_entry env t : _ proof = + match prove_single_closures_entry' env t with + | Proved proof -> Proved proof + | Unknown -> Unknown + | Invalid -> Invalid + | Wrong_kind -> Misc.fatal_errorf "Type has wrong kind: %a" print t + +(* CR mshinwell: Try to functorise or otherwise factor out across the + various number kinds. *) +let prove_naked_floats env t : _ proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Naked_float]:@ %a" print t + in + match expand_head t env with + | Const (Naked_float f) -> Proved (Float.Set.singleton f) + | Const (Naked_immediate _ | Tagged_immediate _ | Naked_int32 _ + | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () + | Resolved resolved -> + match resolved with + | Naked_float (Ok fs) -> + if Float.Set.is_empty fs then Invalid + else Proved fs + | Naked_float Unknown -> Unknown + | Naked_float Bottom -> Invalid + | Value _ -> wrong_kind () + | Naked_immediate _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_naked_int32s env t : _ proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Naked_int32]:@ %a" print t + in + match expand_head t env with + | Const (Naked_int32 i) -> Proved (Int32.Set.singleton i) + | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ + | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () + | Resolved resolved -> + match resolved with + | Naked_int32 (Ok is) -> + if Int32.Set.is_empty is then Invalid + else Proved is + | Naked_int32 Unknown -> Unknown + | Naked_int32 Bottom -> Invalid + | Value _ -> wrong_kind () + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_naked_int64s env t : _ proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Naked_int64]:@ %a" print t + in + match expand_head t env with + | Const (Naked_int64 i) -> Proved (Int64.Set.singleton i) + | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ + | Naked_int32 _ | Naked_nativeint _) -> wrong_kind () + | Resolved resolved -> + match resolved with + | Naked_int64 (Ok is) -> + if Int64.Set.is_empty is then Invalid + else Proved is + | Naked_int64 Unknown -> Unknown + | Naked_int64 Bottom -> Invalid + | Value _ -> wrong_kind () + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_naked_nativeints env t : _ proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Naked_nativeint]:@ %a" print t + in + match expand_head t env with + | Const (Naked_nativeint i) -> Proved (Targetint.Set.singleton i) + | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ + | Naked_int32 _ | Naked_int64 _) -> wrong_kind () + | Resolved resolved -> + match resolved with + | Naked_nativeint (Ok is) -> + if Targetint.Set.is_empty is then Invalid + else Proved is + | Naked_nativeint Unknown -> Unknown + | Naked_nativeint Bottom -> Invalid + | Value _ -> wrong_kind () + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + +let prove_is_int env t : bool proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t + in + match expand_head t env with + | Const (Tagged_immediate _) -> Proved true + | Const _ -> wrong_kind () + | Resolved resolved -> + match resolved with + | Value (Ok (Variant blocks_imms)) -> + begin match blocks_imms.blocks, blocks_imms.immediates with + | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown + | Known blocks, Known imms -> + (* CR mshinwell: Should we tighten things up by causing fatal errors + in cases such as [blocks] and [imms] both being bottom? *) + if Row_like.For_blocks.is_bottom blocks then + if is_bottom env imms then Invalid + else Proved true + else + if is_bottom env imms then Proved false + else Unknown + end + | Value (Ok _) -> Invalid + | Value Unknown -> Unknown + | Value Bottom -> Invalid + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_tags_must_be_a_block env t : Tag.Set.t proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t + in + match expand_head t env with + | Const (Tagged_immediate _) -> Unknown + | Const _ -> wrong_kind () + | Resolved resolved -> + match resolved with + | Value (Ok (Variant blocks_imms)) -> + begin match blocks_imms.immediates with + | Unknown -> Unknown + | Known imms -> + if not (is_bottom env imms) then + Invalid + else + match blocks_imms.blocks with + | Unknown -> Unknown + | Known blocks -> + (* CR mshinwell: maybe [all_tags] should return the [Invalid] + case directly? *) + match Row_like.For_blocks.all_tags blocks with + | Unknown -> Unknown + | Known tags -> + if Tag.Set.is_empty tags then Invalid + else Proved tags + end + | Value (Ok _) -> Invalid + | Value Unknown -> Unknown + | Value Bottom -> Invalid + (* CR mshinwell: Here and elsewhere, use or-patterns. *) + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_naked_immediates env t : Immediate.Set.t proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Naked_immediate]:@ %a" print t + in + match expand_head t env with + | Const (Naked_immediate i) -> Proved (Immediate.Set.singleton i) + | Const (Tagged_immediate _ | Naked_float _ | Naked_int32 _ + | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () + | Resolved resolved -> + match resolved with + | Naked_immediate (Ok (Naked_immediates is)) -> + (* CR mshinwell: As noted elsewhere, add abstraction to avoid the need + for these checks *) + if Immediate.Set.is_empty is then Invalid + else Proved is + | Naked_immediate (Ok (Is_int scrutinee_ty)) -> + begin match prove_is_int env scrutinee_ty with + | Proved true -> Proved (Immediate.Set.singleton Immediate.bool_true) + | Proved false -> Proved (Immediate.Set.singleton Immediate.bool_false) + | Unknown -> Unknown + | Invalid -> Invalid + end + | Naked_immediate (Ok (Get_tag block_ty)) -> + begin match prove_tags_must_be_a_block env block_ty with + | Proved tags -> + let is = + Tag.Set.fold (fun tag is -> + Immediate.Set.add (Immediate.tag tag) is) + tags + Immediate.Set.empty + in + Proved is + | Unknown -> Unknown + | Invalid -> Invalid + end + | Naked_immediate Unknown -> Unknown + | Naked_immediate Bottom -> Invalid + | Value _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_equals_tagged_immediates env t : Immediate.Set.t proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t + in + match expand_head t env with + | Const (Tagged_immediate imm) -> Proved (Immediate.Set.singleton imm) + | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ + | Naked_nativeint _) -> wrong_kind () + | Resolved resolved -> + match resolved with + | Value (Ok (Variant blocks_imms)) -> + begin match blocks_imms.blocks, blocks_imms.immediates with + | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown + | Known blocks, Known imms -> + (* CR mshinwell: Check this. Again it depends on the context; is + this a context where variants are ok? *) + if not (Row_like.For_blocks.is_bottom blocks) + then Unknown + else prove_naked_immediates env imms + end + | Value (Ok _) -> Invalid + | Value Unknown -> Unknown + | Value Bottom -> Invalid + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_equals_single_tagged_immediate env t : _ proof = + match prove_equals_tagged_immediates env t with + | Proved imms -> + begin match Immediate.Set.get_singleton imms with + | Some imm -> Proved imm + | None -> Unknown + end + | Unknown -> Unknown + | Invalid -> Invalid + +let prove_tags_and_sizes env t : Targetint.OCaml.t Tag.Map.t proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t + in + match expand_head t env with + | Const (Tagged_immediate _) -> Unknown + | Const _ -> wrong_kind () + | Resolved resolved -> + match resolved with + | Value (Ok (Variant blocks_imms)) -> + begin match blocks_imms.immediates with + (* CR mshinwell: Care. Should this return [Unknown] or [Invalid] if + there is the possibility of the type representing a tagged + immediate? *) + | Unknown -> Unknown + | Known immediates -> + if is_bottom env immediates then + match blocks_imms.blocks with + | Unknown -> Unknown + | Known blocks -> + match Row_like.For_blocks.all_tags_and_sizes blocks with + | Unknown -> Unknown + | Known tags_and_sizes -> Proved tags_and_sizes + else + Unknown + end + | Value (Ok _) -> Invalid + | Value Unknown -> Unknown + | Value Bottom -> Invalid + (* CR mshinwell: Here and elsewhere, use or-patterns. *) + | Naked_immediate _ -> wrong_kind () + | Naked_float _ -> wrong_kind () + | Naked_int32 _ -> wrong_kind () + | Naked_int64 _ -> wrong_kind () + | Naked_nativeint _ -> wrong_kind () + +let prove_unique_tag_and_size env t + : (Tag.t * Targetint.OCaml.t) proof_allowing_kind_mismatch = + if not (Flambda_kind.equal (kind t) Flambda_kind.value) then + Wrong_kind + else + match prove_tags_and_sizes env t with + | Invalid -> Invalid + | Unknown -> Unknown + | Proved tags_to_sizes -> + match Tag.Map.get_singleton tags_to_sizes with + | None -> Unknown + | Some (tag, size) -> Proved (tag, size) + +let prove_is_a_tagged_immediate env t : _ proof_allowing_kind_mismatch = + match expand_head t env with + | Const (Tagged_immediate _) -> Proved () + | Const _ -> Wrong_kind + | Resolved resolved -> + match resolved with + | Value Unknown -> Unknown + | Value (Ok (Variant { blocks; immediates; })) -> + begin match blocks, immediates with + | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown + | Known blocks, Known imms -> + if Row_like.For_blocks.is_bottom blocks && not (is_bottom env imms) + then Proved () + else Invalid + end + | Value _ -> Invalid + | _ -> Wrong_kind + +let prove_is_a_boxed_float env t : _ proof_allowing_kind_mismatch = + match expand_head t env with + | Const _ -> Wrong_kind + | Resolved resolved -> + match resolved with + | Value Unknown -> Unknown + | Value (Ok (Boxed_float _)) -> Proved () + | Value _ -> Invalid + | _ -> Wrong_kind + +let prove_is_a_boxed_int32 env t : _ proof_allowing_kind_mismatch = + match expand_head t env with + | Const _ -> Wrong_kind + | Resolved resolved -> + match resolved with + | Value Unknown -> Unknown + | Value (Ok (Boxed_int32 _)) -> Proved () + | Value _ -> Invalid + | _ -> Wrong_kind + +let prove_is_a_boxed_int64 env t : _ proof_allowing_kind_mismatch = + match expand_head t env with + | Const _ -> Wrong_kind + | Resolved resolved -> + match resolved with + | Value Unknown -> Unknown + | Value (Ok (Boxed_int64 _)) -> Proved () + | Value _ -> Invalid + | _ -> Wrong_kind + +let prove_is_a_boxed_nativeint env t : _ proof_allowing_kind_mismatch = + match expand_head t env with + | Const _ -> Wrong_kind + | Resolved resolved -> + match resolved with + | Value Unknown -> Unknown + | Value (Ok (Boxed_nativeint _)) -> Proved () + | Value _ -> Invalid + | _ -> Wrong_kind + +(* CR mshinwell: Factor out code from the following. *) + +let prove_boxed_floats env t : _ proof = + let result_var = Variable.create "result" in + let result_var' = + Var_in_binding_pos.create result_var Name_mode.normal + in + let result_simple = Simple.var result_var in + let result_kind = K.naked_float in + let shape = box_float (alias_type_of result_kind result_simple) in + match meet_shape env t ~shape ~result_var:result_var' ~result_kind with + | Bottom -> Invalid + | Ok env_extension -> + let env = + Typing_env.add_definition env + (Name_in_binding_pos.create (Name.var result_var) + Name_mode.normal) + result_kind + in + let env = Typing_env.add_env_extension env ~env_extension in + let t = Typing_env.find env (Name.var result_var) in + prove_naked_floats env t + +let prove_boxed_int32s env t : _ proof = + let result_var = Variable.create "result" in + let result_var' = + Var_in_binding_pos.create result_var Name_mode.normal + in + let result_simple = Simple.var result_var in + let result_kind = K.naked_int32 in + let shape = box_int32 (alias_type_of result_kind result_simple) in + match meet_shape env t ~shape ~result_var:result_var' ~result_kind with + | Bottom -> Invalid + | Ok env_extension -> + let env = + Typing_env.add_definition env + (Name_in_binding_pos.create (Name.var result_var) + Name_mode.normal) + result_kind + in + let env = Typing_env.add_env_extension env ~env_extension in + let t = Typing_env.find env (Name.var result_var) in + prove_naked_int32s env t + +let prove_boxed_int64s env t : _ proof = + let result_var = Variable.create "result" in + let result_var' = + Var_in_binding_pos.create result_var Name_mode.normal + in + let result_simple = Simple.var result_var in + let result_kind = K.naked_int64 in + let shape = box_int64 (alias_type_of result_kind result_simple) in + match meet_shape env t ~shape ~result_var:result_var' ~result_kind with + | Bottom -> Invalid + | Ok env_extension -> + let env = + Typing_env.add_definition env + (Name_in_binding_pos.create (Name.var result_var) + Name_mode.normal) + result_kind + in + let env = Typing_env.add_env_extension env ~env_extension in + let t = Typing_env.find env (Name.var result_var) in + prove_naked_int64s env t + +let prove_boxed_nativeints env t : _ proof = + let result_var = Variable.create "result" in + let result_var' = + Var_in_binding_pos.create result_var Name_mode.normal + in + let result_simple = Simple.var result_var in + let result_kind = K.naked_nativeint in + let shape = box_nativeint (alias_type_of result_kind result_simple) in + match meet_shape env t ~shape ~result_var:result_var' ~result_kind with + | Bottom -> Invalid + | Ok env_extension -> + let env = + Typing_env.add_definition env + (Name_in_binding_pos.create (Name.var result_var) + Name_mode.normal) + result_kind + in + let env = Typing_env.add_env_extension env ~env_extension in + let t = Typing_env.find env (Name.var result_var) in + prove_naked_nativeints env t + +let prove_strings env t : String_info.Set.t proof = + let wrong_kind () = + Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t + in + match expand_head t env with + | Const _ -> + if K.equal (kind t) K.value then Invalid + else wrong_kind () + | Resolved resolved -> + match resolved with + | Value (Ok (String strs)) -> Proved strs + | Value (Ok _) -> Invalid + | Value Unknown -> Unknown + | Value Bottom -> Invalid + | Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ + | Naked_nativeint _ -> wrong_kind () + +type to_lift = + | Immutable_block of Tag.Scannable.t + * (var_or_symbol_or_tagged_immediate list) + | Boxed_float of Float.t + | Boxed_int32 of Int32.t + | Boxed_int64 of Int64.t + | Boxed_nativeint of Targetint.t + +type reification_result = + | Lift of to_lift + | Lift_set_of_closures of { + closure_id : Closure_id.t; + function_decls : Function_declaration_type.Inlinable.t Closure_id.Map.t; + closure_vars : Simple.t Var_within_closure.Map.t; + } + | Simple of Simple.t + | Cannot_reify + | Invalid + +(* CR mshinwell: Think more to identify all the cases that should be + in this function. *) +let reify ?allowed_free_vars env ~min_name_mode t : reification_result = + let allowed_free_vars = + Option.value allowed_free_vars ~default:Variable.Set.empty + in +(* +Format.eprintf "reifying %a\n%!" print t; +*) + match + Typing_env.get_alias_then_canonical_simple env ~min_name_mode t + with + | Bottom -> Invalid + | Ok (Some canonical_simple) + when begin match Simple.descr canonical_simple with + | Name (Symbol _) -> true + | _ -> false + end -> + (* Don't lift things that are already bound to symbols. Apart from + anything else, this could cause aliases between symbols, which are + currently forbidden (every symbol has the same binding time). *) + Cannot_reify + | Ok canonical_simple_opt -> + match expand_head t env with + | Const const -> Simple (Simple.const const) + | Resolved resolved -> + let try_canonical_simple () = + match canonical_simple_opt with + | None -> Cannot_reify + | Some canonical_simple -> Simple canonical_simple + in + match resolved with + | Value (Ok (Variant blocks_imms)) -> + begin match blocks_imms.blocks, blocks_imms.immediates with + | Known blocks, Known imms -> + if is_bottom env imms then + begin match Row_like.For_blocks.get_singleton blocks with + | None -> try_canonical_simple () + | Some ((tag, size), field_types) -> + assert (Targetint.OCaml.equal size + (Product.Int_indexed.width field_types)); + (* CR mshinwell: Could recognise other things, e.g. tagged + immediates and float arrays, supported by [Static_part]. *) + let field_types = + Product.Int_indexed.components field_types + in + let vars_or_symbols_or_tagged_immediates = + List.filter_map + (fun field_type + : var_or_symbol_or_tagged_immediate option -> + match + (* CR mshinwell: Change this to a function + [prove_equals_to_simple]? *) + prove_equals_to_var_or_symbol_or_tagged_immediate env + field_type + with + | Proved (Var var) -> + if Variable.Set.mem var allowed_free_vars then + Some (Var var) + else + None + | Proved (Symbol sym) -> Some (Symbol sym) + | Proved (Tagged_immediate imm) -> + Some (Tagged_immediate imm) + (* CR mshinwell: [Invalid] should propagate up *) + | Unknown | Invalid -> None) + field_types + in + if List.compare_lengths field_types + vars_or_symbols_or_tagged_immediates = 0 + then + match Tag.Scannable.of_tag tag with + | Some tag -> + Lift (Immutable_block ( + tag, vars_or_symbols_or_tagged_immediates)) + | None -> try_canonical_simple () + else + try_canonical_simple () + end + else if Row_like.For_blocks.is_bottom blocks then + match prove_naked_immediates env imms with + | Proved imms -> + begin match Immediate.Set.get_singleton imms with + | None -> try_canonical_simple () + | Some imm -> + Simple (Simple.const (Tagged_immediate imm)) + end + | Unknown -> try_canonical_simple () + | Invalid -> Invalid + else + try_canonical_simple () + | _, _ -> try_canonical_simple () + end + | Value (Ok (Closures closures)) -> + (* CR mshinwell: Here and above, move to separate function. *) + begin match + Row_like.For_closures_entry_by_set_of_closures_contents. + get_singleton closures.by_closure_id + with + | None -> try_canonical_simple () + | Some ((closure_id, contents), closures_entry) -> + (* CR mshinwell: What about if there were multiple entries in the + row-like structure for the same closure ID? This is ruled out + by [get_singleton] at the moment. We should probably choose + the best entry from the [Row_like] structure. *) + let closure_ids = Set_of_closures_contents.closures contents in + (* CR mshinwell: Should probably check + [Set_of_closures_contents.closure_vars contents]? *) + if not (Closure_id.Set.mem closure_id closure_ids) then begin + Misc.fatal_errorf "Closure ID %a expected in \ + set-of-closures-contents in closure type@ %a" + Closure_id.print closure_id + print t + end; + let function_decls_with_closure_vars = + Closure_id.Set.fold + (fun closure_id function_decls_with_closure_vars -> + match + Closures_entry.find_function_declaration closures_entry + closure_id + with + | Bottom -> function_decls_with_closure_vars + | Ok function_decl -> + match function_decl with + | Bottom | Unknown | Ok (Non_inlinable _) -> + function_decls_with_closure_vars + | Ok (Inlinable inlinable_decl) -> + (* CR mshinwell: We're ignoring [rec_info] *) + let closure_var_types = + Closures_entry.closure_var_types closures_entry + in + let closure_var_simples = + Var_within_closure.Map.filter_map closure_var_types + ~f:(fun _closure_var closure_var_type -> + match + prove_equals_to_var_or_symbol_or_tagged_immediate + env closure_var_type + with + | Proved (Var var) -> + if Variable.Set.mem var allowed_free_vars then + Some (Simple.var var) + else + None + | Proved (Symbol sym) -> Some (Simple.symbol sym) + | Proved (Tagged_immediate imm) -> + Some (Simple.const (Tagged_immediate imm)) + | Unknown | Invalid -> None) + in + if Var_within_closure.Map.cardinal closure_var_types + <> Var_within_closure.Map.cardinal closure_var_simples + then function_decls_with_closure_vars + else + Closure_id.Map.add closure_id + (inlinable_decl, closure_var_simples) + function_decls_with_closure_vars) + closure_ids + Closure_id.Map.empty + in + if Closure_id.Set.cardinal closure_ids + <> Closure_id.Map.cardinal function_decls_with_closure_vars + then try_canonical_simple () + else + let function_decls = + Closure_id.Map.map (fun (function_decl, _) -> function_decl) + function_decls_with_closure_vars + in + let closure_vars = + Closure_id.Map.fold + (fun _closure_id (_function_decl, closure_var_simples) + all_closure_vars -> + Var_within_closure.Map.fold + (fun closure_var simple all_closure_vars -> + begin match + Var_within_closure.Map.find closure_var + all_closure_vars + with + | exception Not_found -> () + | existing_simple -> + if not (Simple.equal simple existing_simple) + then begin + Misc.fatal_errorf "Disagreement on %a and %a \ + (closure var %a)@ \ + whilst reifying set-of-closures from:@ %a" + Simple.print simple + Simple.print existing_simple + Var_within_closure.print closure_var + print t + end + end; + Var_within_closure.Map.add closure_var simple + all_closure_vars) + closure_var_simples + all_closure_vars) + function_decls_with_closure_vars + Var_within_closure.Map.empty + in + Lift_set_of_closures { + closure_id; + function_decls; + closure_vars; + } + end + (* CR mshinwell: share code with [prove_equals_tagged_immediates], + above *) + | Naked_immediate (Ok (Is_int scrutinee_ty)) -> + begin match prove_is_int env scrutinee_ty with + | Proved true -> Simple Simple.untagged_const_true + | Proved false -> Simple Simple.untagged_const_false + | Unknown -> try_canonical_simple () + | Invalid -> Invalid + end + | Naked_immediate (Ok (Get_tag block_ty)) -> + begin match prove_tags_must_be_a_block env block_ty with + | Proved tags -> + let is = + Tag.Set.fold (fun tag is -> + Immediate.Set.add (Immediate.tag tag) is) + tags + Immediate.Set.empty + in + begin match Immediate.Set.get_singleton is with + | None -> try_canonical_simple () + | Some i -> Simple (Simple.const (Naked_immediate i)) + end + | Unknown -> try_canonical_simple () + | Invalid -> Invalid + end + | Value Bottom + | Naked_immediate Bottom | Naked_float Bottom + | Naked_int32 Bottom | Naked_int64 Bottom | Naked_nativeint Bottom -> + Invalid + | _ -> try_canonical_simple () diff --git a/middle_end/flambda2.0/types/template/flambda_type0.templ.ml b/middle_end/flambda2.0/types/template/flambda_type0.templ.ml deleted file mode 100644 index 52d11dfbf8f6..000000000000 --- a/middle_end/flambda2.0/types/template/flambda_type0.templ.ml +++ /dev/null @@ -1,880 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2018--2019 OCamlPro SAS *) -(* Copyright 2018--2019 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-30-40-41-42"] - -(* CR mshinwell: Decide on doc or non-doc comments in here. There are some - modules which aren't exposed in the interface but probably require - documentation. *) - -(* CR mshinwell: Remove when warning 60 fixed *) -[@@@ocaml.warning "-60"] - -module Float = Numbers.Float_by_bit_pattern -module Int32 = Numbers.Int32 -module Int64 = Numbers.Int64 - -module K = Flambda_kind - -module Make - (Term_language_function_declaration : Term_language_function_declaration.S) -= struct - (* -- module rec binding here -- *) - - include Type_grammar - - type flambda_type = t - - let meet env t1 t2 : _ Or_bottom.t = - let meet_env = Meet_env.create env in - meet meet_env t1 t2 - - let meet_shape env t ~shape ~result_var ~result_kind : _ Or_bottom.t = - let result = Name_in_binding_pos.var result_var in - let env = Typing_env.add_definition env result result_kind in - match meet env t shape with - | Bottom -> Bottom - | Ok (_meet_ty, env_extension) -> Ok env_extension - - let arity_of_list ts = - Flambda_arity.create (List.map kind ts) - - type typing_env = Typing_env.t - type typing_env_extension = Typing_env_extension.t - - let invariant _env _t = () (* CR mshinwell: implement *) - - type 'a type_accessor = Typing_env.t -> 'a - - let unknown_types_from_arity arity = - List.map (fun kind -> unknown kind) arity - - let bottom_types_from_arity arity = - List.map (fun kind -> bottom kind) arity - - let is_bottom env t = - match expand_head t env with - | Resolved (Value Bottom) - | Resolved (Naked_immediate Bottom) - | Resolved (Naked_float Bottom) - | Resolved (Naked_int32 Bottom) - | Resolved (Naked_int64 Bottom) - | Resolved (Naked_nativeint Bottom) -> true - | Const _ - | Resolved (Value _) - | Resolved (Naked_immediate _) - | Resolved (Naked_float _) - | Resolved (Naked_int32 _) - | Resolved (Naked_int64 _) - | Resolved (Naked_nativeint _) -> false - - type 'a proof = - | Proved of 'a - | Unknown - | Invalid - - type 'a proof_allowing_kind_mismatch = - | Proved of 'a - | Unknown - | Invalid - | Wrong_kind - - type var_or_symbol_or_tagged_immediate = - | Var of Variable.t - | Symbol of Symbol.t - | Tagged_immediate of Immediate.t - - let prove_equals_to_var_or_symbol_or_tagged_immediate env t - : var_or_symbol_or_tagged_immediate proof = - let original_kind = kind t in - if not (K.equal original_kind K.value) then begin - Misc.fatal_errorf "Type %a is not of kind value" - print t - end; - (* XXX This probably shouldn't be using [get_alias] *) - (* XXX This needs to match the equal-to-tagged-immediates function below *) - match get_alias t with - | None -> Unknown - | Some simple -> - match Simple.descr simple with - | Const (Tagged_immediate imm) -> Proved (Tagged_immediate imm) - | Const _ -> - Misc.fatal_errorf "[Simple] %a in the [Equals] field has a kind \ - different from that returned by [kind] (%a):@ %a" - Simple.print simple - K.print original_kind - print t - | Name _ -> - match - Typing_env.get_canonical_simple env simple - ~min_name_mode:Name_mode.normal - with - | Bottom -> Invalid - | Ok None -> Unknown - | Ok (Some simple) -> - (* CR mshinwell: Instead, get all aliases and find a Symbol, - to avoid relying on the fact that if there is a Symbol alias then - it will be canonical *) - match Simple.descr simple with - | Name (Symbol sym) -> Proved (Symbol sym) - | Name (Var var) -> Proved (Var var) - | Const (Tagged_immediate imm) -> Proved (Tagged_immediate imm) - | Const _ -> - let kind = kind t in - Misc.fatal_errorf "Kind returned by [get_canonical_simple] (%a) \ - doesn't match the kind of the returned [Simple] %a:@ %a" - K.print kind - Simple.print simple - print t - - let prove_single_closures_entry' env t : _ proof_allowing_kind_mismatch = - match expand_head t env with - | Const _ -> Invalid - | Resolved resolved -> - match resolved with - | Value (Ok (Closures closures)) -> - begin match - Row_like.For_closures_entry_by_set_of_closures_contents. - get_singleton closures.by_closure_id - with - | None -> Unknown - | Some ((closure_id, set_of_closures_contents), closures_entry) -> - let closure_id' = - Set_of_closures_contents.closures set_of_closures_contents - |> Closure_id.Set.get_singleton - in - match closure_id' with - | None -> Unknown - | Some closure_id' -> - assert (Closure_id.equal closure_id closure_id'); - let function_decl = - Closures_entry.find_function_declaration closures_entry closure_id - in - Proved (closure_id, closures_entry, function_decl) - end - | Value (Ok _) -> Invalid - | Value Unknown -> Unknown - | Value Bottom -> Invalid - | Naked_immediate _ -> Wrong_kind - | Naked_float _ -> Wrong_kind - | Naked_int32 _ -> Wrong_kind - | Naked_int64 _ -> Wrong_kind - | Naked_nativeint _ -> Wrong_kind - - let prove_single_closures_entry env t : _ proof = - match prove_single_closures_entry' env t with - | Proved proof -> Proved proof - | Unknown -> Unknown - | Invalid -> Invalid - | Wrong_kind -> Misc.fatal_errorf "Type has wrong kind: %a" print t - - (* CR mshinwell: Try to functorise or otherwise factor out across the - various number kinds. *) - let prove_naked_floats env t : _ proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Naked_float]:@ %a" print t - in - match expand_head t env with - | Const (Naked_float f) -> Proved (Float.Set.singleton f) - | Const (Naked_immediate _ | Tagged_immediate _ | Naked_int32 _ - | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () - | Resolved resolved -> - match resolved with - | Naked_float (Ok fs) -> - if Float.Set.is_empty fs then Invalid - else Proved fs - | Naked_float Unknown -> Unknown - | Naked_float Bottom -> Invalid - | Value _ -> wrong_kind () - | Naked_immediate _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_naked_int32s env t : _ proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Naked_int32]:@ %a" print t - in - match expand_head t env with - | Const (Naked_int32 i) -> Proved (Int32.Set.singleton i) - | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () - | Resolved resolved -> - match resolved with - | Naked_int32 (Ok is) -> - if Int32.Set.is_empty is then Invalid - else Proved is - | Naked_int32 Unknown -> Unknown - | Naked_int32 Bottom -> Invalid - | Value _ -> wrong_kind () - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_naked_int64s env t : _ proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Naked_int64]:@ %a" print t - in - match expand_head t env with - | Const (Naked_int64 i) -> Proved (Int64.Set.singleton i) - | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int32 _ | Naked_nativeint _) -> wrong_kind () - | Resolved resolved -> - match resolved with - | Naked_int64 (Ok is) -> - if Int64.Set.is_empty is then Invalid - else Proved is - | Naked_int64 Unknown -> Unknown - | Naked_int64 Bottom -> Invalid - | Value _ -> wrong_kind () - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_naked_nativeints env t : _ proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Naked_nativeint]:@ %a" print t - in - match expand_head t env with - | Const (Naked_nativeint i) -> Proved (Targetint.Set.singleton i) - | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int32 _ | Naked_int64 _) -> wrong_kind () - | Resolved resolved -> - match resolved with - | Naked_nativeint (Ok is) -> - if Targetint.Set.is_empty is then Invalid - else Proved is - | Naked_nativeint Unknown -> Unknown - | Naked_nativeint Bottom -> Invalid - | Value _ -> wrong_kind () - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - - let prove_is_int env t : bool proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t - in - match expand_head t env with - | Const (Tagged_immediate _) -> Proved true - | Const _ -> wrong_kind () - | Resolved resolved -> - match resolved with - | Value (Ok (Variant blocks_imms)) -> - begin match blocks_imms.blocks, blocks_imms.immediates with - | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown - | Known blocks, Known imms -> - (* CR mshinwell: Should we tighten things up by causing fatal errors - in cases such as [blocks] and [imms] both being bottom? *) - if Row_like.For_blocks.is_bottom blocks then - if is_bottom env imms then Invalid - else Proved true - else - if is_bottom env imms then Proved false - else Unknown - end - | Value (Ok _) -> Invalid - | Value Unknown -> Unknown - | Value Bottom -> Invalid - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_tags_must_be_a_block env t : Tag.Set.t proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t - in - match expand_head t env with - | Const (Tagged_immediate _) -> Unknown - | Const _ -> wrong_kind () - | Resolved resolved -> - match resolved with - | Value (Ok (Variant blocks_imms)) -> - begin match blocks_imms.immediates with - | Unknown -> Unknown - | Known imms -> - if not (is_bottom env imms) then - Invalid - else - match blocks_imms.blocks with - | Unknown -> Unknown - | Known blocks -> - (* CR mshinwell: maybe [all_tags] should return the [Invalid] - case directly? *) - match Row_like.For_blocks.all_tags blocks with - | Unknown -> Unknown - | Known tags -> - if Tag.Set.is_empty tags then Invalid - else Proved tags - end - | Value (Ok _) -> Invalid - | Value Unknown -> Unknown - | Value Bottom -> Invalid - (* CR mshinwell: Here and elsewhere, use or-patterns. *) - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_naked_immediates env t : Immediate.Set.t proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Naked_immediate]:@ %a" print t - in - match expand_head t env with - | Const (Naked_immediate i) -> Proved (Immediate.Set.singleton i) - | Const (Tagged_immediate _ | Naked_float _ | Naked_int32 _ - | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () - | Resolved resolved -> - match resolved with - | Naked_immediate (Ok (Naked_immediates is)) -> - (* CR mshinwell: As noted elsewhere, add abstraction to avoid the need - for these checks *) - if Immediate.Set.is_empty is then Invalid - else Proved is - | Naked_immediate (Ok (Is_int scrutinee_ty)) -> - begin match prove_is_int env scrutinee_ty with - | Proved true -> Proved (Immediate.Set.singleton Immediate.bool_true) - | Proved false -> Proved (Immediate.Set.singleton Immediate.bool_false) - | Unknown -> Unknown - | Invalid -> Invalid - end - | Naked_immediate (Ok (Get_tag block_ty)) -> - begin match prove_tags_must_be_a_block env block_ty with - | Proved tags -> - let is = - Tag.Set.fold (fun tag is -> - Immediate.Set.add (Immediate.tag tag) is) - tags - Immediate.Set.empty - in - Proved is - | Unknown -> Unknown - | Invalid -> Invalid - end - | Naked_immediate Unknown -> Unknown - | Naked_immediate Bottom -> Invalid - | Value _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_equals_tagged_immediates env t : Immediate.Set.t proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t - in - match expand_head t env with - | Const (Tagged_immediate imm) -> Proved (Immediate.Set.singleton imm) - | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ - | Naked_nativeint _) -> wrong_kind () - | Resolved resolved -> - match resolved with - | Value (Ok (Variant blocks_imms)) -> - begin match blocks_imms.blocks, blocks_imms.immediates with - | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown - | Known blocks, Known imms -> - (* CR mshinwell: Check this. Again it depends on the context; is - this a context where variants are ok? *) - if not (Row_like.For_blocks.is_bottom blocks) - then Unknown - else prove_naked_immediates env imms - end - | Value (Ok _) -> Invalid - | Value Unknown -> Unknown - | Value Bottom -> Invalid - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_equals_single_tagged_immediate env t : _ proof = - match prove_equals_tagged_immediates env t with - | Proved imms -> - begin match Immediate.Set.get_singleton imms with - | Some imm -> Proved imm - | None -> Unknown - end - | Unknown -> Unknown - | Invalid -> Invalid - - let prove_tags_and_sizes env t : Targetint.OCaml.t Tag.Map.t proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t - in - match expand_head t env with - | Const (Tagged_immediate _) -> Unknown - | Const _ -> wrong_kind () - | Resolved resolved -> - match resolved with - | Value (Ok (Variant blocks_imms)) -> - begin match blocks_imms.immediates with - (* CR mshinwell: Care. Should this return [Unknown] or [Invalid] if - there is the possibility of the type representing a tagged - immediate? *) - | Unknown -> Unknown - | Known immediates -> - if is_bottom env immediates then - match blocks_imms.blocks with - | Unknown -> Unknown - | Known blocks -> - match Row_like.For_blocks.all_tags_and_sizes blocks with - | Unknown -> Unknown - | Known tags_and_sizes -> Proved tags_and_sizes - else - Unknown - end - | Value (Ok _) -> Invalid - | Value Unknown -> Unknown - | Value Bottom -> Invalid - (* CR mshinwell: Here and elsewhere, use or-patterns. *) - | Naked_immediate _ -> wrong_kind () - | Naked_float _ -> wrong_kind () - | Naked_int32 _ -> wrong_kind () - | Naked_int64 _ -> wrong_kind () - | Naked_nativeint _ -> wrong_kind () - - let prove_unique_tag_and_size env t - : (Tag.t * Targetint.OCaml.t) proof_allowing_kind_mismatch = - if not (Flambda_kind.equal (kind t) Flambda_kind.value) then - Wrong_kind - else - match prove_tags_and_sizes env t with - | Invalid -> Invalid - | Unknown -> Unknown - | Proved tags_to_sizes -> - match Tag.Map.get_singleton tags_to_sizes with - | None -> Unknown - | Some (tag, size) -> Proved (tag, size) - - let prove_is_a_tagged_immediate env t : _ proof_allowing_kind_mismatch = - match expand_head t env with - | Const (Tagged_immediate _) -> Proved () - | Const _ -> Wrong_kind - | Resolved resolved -> - match resolved with - | Value Unknown -> Unknown - | Value (Ok (Variant { blocks; immediates; })) -> - begin match blocks, immediates with - | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown - | Known blocks, Known imms -> - if Row_like.For_blocks.is_bottom blocks && not (is_bottom env imms) - then Proved () - else Invalid - end - | Value _ -> Invalid - | _ -> Wrong_kind - - let prove_is_a_boxed_float env t : _ proof_allowing_kind_mismatch = - match expand_head t env with - | Const _ -> Wrong_kind - | Resolved resolved -> - match resolved with - | Value Unknown -> Unknown - | Value (Ok (Boxed_float _)) -> Proved () - | Value _ -> Invalid - | _ -> Wrong_kind - - let prove_is_a_boxed_int32 env t : _ proof_allowing_kind_mismatch = - match expand_head t env with - | Const _ -> Wrong_kind - | Resolved resolved -> - match resolved with - | Value Unknown -> Unknown - | Value (Ok (Boxed_int32 _)) -> Proved () - | Value _ -> Invalid - | _ -> Wrong_kind - - let prove_is_a_boxed_int64 env t : _ proof_allowing_kind_mismatch = - match expand_head t env with - | Const _ -> Wrong_kind - | Resolved resolved -> - match resolved with - | Value Unknown -> Unknown - | Value (Ok (Boxed_int64 _)) -> Proved () - | Value _ -> Invalid - | _ -> Wrong_kind - - let prove_is_a_boxed_nativeint env t : _ proof_allowing_kind_mismatch = - match expand_head t env with - | Const _ -> Wrong_kind - | Resolved resolved -> - match resolved with - | Value Unknown -> Unknown - | Value (Ok (Boxed_nativeint _)) -> Proved () - | Value _ -> Invalid - | _ -> Wrong_kind - - (* CR mshinwell: Factor out code from the following. *) - - let prove_boxed_floats env t : _ proof = - let result_var = Variable.create "result" in - let result_var' = - Var_in_binding_pos.create result_var Name_mode.normal - in - let result_simple = Simple.var result_var in - let result_kind = K.naked_float in - let shape = box_float (alias_type_of result_kind result_simple) in - match meet_shape env t ~shape ~result_var:result_var' ~result_kind with - | Bottom -> Invalid - | Ok env_extension -> - let env = - Typing_env.add_definition env - (Name_in_binding_pos.create (Name.var result_var) - Name_mode.normal) - result_kind - in - let env = Typing_env.add_env_extension env ~env_extension in - let t = Typing_env.find env (Name.var result_var) in - prove_naked_floats env t - - let prove_boxed_int32s env t : _ proof = - let result_var = Variable.create "result" in - let result_var' = - Var_in_binding_pos.create result_var Name_mode.normal - in - let result_simple = Simple.var result_var in - let result_kind = K.naked_int32 in - let shape = box_int32 (alias_type_of result_kind result_simple) in - match meet_shape env t ~shape ~result_var:result_var' ~result_kind with - | Bottom -> Invalid - | Ok env_extension -> - let env = - Typing_env.add_definition env - (Name_in_binding_pos.create (Name.var result_var) - Name_mode.normal) - result_kind - in - let env = Typing_env.add_env_extension env ~env_extension in - let t = Typing_env.find env (Name.var result_var) in - prove_naked_int32s env t - - let prove_boxed_int64s env t : _ proof = - let result_var = Variable.create "result" in - let result_var' = - Var_in_binding_pos.create result_var Name_mode.normal - in - let result_simple = Simple.var result_var in - let result_kind = K.naked_int64 in - let shape = box_int64 (alias_type_of result_kind result_simple) in - match meet_shape env t ~shape ~result_var:result_var' ~result_kind with - | Bottom -> Invalid - | Ok env_extension -> - let env = - Typing_env.add_definition env - (Name_in_binding_pos.create (Name.var result_var) - Name_mode.normal) - result_kind - in - let env = Typing_env.add_env_extension env ~env_extension in - let t = Typing_env.find env (Name.var result_var) in - prove_naked_int64s env t - - let prove_boxed_nativeints env t : _ proof = - let result_var = Variable.create "result" in - let result_var' = - Var_in_binding_pos.create result_var Name_mode.normal - in - let result_simple = Simple.var result_var in - let result_kind = K.naked_nativeint in - let shape = box_nativeint (alias_type_of result_kind result_simple) in - match meet_shape env t ~shape ~result_var:result_var' ~result_kind with - | Bottom -> Invalid - | Ok env_extension -> - let env = - Typing_env.add_definition env - (Name_in_binding_pos.create (Name.var result_var) - Name_mode.normal) - result_kind - in - let env = Typing_env.add_env_extension env ~env_extension in - let t = Typing_env.find env (Name.var result_var) in - prove_naked_nativeints env t - - let prove_strings env t : String_info.Set.t proof = - let wrong_kind () = - Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t - in - match expand_head t env with - | Const _ -> - if K.equal (kind t) K.value then Invalid - else wrong_kind () - | Resolved resolved -> - match resolved with - | Value (Ok (String strs)) -> Proved strs - | Value (Ok _) -> Invalid - | Value Unknown -> Unknown - | Value Bottom -> Invalid - | Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ - | Naked_nativeint _ -> wrong_kind () - - type to_lift = - | Immutable_block of Tag.Scannable.t - * (var_or_symbol_or_tagged_immediate list) - | Boxed_float of Float.t - | Boxed_int32 of Int32.t - | Boxed_int64 of Int64.t - | Boxed_nativeint of Targetint.t - - type reification_result = - | Lift of to_lift - | Lift_set_of_closures of { - closure_id : Closure_id.t; - function_decls : Term_language_function_declaration.t Closure_id.Map.t; - closure_vars : Simple.t Var_within_closure.Map.t; - } - | Simple of Simple.t - | Cannot_reify - | Invalid - - (* CR mshinwell: Think more to identify all the cases that should be - in this function. *) - let reify ?allowed_free_vars env ~min_name_mode t : reification_result = - let allowed_free_vars = - Option.value allowed_free_vars ~default:Variable.Set.empty - in -(* -Format.eprintf "reifying %a\n%!" print t; -*) - match - Typing_env.get_alias_then_canonical_simple env ~min_name_mode t - with - | Bottom -> Invalid - | Ok (Some canonical_simple) - when begin match Simple.descr canonical_simple with - | Name (Symbol _) -> true - | _ -> false - end -> - (* Don't lift things that are already bound to symbols. Apart from - anything else, this could cause aliases between symbols, which are - currently forbidden (every symbol has the same binding time). *) - Cannot_reify - | Ok canonical_simple_opt -> - match expand_head t env with - | Const const -> Simple (Simple.const const) - | Resolved resolved -> - let try_canonical_simple () = - match canonical_simple_opt with - | None -> Cannot_reify - | Some canonical_simple -> Simple canonical_simple - in - match resolved with - | Value (Ok (Variant blocks_imms)) -> - begin match blocks_imms.blocks, blocks_imms.immediates with - | Known blocks, Known imms -> - if is_bottom env imms then - begin match Row_like.For_blocks.get_singleton blocks with - | None -> try_canonical_simple () - | Some ((tag, size), field_types) -> - assert (Targetint.OCaml.equal size - (Product.Int_indexed.width field_types)); - (* CR mshinwell: Could recognise other things, e.g. tagged - immediates and float arrays, supported by [Static_part]. *) - let field_types = - Product.Int_indexed.components field_types - in - let vars_or_symbols_or_tagged_immediates = - List.filter_map - (fun field_type - : var_or_symbol_or_tagged_immediate option -> - match - (* CR mshinwell: Change this to a function - [prove_equals_to_simple]? *) - prove_equals_to_var_or_symbol_or_tagged_immediate env - field_type - with - | Proved (Var var) -> - if Variable.Set.mem var allowed_free_vars then - Some (Var var) - else - None - | Proved (Symbol sym) -> Some (Symbol sym) - | Proved (Tagged_immediate imm) -> - Some (Tagged_immediate imm) - (* CR mshinwell: [Invalid] should propagate up *) - | Unknown | Invalid -> None) - field_types - in - if List.compare_lengths field_types - vars_or_symbols_or_tagged_immediates = 0 - then - match Tag.Scannable.of_tag tag with - | Some tag -> - Lift (Immutable_block ( - tag, vars_or_symbols_or_tagged_immediates)) - | None -> try_canonical_simple () - else - try_canonical_simple () - end - else if Row_like.For_blocks.is_bottom blocks then - match prove_naked_immediates env imms with - | Proved imms -> - begin match Immediate.Set.get_singleton imms with - | None -> try_canonical_simple () - | Some imm -> - Simple (Simple.const (Tagged_immediate imm)) - end - | Unknown -> try_canonical_simple () - | Invalid -> Invalid - else - try_canonical_simple () - | _, _ -> try_canonical_simple () - end - | Value (Ok (Closures closures)) -> - (* CR mshinwell: Here and above, move to separate function. *) - begin match - Row_like.For_closures_entry_by_set_of_closures_contents. - get_singleton closures.by_closure_id - with - | None -> try_canonical_simple () - | Some ((closure_id, contents), closures_entry) -> - (* CR mshinwell: What about if there were multiple entries in the - row-like structure for the same closure ID? This is ruled out - by [get_singleton] at the moment. We should probably choose - the best entry from the [Row_like] structure. *) - let closure_ids = Set_of_closures_contents.closures contents in - (* CR mshinwell: Should probably check - [Set_of_closures_contents.closure_vars contents]? *) - if not (Closure_id.Set.mem closure_id closure_ids) then begin - Misc.fatal_errorf "Closure ID %a expected in \ - set-of-closures-contents in closure type@ %a" - Closure_id.print closure_id - print t - end; - let function_decls_with_closure_vars = - Closure_id.Set.fold - (fun closure_id function_decls_with_closure_vars -> - match - Closures_entry.find_function_declaration closures_entry - closure_id - with - | Unknown -> function_decls_with_closure_vars - | Known function_decl -> - match function_decl with - | Non_inlinable _ -> function_decls_with_closure_vars - | Inlinable { function_decl; rec_info = _ } -> - (* CR mshinwell: We're ignoring [rec_info] *) - let closure_var_types = - Closures_entry.closure_var_types closures_entry - in - let closure_var_simples = - Var_within_closure.Map.filter_map closure_var_types - ~f:(fun _closure_var closure_var_type -> - match - prove_equals_to_var_or_symbol_or_tagged_immediate - env closure_var_type - with - | Proved (Var var) -> - if Variable.Set.mem var allowed_free_vars then - Some (Simple.var var) - else - None - | Proved (Symbol sym) -> Some (Simple.symbol sym) - | Proved (Tagged_immediate imm) -> - Some (Simple.const (Tagged_immediate imm)) - | Unknown | Invalid -> None) - in - if Var_within_closure.Map.cardinal closure_var_types - <> Var_within_closure.Map.cardinal closure_var_simples - then function_decls_with_closure_vars - else - Closure_id.Map.add closure_id - (function_decl, closure_var_simples) - function_decls_with_closure_vars) - closure_ids - Closure_id.Map.empty - in - if Closure_id.Set.cardinal closure_ids - <> Closure_id.Map.cardinal function_decls_with_closure_vars - then try_canonical_simple () - else - let function_decls = - Closure_id.Map.map (fun (function_decl, _) -> function_decl) - function_decls_with_closure_vars - in - let closure_vars = - Closure_id.Map.fold - (fun _closure_id (_function_decl, closure_var_simples) - all_closure_vars -> - Var_within_closure.Map.fold - (fun closure_var simple all_closure_vars -> - begin match - Var_within_closure.Map.find closure_var - all_closure_vars - with - | exception Not_found -> () - | existing_simple -> - if not (Simple.equal simple existing_simple) - then begin - Misc.fatal_errorf "Disagreement on %a and %a \ - (closure var %a)@ \ - whilst reifying set-of-closures from:@ %a" - Simple.print simple - Simple.print existing_simple - Var_within_closure.print closure_var - print t - end - end; - Var_within_closure.Map.add closure_var simple - all_closure_vars) - closure_var_simples - all_closure_vars) - function_decls_with_closure_vars - Var_within_closure.Map.empty - in - Lift_set_of_closures { - closure_id; - function_decls; - closure_vars; - } - end - (* CR mshinwell: share code with [prove_equals_tagged_immediates], - above *) - | Naked_immediate (Ok (Is_int scrutinee_ty)) -> - begin match prove_is_int env scrutinee_ty with - | Proved true -> Simple Simple.untagged_const_true - | Proved false -> Simple Simple.untagged_const_false - | Unknown -> try_canonical_simple () - | Invalid -> Invalid - end - | Naked_immediate (Ok (Get_tag block_ty)) -> - begin match prove_tags_must_be_a_block env block_ty with - | Proved tags -> - let is = - Tag.Set.fold (fun tag is -> - Immediate.Set.add (Immediate.tag tag) is) - tags - Immediate.Set.empty - in - begin match Immediate.Set.get_singleton is with - | None -> try_canonical_simple () - | Some i -> Simple (Simple.const (Naked_immediate i)) - end - | Unknown -> try_canonical_simple () - | Invalid -> Invalid - end - | Value Bottom - | Naked_immediate Bottom | Naked_float Bottom - | Naked_int32 Bottom | Naked_int64 Bottom | Naked_nativeint Bottom -> - Invalid - | _ -> try_canonical_simple () -end diff --git a/middle_end/flambda2.0/types/type_grammar.rec.ml b/middle_end/flambda2.0/types/type_grammar.rec.ml index bd8c10a6f73f..1df7cec1c29d 100644 --- a/middle_end/flambda2.0/types/type_grammar.rec.ml +++ b/middle_end/flambda2.0/types/type_grammar.rec.ml @@ -232,7 +232,7 @@ let alias_type_of (kind : K.t) name : t = | Naked_number Naked_int32 -> Naked_int32 (T_N32.create_equals name) | Naked_number Naked_int64 -> Naked_int64 (T_N64.create_equals name) | Naked_number Naked_nativeint -> Naked_nativeint (T_NN.create_equals name) - | Fabricated -> Misc.fatal_error "Fabricated not expected here" + | Fabricated -> Misc.fatal_error "Only used in [Flambda_static] now" let bottom_value () = Value (T_V.bottom ()) let bottom_naked_immediate () = Naked_immediate (T_NI.bottom ()) @@ -249,7 +249,7 @@ let bottom (kind : K.t) = | Naked_number Naked_int32 -> bottom_naked_int32 () | Naked_number Naked_int64 -> bottom_naked_int64 () | Naked_number Naked_nativeint -> bottom_naked_nativeint () - | Fabricated -> Misc.fatal_error "Fabricated not expected here" + | Fabricated -> Misc.fatal_error "Only used in [Flambda_static] now" let bottom_like t = bottom (kind t) @@ -268,7 +268,7 @@ let unknown (kind : K.t) = | Naked_number Naked_int32 -> any_naked_int32 () | Naked_number Naked_int64 -> any_naked_int64 () | Naked_number Naked_nativeint -> any_naked_nativeint () - | Fabricated -> Misc.fatal_error "Fabricated not expected here" + | Fabricated -> Misc.fatal_error "Only used in [Flambda_static] now" let unknown_like t = unknown (kind t) @@ -503,20 +503,18 @@ let any_boxed_int32 () = box_int32 (any_naked_int32 ()) let any_boxed_int64 () = box_int64 (any_naked_int64 ()) let any_boxed_nativeint () = box_nativeint (any_naked_nativeint ()) -let create_inlinable_function_declaration function_decl rec_info +let create_inlinable_function_declaration ~code_id ~param_arity ~result_arity + ~stub ~dbg ~inline ~is_a_functor ~recursive ~rec_info : Function_declaration_type.t = - Inlinable { - function_decl; - rec_info; - } - -let create_non_inlinable_function_declaration ~param_arity ~result_arity - ~recursive : Function_declaration_type.t = - Non_inlinable { - param_arity; - result_arity; - recursive; - } + Ok (Inlinable ( + Function_declaration_type.Inlinable.create ~code_id ~param_arity + ~result_arity ~stub ~dbg ~inline ~is_a_functor ~recursive ~rec_info)) + +let create_non_inlinable_function_declaration ~code_id ~param_arity + ~result_arity ~recursive : Function_declaration_type.t = + Ok (Non_inlinable ( + Function_declaration_type.Non_inlinable.create ~code_id ~param_arity + ~result_arity ~recursive)) let exactly_this_closure closure_id ~all_function_decls_in_set:function_decls ~all_closures_in_set:closure_types @@ -526,10 +524,6 @@ let exactly_this_closure closure_id ~all_function_decls_in_set:function_decls let closure_var_types = Product.Var_within_closure_indexed.create closure_var_types in - let function_decls = - Closure_id.Map.map (fun func_decl -> Or_unknown.Known func_decl) - function_decls - in Closures_entry.create ~function_decls ~closure_types ~closure_var_types in let by_closure_id = @@ -554,7 +548,7 @@ let at_least_the_closures_with_ids ~this_closure closure_ids_and_bindings = closure_ids_and_bindings in let function_decls = - Closure_id.Map.map (fun _ -> Or_unknown.Unknown) + Closure_id.Map.map (fun _ -> Or_unknown_or_bottom.Unknown) closure_ids_and_bindings in let closure_types = Product.Closure_id_indexed.create closure_ids_and_types in diff --git a/middle_end/flambda2.0/types/type_grammar.rec.mli b/middle_end/flambda2.0/types/type_grammar.rec.mli index 5cfc874d48ee..22912dd07ad4 100644 --- a/middle_end/flambda2.0/types/type_grammar.rec.mli +++ b/middle_end/flambda2.0/types/type_grammar.rec.mli @@ -133,12 +133,20 @@ val type_for_const : Simple.Const.t -> t val kind_for_const : Simple.Const.t -> Flambda_kind.t val create_inlinable_function_declaration - : Term_language_function_declaration.t - -> Rec_info.t + : code_id:Code_id.t + -> param_arity:Flambda_arity.t + -> result_arity:Flambda_arity.t + -> stub:bool + -> dbg:Debuginfo.t + -> inline:Inline_attribute.t + -> is_a_functor:bool + -> recursive:Recursive.t + -> rec_info:Rec_info.t -> Function_declaration_type.t val create_non_inlinable_function_declaration - : param_arity:Flambda_arity.t + : code_id:Code_id.t + -> param_arity:Flambda_arity.t -> result_arity:Flambda_arity.t -> recursive:Recursive.t -> Function_declaration_type.t diff --git a/middle_end/flambda2.0/types/type_of_kind/type_of_kind_value0.rec.ml b/middle_end/flambda2.0/types/type_of_kind/type_of_kind_value0.rec.ml index 0adaa725a861..1429aed008f1 100644 --- a/middle_end/flambda2.0/types/type_of_kind/type_of_kind_value0.rec.ml +++ b/middle_end/flambda2.0/types/type_of_kind/type_of_kind_value0.rec.ml @@ -143,15 +143,11 @@ let apply_rec_info t rec_info : _ Or_bottom.t = match t with | Closures { by_closure_id; } -> Or_bottom.map - (Row_like.For_closures_entry_by_set_of_closures_contents.map_function_decl_types + (Row_like.For_closures_entry_by_set_of_closures_contents. + map_function_decl_types by_closure_id - ~f:(fun (decl : Function_declaration_type.t) - : Function_declaration_type.t Or_bottom.t -> - match decl with - | Non_inlinable _ -> Ok decl - | Inlinable { function_decl; rec_info = old_rec_info; } -> - let rec_info = Rec_info.merge old_rec_info ~newer:rec_info in - Ok (Inlinable { function_decl; rec_info; }))) + ~f:(fun (decl : Function_declaration_type.t) : _ Or_bottom.t -> + Function_declaration_type.apply_rec_info decl rec_info)) ~f:(fun by_closure_id -> Closures { by_closure_id; }) | Variant _ | Boxed_float _ diff --git a/middle_end/flambda2.0/types/type_system_intf.ml b/middle_end/flambda2.0/types/type_system_intf.ml deleted file mode 100644 index 3abe6e80dd7d..000000000000 --- a/middle_end/flambda2.0/types/type_system_intf.ml +++ /dev/null @@ -1,477 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2019 OCamlPro SAS *) -(* Copyright 2014--2019 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. *) -(* *) -(**************************************************************************) - -(** The interface to the type system once instantiated for a particular - expression language (typically [Flambda]). *) - -[@@@ocaml.warning "+a-4-30-40-41-42"] - -(* CR mshinwell: Add invariant checks, including e.g. on the bodies of - functions in types. *) - -module Float = Numbers.Float_by_bit_pattern -module Int32 = Numbers.Int32 -module Int64 = Numbers.Int64 - -module type S = sig - type term_language_function_declaration - - type t - type flambda_type = t - - val print : Format.formatter -> t -> unit - - val print_with_cache : cache:Printing_cache.t -> Format.formatter -> t -> unit - - val invariant : Invariant_env.t -> t -> unit - - val arity_of_list : t list -> Flambda_arity.t - - type typing_env - type typing_env_extension - - module Typing_env_extension : sig - type t = typing_env_extension - - val print : Format.formatter -> t -> unit - - val invariant : t -> unit - - val empty : unit -> t - - val one_equation : Name.t -> flambda_type -> t - - val add_or_replace_equation : t -> Name.t -> flambda_type -> t - - val add_cse - : t - -> Flambda_primitive.Eligible_for_cse.t - -> bound_to:Simple.t - -> t - end - - module Typing_env : sig - type t = typing_env - - val invariant : t -> unit - - val print : Format.formatter -> t -> unit - - val create : resolver:(Export_id.t -> flambda_type option) -> t - - val create_using_resolver_and_symbol_bindings_from : t -> t - - val resolver : t -> (Export_id.t -> flambda_type option) - - val var_domain : t -> Variable.Set.t - - val current_scope : t -> Scope.t - - val increment_scope : t -> t - - val add_definition : t -> Name_in_binding_pos.t -> Flambda_kind.t -> t - - val add_definitions_of_params : t -> params:Kinded_parameter.t list -> t - - val add_equation : t -> Name.t -> flambda_type -> t - - val add_equations_on_params - : t - -> params:Kinded_parameter.t list - -> param_types:flambda_type list - -> t - - val meet_equations_on_params - : t - -> params:Kinded_parameter.t list - -> param_types:flambda_type list - -> t - - val add_cse - : t - -> Flambda_primitive.Eligible_for_cse.t - -> bound_to:Simple.t - -> t - - val mem : t -> Name.t -> bool - - val find : t -> Name.t -> flambda_type - - val find_params : t -> Kinded_parameter.t list -> flambda_type list - - val find_cse : t -> Flambda_primitive.Eligible_for_cse.t -> Simple.t option - - val find_cse_rev - : t - -> bound_to:Simple.t - -> Flambda_primitive.Eligible_for_cse.t option - - val add_env_extension - : t - -> env_extension:Typing_env_extension.t - -> t - - val get_canonical_simple - : t - -> ?min_name_mode:Name_mode.t - -> Simple.t - -> Simple.t option Or_bottom.t - - val get_canonical_simple_with_kind - : t - -> ?min_name_mode:Name_mode.t - -> Simple.t - -> Simple.t option Or_bottom.t * Flambda_kind.t - - val cut_and_n_way_join - : t - -> (t * Apply_cont_rewrite_id.t * Continuation_use_kind.t - * Variable.Set.t) list - -> unknown_if_defined_at_or_later_than:Scope.t - -> Typing_env_extension.t * Continuation_extra_params_and_args.t - - val free_variables_transitive : t -> flambda_type -> Variable.Set.t - end - - val meet : Typing_env.t -> t -> t -> (t * Typing_env_extension.t) Or_bottom.t - - val meet_shape - : Typing_env.t - -> t - -> shape:t - -> result_var:Var_in_binding_pos.t - -> result_kind:Flambda_kind.t - -> Typing_env_extension.t Or_bottom.t - - val join : Typing_env.t -> t -> t -> t - - (* CR mshinwell: Substitute out this alias once it's finalised *) - type 'a type_accessor = Typing_env.t -> 'a - - (* CR mshinwell: The function declaration types should be abstract *) - module Function_declaration_type : sig - type inlinable = private { - function_decl : term_language_function_declaration; - rec_info : Rec_info.t; - } - - type t = private - | Non_inlinable of { - param_arity : Flambda_arity.t; - result_arity : Flambda_arity.t; - recursive : Recursive.t; - } - | Inlinable of inlinable - end - - module Closures_entry : sig - type t - - val closure_var_types : t -> flambda_type Var_within_closure.Map.t - end - - (** This function takes a type [t] and an environment [env] that assigns types - to all the free names of [t]. It also takes an environment, called - [suitable_for], in which we would like to use [t]. The function - identifies which free names (if any) of [t] would be unbound in - [suitable_for]. For each such name a fresh variable is assigned and - irrelevantly bound in [suitable_for]; the returned type is like [t] - except that the names that would otherwise be unbound are replaced by - these fresh variables. The fresh variables are assigned types in the - returned environment extension on a best effort basis. *) - (* CR mshinwell: update comment *) - val make_suitable_for_environment - : t - -> Typing_env.t - -> suitable_for:Typing_env.t - -> bind_to:Name.t - -> Typing_env_extension.t - - val apply_rec_info : flambda_type -> Rec_info.t -> flambda_type Or_bottom.t - - (** Construct a bottom type of the given kind. *) - val bottom : Flambda_kind.t -> t - - (** Construct a top ("unknown") type of the given kind. *) - val unknown : Flambda_kind.t -> t - - (** Create an bottom type with the same kind as the given type. *) - val bottom_like : t -> t - - (** Create an "unknown" type with the same kind as the given type. *) - val unknown_like : t -> t - - val any_value : unit -> t - - val any_tagged_immediate : unit -> t - val any_tagged_bool : unit -> t - - val any_boxed_float : unit -> t - val any_boxed_int32 : unit -> t - val any_boxed_int64 : unit -> t - val any_boxed_nativeint : unit -> t - - val any_naked_immediate : unit -> t - val any_naked_float : unit -> t - val any_naked_int32 : unit -> t - val any_naked_int64 : unit -> t - val any_naked_nativeint : unit -> t - - (** Building of types representing tagged / boxed values from specified - constants. *) - val this_tagged_immediate : Immediate.t -> t - val this_boxed_float : Numbers.Float_by_bit_pattern.t -> t - val this_boxed_int32 : Int32.t -> t - val this_boxed_int64 : Int64.t -> t - val this_boxed_nativeint : Targetint.t -> t - - val these_tagged_immediates : Immediate.Set.t -> t - val these_boxed_floats : Numbers.Float_by_bit_pattern.Set.t -> t - val these_boxed_int32s : Int32.Set.t -> t - val these_boxed_int64s : Int64.Set.t -> t - val these_boxed_nativeints : Targetint.Set.t -> t - - (** Building of types representing untagged / unboxed values from - specified constants. *) - val this_naked_immediate : Immediate.t -> t - val this_naked_float : Numbers.Float_by_bit_pattern.t -> t - val this_naked_int32 : Int32.t -> t - val this_naked_int64 : Int64.t -> t - val this_naked_nativeint : Targetint.t -> t - - val these_naked_immediates : Immediate.Set.t -> t - val these_naked_floats : Numbers.Float_by_bit_pattern.Set.t -> t - val these_naked_int32s : Int32.Set.t -> t - val these_naked_int64s : Int64.Set.t -> t - val these_naked_nativeints : Targetint.Set.t -> t - - val boxed_float_alias_to : naked_float:Variable.t -> t - val boxed_int32_alias_to : naked_int32:Variable.t -> t - val boxed_int64_alias_to : naked_int64:Variable.t -> t - val boxed_nativeint_alias_to : naked_nativeint:Variable.t -> t - - val box_float : t -> t - val box_int32 : t -> t - val box_int64 : t -> t - val box_nativeint : t -> t - - val tagged_immediate_alias_to : naked_immediate:Variable.t -> t - val tag_immediate : t -> t - - val is_int_for_scrutinee : scrutinee:Simple.t -> t - val get_tag_for_block : block:Simple.t -> t - - (* CR mshinwell: decide on exact strategy for mutable blocks *) - - (** The type of an immutable block with a known tag, size and field types. *) - val immutable_block : Tag.t -> field_kind:Flambda_kind.t -> fields:t list -> t - - (** The type of an immutable block with at least [n] fields and an unknown - tag. The type of the [n - 1]th field is taken to be an [Equals] to the - given variable. *) - val immutable_block_with_size_at_least - : n:Targetint.OCaml.t - -> field_kind:Flambda_kind.t - -> field_n_minus_one:Variable.t - -> t - - val this_immutable_string : string -> t - - val mutable_string : size:int -> t - - (** Create a description of a function declaration whose code is known. *) - val create_inlinable_function_declaration - : term_language_function_declaration - -> Rec_info.t - -> Function_declaration_type.t - - (** Create a description of a function declaration whose code is unknown. - Such declarations cannot be inlined, but can be direct called. *) - val create_non_inlinable_function_declaration - : param_arity:Flambda_arity.t - -> result_arity:Flambda_arity.t - -> recursive:Recursive.t - -> Function_declaration_type.t - - val exactly_this_closure - : Closure_id.t - -> all_function_decls_in_set:Function_declaration_type.t Closure_id.Map.t - -> all_closures_in_set:t Closure_id.Map.t - -> all_closure_vars_in_set:flambda_type Var_within_closure.Map.t - -> flambda_type - - val at_least_the_closures_with_ids - : this_closure:Closure_id.t - -> Simple.t Closure_id.Map.t - -> flambda_type - - val closure_with_at_least_this_closure_var - : Var_within_closure.t - -> closure_element_var:Variable.t - -> flambda_type - - val array_of_length : length:flambda_type -> flambda_type - - (** Construct a type equal to the type of the given name. (The name - must be present in the given environment when calling e.g. [join].) *) - val alias_type_of : Flambda_kind.t -> Simple.t -> t - - (** Determine the (unique) kind of a type. *) - val kind : t -> Flambda_kind.t - - (** For each of the kinds in an arity, create an "unknown" type. *) - val unknown_types_from_arity : Flambda_arity.t -> t list - - (** For each of the kinds in an arity, create an "bottom" type. *) - val bottom_types_from_arity : Flambda_arity.t -> t list - - (** Whether the given type says that a term of that type can never be - constructed (in other words, it is [Invalid]). *) - val is_bottom : (t -> bool) type_accessor - - val type_for_const : Simple.Const.t -> t - val kind_for_const : Simple.Const.t -> Flambda_kind.t - - type 'a proof = private - | Proved of 'a - | Unknown - | Invalid - - type 'a proof_allowing_kind_mismatch = private - | Proved of 'a - | Unknown - | Invalid - | Wrong_kind - - (* CR mshinwell: Should remove "_equals_" from these names *) - val prove_equals_tagged_immediates - : Typing_env.t - -> t - -> Immediate.Set.t proof - - val prove_naked_immediates - : Typing_env.t - -> t - -> Immediate.Set.t proof - - val prove_equals_single_tagged_immediate - : Typing_env.t - -> t - -> Immediate.t proof - - val prove_naked_floats - : Typing_env.t - -> t - -> Numbers.Float_by_bit_pattern.Set.t proof - - val prove_naked_int32s : Typing_env.t -> t -> Numbers.Int32.Set.t proof - - val prove_naked_int64s : Typing_env.t -> t -> Numbers.Int64.Set.t proof - - val prove_naked_nativeints : Typing_env.t -> t -> Targetint.Set.t proof - - val prove_is_a_tagged_immediate - : Typing_env.t - -> t - -> unit proof_allowing_kind_mismatch - - val prove_is_a_boxed_float - : Typing_env.t - -> t - -> unit proof_allowing_kind_mismatch - - val prove_is_a_boxed_int32 - : Typing_env.t - -> t - -> unit proof_allowing_kind_mismatch - - val prove_is_a_boxed_int64 - : Typing_env.t - -> t - -> unit proof_allowing_kind_mismatch - - val prove_is_a_boxed_nativeint - : Typing_env.t - -> t - -> unit proof_allowing_kind_mismatch - - val prove_boxed_floats : Typing_env.t -> t -> Float.Set.t proof - val prove_boxed_int32s : Typing_env.t -> t -> Numbers.Int32.Set.t proof - val prove_boxed_int64s : Typing_env.t -> t -> Numbers.Int64.Set.t proof - val prove_boxed_nativeints : Typing_env.t -> t -> Targetint.Set.t proof - - val prove_tags_and_sizes - : Typing_env.t - -> t - -> Targetint.OCaml.t Tag.Map.t proof - - val prove_unique_tag_and_size - : Typing_env.t - -> t - -> (Tag.t * Targetint.OCaml.t) proof_allowing_kind_mismatch - - val prove_is_int : Typing_env.t -> t -> bool proof - - (** Prove that the given type, of kind [Value], is a closures type - describing exactly one closure. The function declaration corresponding - to such closure is returned together with its closure ID, if it is - known. *) - val prove_single_closures_entry - : Typing_env.t - -> t - -> (Closure_id.t * Closures_entry.t - * Function_declaration_type.t Or_unknown.t) proof - - val prove_single_closures_entry' - : Typing_env.t - -> t - -> (Closure_id.t * Closures_entry.t - * Function_declaration_type.t Or_unknown.t) - proof_allowing_kind_mismatch - - val prove_strings : Typing_env.t -> t -> String_info.Set.t proof - - type var_or_symbol_or_tagged_immediate = private - | Var of Variable.t - | Symbol of Symbol.t - | Tagged_immediate of Immediate.t - - type to_lift = (* private *) (* CR mshinwell: resurrect *) - | Immutable_block of - Tag.Scannable.t * (var_or_symbol_or_tagged_immediate list) - | Boxed_float of Float.t - | Boxed_int32 of Int32.t - | Boxed_int64 of Int64.t - | Boxed_nativeint of Targetint.t - - type reification_result = private - | Lift of to_lift (* CR mshinwell: rename? *) - | Lift_set_of_closures of { - closure_id : Closure_id.t; - function_decls : term_language_function_declaration Closure_id.Map.t; - closure_vars : Simple.t Var_within_closure.Map.t; - } - | Simple of Simple.t - | Cannot_reify - | Invalid - - val reify - : ?allowed_free_vars:Variable.Set.t - -> Typing_env.t - -> min_name_mode:Name_mode.t - -> t - -> reification_result -end diff --git a/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml b/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml index 53aef54602f3..022b64f4a821 100644 --- a/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml +++ b/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml @@ -273,7 +273,7 @@ end module Closures_info = struct type t = { closure_id : Closure_id.t; - func_decl_type : T.Function_declaration_type.t; + func_decl_type : T.Function_declaration_type.t0; closure_type : T.t; } end @@ -289,7 +289,8 @@ struct let make_boxed_value (info : Info.t) ~fields:closure_vars = let all_function_decls_in_set = - Closure_id.Map.singleton info.closure_id info.func_decl_type + Closure_id.Map.singleton info.closure_id + (Or_unknown_or_bottom.Ok info.func_decl_type) in let all_closures_in_set = Closure_id.Map.singleton info.closure_id info.closure_type @@ -469,7 +470,7 @@ let rec make_unboxing_decision typing_env ~depth ~arg_types_by_use_id | Wrong_kind | Invalid | Unknown -> (* CR-someday mshinwell: We could support more than a unique closure. *) match T.prove_single_closures_entry' typing_env param_type with - | Proved (closure_id, closures_entry, Known func_decl_type) -> + | Proved (closure_id, closures_entry, Ok func_decl_type) -> let closure_var_types = T.Closures_entry.closure_var_types closures_entry in @@ -483,7 +484,7 @@ let rec make_unboxing_decision typing_env ~depth ~arg_types_by_use_id Closures.unbox_one_parameter typing_env ~depth ~arg_types_by_use_id ~param_type extra_params_and_args ~unbox_value:make_unboxing_decision info closure_vars K.value - | Proved (_, _, Unknown) | Wrong_kind | Invalid | Unknown -> + | Proved (_, _, (Unknown | Bottom)) | Wrong_kind | Invalid | Unknown -> let rec try_unboxing = function | [] -> typing_env, param_type, extra_params_and_args | (prover, unboxer, tag, kind) :: decisions -> From cdaf8931ef6421e24606279d2b4d1e747be8efd5 Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Thu, 19 Dec 2019 18:12:05 +0100 Subject: [PATCH 02/80] Adapt Un_cps to let_code --- middle_end/flambda2.0/to_cmm/un_cps.ml | 275 +++++++++++------- .../flambda2.0/to_cmm/un_cps_closure.ml | 64 ++-- .../flambda2.0/to_cmm/un_cps_closure.mli | 10 +- middle_end/flambda2.0/to_cmm/un_cps_env.ml | 32 ++ middle_end/flambda2.0/to_cmm/un_cps_env.mli | 17 ++ middle_end/flambda2.0/to_cmm/un_cps_helper.ml | 5 +- .../flambda2.0/to_cmm/un_cps_helper.mli | 7 +- 7 files changed, 260 insertions(+), 150 deletions(-) diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 36595351f240..bcbd889b5fb0 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -56,6 +56,7 @@ module R = struct current_data : Cmm.data_item list; other_data : Cmm.data_item list list; gc_roots : Symbol.t list; + functions : Cmm.phrase list; } let empty = { @@ -63,6 +64,7 @@ module R = struct current_data = []; other_data = []; gc_roots = []; + functions = []; } let add_if_not_empty x l = @@ -78,6 +80,7 @@ module R = struct add_if_not_empty t.current_data ( (r.other_data @ t.other_data))); gc_roots = r.gc_roots @ t.gc_roots; + functions = r.functions @ t.functions; } let archive_data r = @@ -96,6 +99,9 @@ module R = struct let add_gc_roots l r = { r with gc_roots = l @ r.gc_roots; } + let add_function f r = + { r with functions = f :: r.functions; } + let to_cmm r = let entry = let dbg = Debuginfo.none in @@ -112,7 +118,7 @@ module R = struct in let data_list = add_if_not_empty r.current_data r.other_data in let data = List.map C.cdata data_list in - data, entry, r.gc_roots + data, entry, r.gc_roots, r.functions end @@ -852,8 +858,20 @@ and apply_call env e = (* Effects from arguments are ignored since a function call will always be given arbitrary effects and coeffects. *) | Call_kind.Function (* FIXME Let code *) - Call_kind.Function_call.Direct { code_id = _; closure_id = _; return_arity = _; } -> - assert false + Call_kind.Function_call.Direct { code_id; closure_id = _; return_arity; } -> + let info = Env.get_function_info env code_id in + let ty = machtype_of_return_arity return_arity in + let args, env, _ = arg_list env (Apply_expr.args e) in + let args, env = + match (info : Env.function_info option) with + | None | Some { needs_closure_arg = true; } -> + let f, env, _ = simple env f in + args @ [f], env + | Some { needs_closure_arg = false; } -> + args, env + in + let f_code = symbol (Code_id.code_symbol code_id) in + C.direct_call ~dbg ty (C.symbol f_code) args, env, effs (* let f_code = Un_cps_closure.(closure_code (closure_name closure_id)) in let f, env, _ = simple env f in @@ -1162,8 +1180,62 @@ and fill_up_to j acc i = if i = j then acc else fill_up_to j (C.int 1 :: acc) (i + 1) +(* Translate a function declaration. *) + +let is_var_used v e = + let free_names = Expr.free_names e in + let occurrence = Name_occurrences.greatest_name_mode_var free_names v in + match (occurrence : Name_mode.Or_absent.t) with + | Absent -> false + | Present _k -> + (* CR mshinwell: I think this should always be [true]. Even if the + variable is only used by phantom bindings, it still needs to be + there. This may only arise in unusual cases (e.g. [my_closure] + that is used only by phantom bindings). *) + true + (* Name_mode.is_normal k *) + +let function_args vars my_closure body = + if is_var_used my_closure body then begin + let param = Parameter.wrap my_closure in + let last_arg = Kinded_parameter.create param Flambda_kind.value in + vars @ [last_arg] + end else + vars + +let function_flags () = + if !Clflags.optimize_for_speed then + [] + else + [ Cmm.Reduce_code_size ] + +let params_and_body env fun_name fun_dbg p = + Function_params_and_body.pattern_match p + ~f:(fun ~return_continuation:k k_exn vars ~body ~my_closure -> + try + let args = function_args vars my_closure body in + let k_exn = Exn_continuation.exn_handler k_exn in + (* Init the env and create a jump id for the ret closure + in case a trap action is attached to one of tis call *) + let env = Env.enter_function_def env k k_exn in + (* translate the arg list and body *) + let env, fun_args = var_list env args in + let fun_body = expr env body in + let fun_flags = function_flags () in + C.fundecl fun_name fun_args fun_body fun_flags fun_dbg + with Misc.Fatal_error as e -> + Format.eprintf "\n%sContext is:%s translating function %s to Cmm \ + with body@ %a\n" + (Flambda_colours.error ()) + (Flambda_colours.normal ()) + fun_name + Expr.print body; + raise e) + (* Static structures *) +module SP = Flambda_static.Static_part + let static_value _env v = match (v : Flambda_static.Of_kind_value.t) with | Symbol s -> C.symbol_address (symbol s) @@ -1172,12 +1244,12 @@ let static_value _env v = C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i))) let or_variable f default v cont = - match (v : _ Flambda_static.Static_part.or_variable) with + match (v : _ SP.or_variable) with | Const c -> f c cont | Var _ -> f default cont let map_or_variable f default v = - match (v : _ Flambda_static.Static_part.or_variable) with + match (v : _ SP.or_variable) with | Const c -> f c | Var _ -> default @@ -1201,7 +1273,7 @@ let rec static_block_updates symb env acc i = function let rec static_float_array_updates symb env acc i = function | [] -> List.fold_left C.sequence C.void acc | sv :: r -> - begin match (sv : _ Flambda_static.Static_part.or_variable) with + begin match (sv : _ SP.or_variable) with | Const _ -> static_float_array_updates symb env acc (i + 1) r | Var var -> @@ -1213,7 +1285,7 @@ let static_boxed_number kind env s default emit transl v r = let name = symbol s in let aux x cont = emit (name, Cmmgen_state.Global) (transl x) cont in let wrapper = - match (v : _ Flambda_static.Static_part.or_variable) with + match (v : _ SP.or_variable) with | Const _ -> Fun.id | Var v -> let update = make_update env kind (C.symbol name) v 0 in @@ -1326,33 +1398,76 @@ let static_structure_item env r let static_fields = List.map (static_value env) fields in let block = C.emit_block block_name header static_fields in let e = static_block_updates (C.symbol name) env [] 0 fields in - R.wrap_init (C.sequence e) (R.add_data block r) + env, R.wrap_init (C.sequence e) (R.add_data block r) | Singleton _, Fabricated_block _ -> (* CR Gbury: What are those ? *) todo() - | Code_and_set_of_closures _ (* s *), Code_and_set_of_closures _ (* set *) -> - assert false (* FIXME Let code *) -(* - let data, updates = - static_set_of_closures env s.closure_symbols set + | Code_and_set_of_closures { code_ids = _; closure_symbols; }, + Code_and_set_of_closures { code; set_of_closures; } -> + (* We cannot both build the environment and compile the functions in + one traversal, as the bodies may contain direct calls to the code ids + being defined *) + let updated_env = + Code_id.Map.fold + (fun code_id SP.({ params_and_body = p; newer_version_of = _; }) env -> + match (p : _ SP.or_deleted) with + | Deleted -> env + | Present p -> + Function_params_and_body.pattern_match p + ~f:(fun ~return_continuation:_ _exn_k _ps ~body ~my_closure -> + let free_vars = + Name_occurrences.variables (Expr.free_names body) + in + (* Format.eprintf "Free vars: %a@." Variable.Set.print free_vars; *) + let needs_closure_arg = + Variable.Set.mem my_closure free_vars + in + let info : Env.function_info = { needs_closure_arg; } in + Env.add_function_info env code_id info)) + code + env in - R.wrap_init (C.sequence updates) (R.add_data data r) -*) + let r = + Code_id.Map.fold + (fun code_id SP.({ params_and_body = p; newer_version_of = _; }) r -> + match (p : _ SP.or_deleted) with + | Deleted -> r + | Present p -> + let fun_symbol = Code_id.code_symbol code_id in + let fun_name = + Linkage_name.to_string (Symbol.linkage_name fun_symbol) + in + (* CR vlaviron: fix debug info *) + let fundecl = + C.cfunction (params_and_body updated_env fun_name Debuginfo.none p) + in + R.add_function fundecl r) + code + r + in + begin match set_of_closures with + | None -> updated_env, r + | Some set -> + let data, updates = + static_set_of_closures env closure_symbols set + in + updated_env, R.wrap_init (C.sequence updates) (R.add_data data r) + end | Singleton s, Boxed_float v -> let default = Numbers.Float_by_bit_pattern.zero in let transl = Numbers.Float_by_bit_pattern.to_float in - static_boxed_number + env, static_boxed_number Cmm.Double_u env s default C.emit_float_constant transl v r | Singleton s, Boxed_int32 v -> - static_boxed_number + env, static_boxed_number Cmm.Word_int env s 0l C.emit_int32_constant Fun.id v r | Singleton s, Boxed_int64 v -> - static_boxed_number + env, static_boxed_number Cmm.Word_int env s 0L C.emit_int64_constant Fun.id v r | Singleton s, Boxed_nativeint v -> let default = Targetint.zero in let transl = nativeint_of_targetint in - static_boxed_number + env, static_boxed_number Cmm.Word_int env s default C.emit_nativeint_constant transl v r | Singleton s, Immutable_float_array fields -> let name = symbol s in @@ -1362,7 +1477,7 @@ let static_structure_item env r C.emit_float_array_constant (name, Cmmgen_state.Global) static_fields in let e = static_float_array_updates (C.symbol name) env [] 0 fields in - R.wrap_init (C.sequence e) (R.update_data float_array r) + env, R.wrap_init (C.sequence e) (R.update_data float_array r) | Singleton s, Mutable_string { initial_value; } | Singleton s, Immutable_string initial_value -> let name = symbol s in @@ -1373,7 +1488,7 @@ let static_structure_item env r Misc.fatal_errorf "Trying to initialize a string of unknown length" | Const str -> let data = C.emit_string_constant (name, Cmmgen_state.Global) str in - R.update_data data r + env, R.update_data data r end let static_structure env is_fully_static s = @@ -1389,30 +1504,31 @@ let static_structure env is_fully_static s = (Flambda_static.Program_body.Static_structure.being_defined s) in let r = R.add_gc_roots roots R.empty in - List.fold_left (fun acc item -> + List.fold_left (fun (env_acc, r_acc) item -> + let env, r = static_structure_item env_acc r_acc item in (* Archive_data helps keep definitions of separate symbols in different data_item lists and this increases readability of the generated cmm. *) - R.archive_data (static_structure_item env acc item) - ) r s + env, R.archive_data r + ) (env, r) s (* Definition *) -let computation_wrapper offsets used_closure_vars c = +let computation_wrapper env c = match c with | None -> - Env.dummy offsets used_closure_vars, (fun x -> x), true + env, (fun x -> x), true | Some (c : Flambda_static.Program_body.Computation.t) -> (* The env for the computation is given a dummy continuation, since the return continuation will be explicitly bound to a jump before translating the computation. *) let dummy_k = Continuation.create () in let k_exn = Exn_continuation.exn_handler c.exn_continuation in - let c_env = Env.mk offsets dummy_k k_exn used_closure_vars in + let c_env = Env.enter_function_def env dummy_k k_exn in (* The environment for the static structure update must contain the variables produced by the computation. It is given dummy continuations, given that the return continuation will not be used. *) - let s_env = Env.mk offsets dummy_k dummy_k used_closure_vars in + let s_env = Env.enter_function_def env dummy_k dummy_k in let s_env, vars = var_list s_env c.computed_values in (* Wrap the static structure update expression [e] by manually translating the computation return continuation by a jump to @@ -1435,76 +1551,17 @@ let computation_wrapper offsets used_closure_vars c = the variable definitions. *) s_env, wrap, false -let definition offsets ~used_closure_vars - (d : Flambda_static.Program_body.Definition.t) = +let definition env (d : Flambda_static.Program_body.Definition.t) = let env, wrapper, is_fully_static = - computation_wrapper offsets used_closure_vars d.computation + computation_wrapper env d.computation in - let r = static_structure env is_fully_static d.static_structure in - R.wrap_init wrapper r - - -(* Translate a function declaration. *) - -let is_var_used v e = - let free_names = Expr.free_names e in - let occurrence = Name_occurrences.greatest_name_mode_var free_names v in - match (occurrence : Name_mode.Or_absent.t) with - | Absent -> false - | Present _k -> - (* CR mshinwell: I think this should always be [true]. Even if the - variable is only used by phantom bindings, it still needs to be - there. This may only arise in unusual cases (e.g. [my_closure] - that is used only by phantom bindings). *) - true - (* Name_mode.is_normal k *) - -let function_args vars my_closure body = - if is_var_used my_closure body then begin - let param = Parameter.wrap my_closure in - let last_arg = Kinded_parameter.create param Flambda_kind.value in - vars @ [last_arg] - end else - vars - -let function_flags () = - if !Clflags.optimize_for_speed then - [] - else - [ Cmm.Reduce_code_size ] + let env, r = static_structure env is_fully_static d.static_structure in + env, R.wrap_init wrapper r -let function_decl _offsets _used_closure_vars fun_name _ d = - Profile.record_call ~accumulate:true fun_name (fun () -> - let _fun_dbg = Function_declaration.dbg d in - assert false (* FIXME Let code *) ) -(* - let p = Function_declaration.params_and_body d in - Function_params_and_body.pattern_match p - ~f:(fun ~return_continuation:k k_exn vars ~body ~my_closure -> - try - let args = function_args vars my_closure body in - let k_exn = Exn_continuation.exn_handler k_exn in - (* Init the env and create a jump id for the ret closure - in case a trap action is attached to one of tis call *) - let env = Env.mk offsets k k_exn used_closure_vars in - (* translate the arg list and body *) - let env, fun_args = var_list env args in - let fun_body = expr env body in - let fun_flags = function_flags () in - C.fundecl fun_name fun_args fun_body fun_flags fun_dbg - with Misc.Fatal_error as e -> - Format.eprintf "\n%sContext is:%s translating function %s to Cmm \ - with body@ %a\n" - (Flambda_colours.error ()) - (Flambda_colours.normal ()) - fun_name - Expr.print body; - raise e)) -*) (* Programs *) -let rec program_body offsets ~used_closure_vars acc body = +let rec program_body env acc body = match Flambda_static.Program_body.descr body with | Flambda_static.Program_body.Root _sym -> (* The root symbol does not really deserve any particular treatment. @@ -1513,19 +1570,19 @@ let rec program_body offsets ~used_closure_vars acc body = in the list of gc_roots, else it does not *have* to be a root. *) List.fold_left (fun acc r -> R.combine r acc) R.empty acc | Flambda_static.Program_body.Definition (def, rest) -> - let r = definition offsets ~used_closure_vars def in - program_body offsets ~used_closure_vars (r :: acc) rest - -let program_functions offsets used_closure_vars p = - let aux = function_decl offsets used_closure_vars in - let fmap = Un_cps_closure.map_on_function_decl aux p in - let all_functions = Closure_id.Map.fold (fun _ x acc -> x :: acc) fmap [] in - (* This is to keep the current cmmgen behaviour which sorts functions by - debuginfo (and thus keeps the order of declaration). *) - let sorted = List.sort - (fun f f' -> Debuginfo.compare f.Cmm.fun_dbg f'.Cmm.fun_dbg) all_functions - in - List.map (fun decl -> C.cfunction decl) sorted + let env, r = definition env def in + program_body env (r :: acc) rest + +(* let program_functions offsets used_closure_vars p = + * let aux = function_decl offsets used_closure_vars in + * let fmap = Un_cps_closure.map_on_function_decl aux p in + * let all_functions = Closure_id.Map.fold (fun _ x acc -> x :: acc) fmap [] in + * (\* This is to keep the current cmmgen behaviour which sorts functions by + * debuginfo (and thus keeps the order of declaration). *\) + * let sorted = List.sort + * (fun f f' -> Debuginfo.compare f.Cmm.fun_dbg f'.Cmm.fun_dbg) all_functions + * in + * List.map (fun decl -> C.cfunction decl) sorted *) let program (p : Flambda_static.Program.t) = Profile.record_call "flambda2_to_cmm" (fun () -> @@ -1533,9 +1590,11 @@ let program (p : Flambda_static.Program.t) = let used_closure_vars = Name_occurrences.closure_vars (Flambda_static.Program.free_names p) in - let functions = program_functions offsets used_closure_vars p in - let res = program_body ~used_closure_vars offsets [] p.body in - let data, entry, gc_roots = R.to_cmm res in + let dummy_k = Continuation.create () in + let env = Env.mk offsets dummy_k dummy_k used_closure_vars in + (* let functions = program_functions offsets used_closure_vars p in *) + let res = program_body env [] p.body in + let data, entry, gc_roots, functions = R.to_cmm res in let cmm_data = C.flush_cmmgen_state () in let roots = List.map symbol gc_roots in (C.gc_root_table roots) :: data @ cmm_data @ functions @ [entry] diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml index de81fc3566f1..6f03276b2a80 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml @@ -580,8 +580,7 @@ module Iter_on_sets_of_closures = struct match (n : Named.t) with | Simple _ | Prim _ -> () | Set_of_closures s -> - let () = f None s in - set_of_closures f s + f None s and let_expr f t = Let.pattern_match t ~f:(fun ~bound_vars:_ ~body -> @@ -628,12 +627,7 @@ module Iter_on_sets_of_closures = struct and invalid _ _ = () - and set_of_closures f s = - let decls = Set_of_closures.function_decls s in - let map = Function_declarations.funs decls in - Closure_id.Map.iter (fun_decl f) map - - and fun_decl _f _ _decl = assert false (* FIXME Let code *) + (* and fun_decl _f _ _decl = assert false (\* FIXME Let code *\) *) (* let t = Function_declaration.params_and_body decl in Function_params_and_body.pattern_match t @@ -645,13 +639,22 @@ module Iter_on_sets_of_closures = struct let computation f c = Flambda_static.Program_body.Computation.iter_expr c ~f:(expr f) - let static_structure_aux _ _ = assert false (* f + let static_structure_aux f ((S (symbs, st)) : Flambda_static.Program_body.Static_structure.t0) = match symbs, st with - | Set_of_closures r, Set_of_closures s -> - f (Some r.closure_symbols) s; - set_of_closures f s - | _ -> () *) (* FIXME Let code *) + | Code_and_set_of_closures { code_ids = _; closure_symbols; }, + Code_and_set_of_closures { code; set_of_closures = s; } -> + Option.iter (fun s -> f (Some closure_symbols) s) s; + Code_id.Map.iter (fun _ { Flambda_static.Static_part.params_and_body; + newer_version_of = _; } -> + match params_and_body with + | Deleted -> () + | Present params_and_body -> + Function_params_and_body.pattern_match params_and_body + ~f:(fun ~return_continuation:_ _ _ ~body ~my_closure:_ -> + expr f body)) + code + | _ -> () let static_structure f s = List.iter (static_structure_aux f) s @@ -692,10 +695,10 @@ let closure_name id = let name = Compilation_unit.get_linkage_name compunit in Format.asprintf "%a__%s" Linkage_name.print name (Closure_id.to_string id) -let closure_id_name o id = - match o with - | None -> closure_name id - | Some _map -> closure_name id +(* let closure_id_name o id = + * match o with + * | None -> closure_name id + * | Some _map -> closure_name id *) (* (* CR Gbury: is this part really necessary ? why not always return closure_name id ? *) @@ -706,18 +709,17 @@ let closure_id_name o id = let closure_code s = Format.asprintf "%s_code" s -let map_on_function_decl f program = - (* CR vlaviron: Why was this Code_id ? *) - let map = ref Closure_id.Map.empty in - let aux o s = - let decls = Set_of_closures.function_decls s in - let funs = Function_declarations.funs decls in - Closure_id.Map.iter (fun closure_id decl -> - let name = closure_code (closure_id_name o closure_id) in - if not (Closure_id.Map.mem closure_id !map) then - map := Closure_id.Map.add closure_id (f name closure_id decl) !map - ) funs - in - Iter_on_sets_of_closures.program aux program; - !map +(* let map_on_function_decl f program = + * let map = ref Code_id.Map.empty in + * let aux o s = + * let decls = Set_of_closures.function_decls s in + * let funs = Function_declarations.funs decls in + * Closure_id.Map.iter (fun closure_id decl -> + * let name = closure_code (closure_id_name o closure_id) in + * if not (Closure_id.Map.mem closure_id !map) then + * map := Closure_id.Map.add closure_id (f name closure_id decl) !map + * ) funs + * in + * Iter_on_sets_of_closures.program aux program; + * !map *) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.mli b/middle_end/flambda2.0/to_cmm/un_cps_closure.mli index 5fa86899ebe4..0e0381f58147 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.mli @@ -45,11 +45,11 @@ val closure_code : string -> string (** Returns the address for a function code from the global name of a closure. *) -val map_on_function_decl : - (string -> Closure_id.t -> Flambda.Function_declaration.t -> 'a) -> - Flambda_static.Program.t -> 'a Closure_id.Map.t -(** Map a function on each function body exactly once, and return the - resulting mapping. *) +(* val map_on_function_decl : + * (string -> Closure_id.t -> Flambda.Function_declaration.t -> 'a) -> + * Flambda_static.Program.t -> 'a Closure_id.Map.t + * (\** Map a function on each function body exactly once, and return the + * resulting mapping. *\) *) type layout_slot = diff --git a/middle_end/flambda2.0/to_cmm/un_cps_env.ml b/middle_end/flambda2.0/to_cmm/un_cps_env.ml index d33813adcab2..f97db50c2ebd 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_env.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_env.ml @@ -71,6 +71,11 @@ type stage = (* Translation environment *) +type function_info = { + needs_closure_arg : bool; + (* Whether direct calls need to provide a closure or can skip it *) +} + type t = { k_return : Continuation.t; (* The continuation of the current context @@ -82,6 +87,9 @@ type t = { (* Closure variables that are used by the context begin translated. (used to remove unused closure variables). *) + functions_info: function_info Code_id.Map.t; + (* Information about known functions *) + vars : Cmm.expression Variable.Map.t; (* Map from flambda2 variables to backend_variables *) conts : cont Continuation.Map.t; @@ -101,6 +109,19 @@ type t = { let mk offsets k_return k_exn used_closure_vars = { k_return; k_exn; used_closure_vars; offsets; + functions_info = Code_id.Map.empty; + stages = []; + pures = Variable.Map.empty; + vars = Variable.Map.empty; + conts = Continuation.Map.empty; + exn_conts_extra_args = Continuation.Map.empty; +} + +let enter_function_def env k_return k_exn = { + k_return; k_exn; + used_closure_vars = env.used_closure_vars; + offsets = env.offsets; + functions_info = env.functions_info; stages = []; pures = Variable.Map.empty; vars = Variable.Map.empty; @@ -118,6 +139,17 @@ let dummy offsets used_closure_vars = let return_cont env = env.k_return let exn_cont env = env.k_exn +(* Function info *) + +let add_function_info env code_id info = + let functions_info = + Code_id.Map.add code_id info env.functions_info + in + { env with functions_info; } + +let get_function_info env code_id = + Code_id.Map.find_opt code_id env.functions_info + (* Variables *) let gen_variable v = diff --git a/middle_end/flambda2.0/to_cmm/un_cps_env.mli b/middle_end/flambda2.0/to_cmm/un_cps_env.mli index cccd5e0d01a7..f6f6a59431d6 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_env.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_env.mli @@ -27,6 +27,11 @@ val mk : translating a flambda2 expression, with return continuation [k], exception continuation [k_exn], and which uses the given closures variables. *) +val enter_function_def : t -> Continuation.t -> Continuation.t -> t +(** [enter_function_def env k k_exn] creates a local environment for + translating a flambda2 expression, with return continuation [k], exception + continuation [k_exn], preserving the global info from [env]. *) + val dummy : Un_cps_closure.env -> Var_within_closure.Set.t -> t (** Create an environment with dummy return adn exception continuations. *) @@ -39,6 +44,18 @@ val return_cont : t -> Continuation.t val exn_cont : t -> Continuation.t (** Returns the exception continuation of the environment. *) +(** {2 Function info *) + +type function_info = { + needs_closure_arg : bool; + (* Whether direct calls need to provide a closure or can skip it *) +} + +val add_function_info : t -> Code_id.t -> function_info -> t +(** Add information on the given function *) + +val get_function_info : t -> Code_id.t -> function_info option +(** Retrieve known information on the given function *) (** {2 Variable bindings} *) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_helper.ml b/middle_end/flambda2.0/to_cmm/un_cps_helper.ml index 8bf51425630d..f6bbaac603d1 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_helper.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_helper.ml @@ -474,9 +474,8 @@ let ccatch ~rec_flag ~handlers ~body = (* Function calls *) -(* CR vlaviron: the closure, f, should not always be necessary (if the function is closed). *) -let direct_call ?(dbg=Debuginfo.none) ty f_code_sym args f = - Cmm.Cop (Cmm.Capply ty, f_code_sym :: args @ [f], dbg) +let direct_call ?(dbg=Debuginfo.none) ty f_code_sym args = + Cmm.Cop (Cmm.Capply ty, f_code_sym :: args, dbg) let indirect_call ?(dbg=Debuginfo.none) ty f = function | [arg] -> diff --git a/middle_end/flambda2.0/to_cmm/un_cps_helper.mli b/middle_end/flambda2.0/to_cmm/un_cps_helper.mli index 25f523cf382e..a605fdf83216 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_helper.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_helper.mli @@ -334,9 +334,10 @@ val float_of_int : ?dbg:Debuginfo.t -> Cmm.expression -> Cmm.expression val direct_call : ?dbg:Debuginfo.t -> - Cmm.machtype -> Cmm.expression -> Cmm.expression list -> Cmm.expression -> Cmm.expression -(** [direct_call ty f_code args f] creates a direct call to the function code [f_code] with - arguments [args], and closure [f], with a return value of type [ty]. *) + Cmm.machtype -> Cmm.expression -> Cmm.expression list -> Cmm.expression +(** [direct_call ty f_code args] creates a direct call to the function code [f_code] with + arguments [args], with a return value of type [ty]. + If a closure needs to be passed, it must be included in [args]. *) val indirect_call : ?dbg:Debuginfo.t -> From d225d11c987b59ab124283ff005186c771b76abd Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Thu, 19 Dec 2019 18:28:48 +0100 Subject: [PATCH 03/80] Fix Code_id.code_symbol --- middle_end/flambda2.0/basic/code_id.ml | 2 +- middle_end/flambda2.0/basic/id_types.ml | 2 ++ middle_end/flambda2.0/basic/id_types.mli | 1 + 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/middle_end/flambda2.0/basic/code_id.ml b/middle_end/flambda2.0/basic/code_id.ml index 0a480aec8019..05bfdcadacbf 100644 --- a/middle_end/flambda2.0/basic/code_id.ml +++ b/middle_end/flambda2.0/basic/code_id.ml @@ -38,7 +38,7 @@ let in_compilation_unit t cu = Compilation_unit.equal (get_compilation_unit t) cu let code_symbol t = - let linkage_name = Linkage_name.create (name t ^ "_code") in + let linkage_name = Linkage_name.create (Unit_id.unique_name t ^ "_code") in Symbol.create (get_compilation_unit t) linkage_name let invert_map map = diff --git a/middle_end/flambda2.0/basic/id_types.ml b/middle_end/flambda2.0/basic/id_types.ml index 17c97c48af69..e9449f4664f9 100644 --- a/middle_end/flambda2.0/basic/id_types.ml +++ b/middle_end/flambda2.0/basic/id_types.ml @@ -39,6 +39,7 @@ module type UnitId = sig include BaseId val create : ?name:string -> Compilation_unit.t -> t val unit : t -> Compilation_unit.t + val unique_name : t -> string end module Id(_:sig end) : Id = struct @@ -84,6 +85,7 @@ module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : let hash off = Hashtbl.hash off let equal o1 o2 = compare o1 o2 = 0 let name o = Innerid.name o.id + let unique_name o = Innerid.to_string o.id let rename t = { id = Innerid.rename t.id; diff --git a/middle_end/flambda2.0/basic/id_types.mli b/middle_end/flambda2.0/basic/id_types.mli index 29c8ee845bb4..dae018e81f64 100644 --- a/middle_end/flambda2.0/basic/id_types.mli +++ b/middle_end/flambda2.0/basic/id_types.mli @@ -45,6 +45,7 @@ sig include BaseId val create : ?name:string -> Compilation_unit.t -> t val unit : t -> Compilation_unit.t + val unique_name : t -> string end (** If applied generatively, i.e. [Id(struct end)], creates a new type From acb44b3397654ab714ffb81a103302720c0e80f0 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Dec 2019 13:45:17 +0000 Subject: [PATCH 04/80] Remove commented code from tests8.ml --- flambdatest/mlexamples/tests8.ml | 41 -------------------------------- 1 file changed, 41 deletions(-) diff --git a/flambdatest/mlexamples/tests8.ml b/flambdatest/mlexamples/tests8.ml index 0eda88a3c26e..1e8c76b942ea 100644 --- a/flambdatest/mlexamples/tests8.ml +++ b/flambdatest/mlexamples/tests8.ml @@ -3,48 +3,7 @@ type +'a node = | Cons of 'a * 'a t and 'a t = unit -> 'a node -(* -let rec map f seq () = - match seq () with - | Nil -> Nil - | Cons (x, next) -> - Cons (f x, map f next) -let rec filter_map f seq () = match seq() with - | Nil -> Nil - | Cons (x, next) -> - match f x with - | None -> filter_map f next () - | Some y -> Cons (y, filter_map f next) - -let rec filter f seq () = match seq() with - | Nil -> Nil - | Cons (x, next) -> - if f x - then Cons (x, filter f next) - else filter f next () - -let rec flat_map f seq () = match seq () with - | Nil -> Nil - | Cons (x, next) -> - flat_map_app f (f x) next () - -(* this is [append seq (flat_map f tail)] *) -and flat_map_app f seq tail () = match seq () with - | Nil -> flat_map f tail () - | Cons (x, next) -> - Cons (x, flat_map_app f next tail) - -let fold_left f acc seq = - let rec aux f acc seq = - match seq () with - | Nil -> acc - | Cons (x, next) -> - let acc = f acc x in - aux f acc next - in - aux f acc seq -*) let iter f seq = let rec aux seq = match seq () with | Nil -> () From 817432c45edfef150128c8fb018580845a981608 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Dec 2019 14:36:23 +0000 Subject: [PATCH 05/80] Minor changes for code --- middle_end/flambda2.0/terms/flambda_static.mli | 3 --- middle_end/flambda2.0/types/structures/code_age_relation.mli | 4 ++-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/middle_end/flambda2.0/terms/flambda_static.mli b/middle_end/flambda2.0/terms/flambda_static.mli index ea49498f69c1..4adfe7cd7a86 100644 --- a/middle_end/flambda2.0/terms/flambda_static.mli +++ b/middle_end/flambda2.0/terms/flambda_static.mli @@ -52,9 +52,6 @@ module Static_part : sig | Present of 'a | Deleted - (* CR mshinwell: Code_id.t to Symbol.t needs to be doable without any - state *) - (** The possibly-recursive declaration of pieces of code and any associated set of closures. *) type code_and_set_of_closures = { diff --git a/middle_end/flambda2.0/types/structures/code_age_relation.mli b/middle_end/flambda2.0/types/structures/code_age_relation.mli index 55f2a6b8b628..2c4dd39d258c 100644 --- a/middle_end/flambda2.0/types/structures/code_age_relation.mli +++ b/middle_end/flambda2.0/types/structures/code_age_relation.mli @@ -26,11 +26,11 @@ val empty : t val add : t -> newer:Code_id.t -> older:Code_id.t -> t -(** [meet] calculates which of the given pieces of code is older, or +(** [meet] calculates which of the given pieces of code is newer, or identifies that the pieces of code are unrelated. *) val meet : t -> Code_id.t -> Code_id.t -> Code_id.t Or_bottom.t -(** [join] calculates which of the given pieces of code is newer, or +(** [join] calculates the newest common ancestor of the given pieces of code, or identifies that the pieces of code are unrelated. *) val join : t -> Code_id.t -> Code_id.t -> Code_id.t Or_unknown.t From c2efc884f71a7e83f211ee473ad0cfa734dccbc8 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Dec 2019 14:44:36 +0000 Subject: [PATCH 06/80] Remove middle_end/flambda2.0/types/basic/term_language_function_declaration.ml --- .../term_language_function_declaration.ml | 27 ------------------- 1 file changed, 27 deletions(-) delete mode 100644 middle_end/flambda2.0/types/basic/term_language_function_declaration.ml diff --git a/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml b/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml deleted file mode 100644 index af2f918065f8..000000000000 --- a/middle_end/flambda2.0/types/basic/term_language_function_declaration.ml +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2018--2019 OCamlPro SAS *) -(* Copyright 2018--2019 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-30-40-41-42"] - -module type S = sig - include Expr_std.S - val print_compact : Format.formatter -> t -> unit - val code_id : t -> Code_id.t -end - -module type S_code = sig - include Expr_std.S -end \ No newline at end of file From b477fc06b936acfee0ab4f70f25aed5b69b09494 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Dec 2019 17:11:34 +0000 Subject: [PATCH 07/80] Remove middle_end/flambda2.0/types/basic/term_language_function_declaration.ml --- flambdatest/mlexamples/tests8.ml | 6 ++ .../simplify/simplify_static.rec.ml | 101 ++++++++++++++---- 2 files changed, 84 insertions(+), 23 deletions(-) diff --git a/flambdatest/mlexamples/tests8.ml b/flambdatest/mlexamples/tests8.ml index 1e8c76b942ea..718896ad3ba3 100644 --- a/flambdatest/mlexamples/tests8.ml +++ b/flambdatest/mlexamples/tests8.ml @@ -4,6 +4,11 @@ type +'a node = and 'a t = unit -> 'a node +let rec map_foo f seq () = match seq() with + | Nil -> Nil + | Cons (x, next) -> + Cons (f x, fun () -> (map_foo [@inlined never]) (fun x -> x) (fun () -> Nil) ()) +(* let iter f seq = let rec aux seq = match seq () with | Nil -> () @@ -12,3 +17,4 @@ let iter f seq = aux next in aux seq +*) diff --git a/middle_end/flambda2.0/simplify/simplify_static.rec.ml b/middle_end/flambda2.0/simplify/simplify_static.rec.ml index 5658963f3f66..97da6950cf2a 100644 --- a/middle_end/flambda2.0/simplify/simplify_static.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static.rec.ml @@ -639,6 +639,9 @@ let simplify_return_continuation_handler dacc | Ok sorted -> sorted | Error _ -> reified_definitions in + (* XXX If top sort fails, change types of the variables involved to "=v" + where each v is another thing like a computed value variable, but will + assume the value of the symbol. *) let static_structure : Static_structure.t = let top_sorted_reified_definitions = (* The [List.rev] relies on the following property: @@ -793,33 +796,55 @@ let simplify_definition dacc (defn : Program_body.Definition.t) = in definition, dacc -(* CR mshinwell: - - Need to delete unused code bindings. - - We should only delete code if the corresponding code-age graph is - linear. If it isn't linear then a subsequent join may need code that - is currently unused. - - We should simplify code on the way up if we don't delete it. *) +(* CR mshinwell: We should simplify code on the way up if we don't delete it. *) -let define_lifted_constants dacc lifted_constants (body : Program_body.t) = - List.fold_left (fun body lifted_constant : Program_body.t -> +let define_lifted_constants lifted_constants ~current_definition = + let defined_symbols_current_definition = + Definition.being_defined current_definition + in + let defined_code_ids_current_definition = + Definition.code_being_defined current_definition + in + List.fold_left + (fun (add_to_current_definition, add_around_body) lifted_constant -> let definition = Lifted_constant.definition lifted_constant in - let static_structure = - (* CR mshinwell: We should have deletion of unused symbols - automatically -- needs to be done for non-lifted constants too *) - Static_structure.delete_bindings definition.static_structure - ~free_names_after:(Program_body.free_names body) - (TE.code_age_relation (DE.typing_env (DA.denv dacc))) + assert (Option.is_none definition.computation); + let free_names = + Static_structure.free_names definition.static_structure in - if Static_structure.is_empty static_structure then body + let free_symbols = Name_occurrences.symbols free_names in + let free_code_ids = Name_occurrences.code_ids free_names in + let no_overlap_with_current_definition = + let no_overlap_with_symbols = + Symbol.Set.is_empty + (Symbol.Set.inter free_symbols + defined_symbols_current_definition) + in + let no_overlap_with_code_ids = + Code_id.Set.is_empty + (Code_id.Set.inter free_code_ids + defined_code_ids_current_definition) + in + no_overlap_with_symbols && no_overlap_with_code_ids + in + if no_overlap_with_current_definition then + (* XXX This should add things to the current definition if there + is recursion + - Also for normal reify (not computed values reify), we also need + to check if we have symbols currently being defined in the reified + type, and if so not lift (except for closures). + An alternative: add a computation that reads from the symbol + being defined and fills in the fields. *) + let add_around_body = + definition :: add_around_body + in + add_to_current_definition, add_around_body else - let definition : Program_body.Definition.t = - { computation = definition.computation; - static_structure; - } + let add_to_current_definition = + List.flatten [definition.static_structure; add_to_current_definition] in - Program_body.define_symbol definition ~body - (TE.code_age_relation (DE.typing_env (DA.denv dacc)))) - body + add_to_current_definition, add_around_body) + ([], []) lifted_constants let rec simplify_program_body0 dacc (body : Program_body.t) k = @@ -829,11 +854,41 @@ let rec simplify_program_body0 dacc (body : Program_body.t) k = let defn, dacc = simplify_definition dacc defn in let r = DA.r dacc in simplify_program_body0 dacc body (fun body dacc -> + let add_to_current_definition, add_around_body = + define_lifted_constants (R.get_lifted_constants r) + ~current_definition:defn + in + let defn = + { defn with + static_structure = add_to_current_definition @ defn.static_structure; + } + in let body = Program_body.define_symbol defn ~body (TE.code_age_relation (DE.typing_env (DA.denv dacc))) in - let body = define_lifted_constants dacc (R.get_lifted_constants r) body in + let body = + List.fold_left (fun body (defn : Definition.t) -> + let static_structure = + (* CR mshinwell: We should have deletion of unused symbols + automatically -- needs to be done for non-lifted constants + too *) + Static_structure.delete_bindings defn.static_structure + ~free_names_after:(Program_body.free_names body) + (TE.code_age_relation (DE.typing_env (DA.denv dacc))) + in + if Static_structure.is_empty static_structure then body + else + let defn : Program_body.Definition.t = + { computation = None; + static_structure; + } + in + Program_body.define_symbol defn ~body + (TE.code_age_relation (DE.typing_env (DA.denv dacc)))) + body + (List.rev add_around_body) + in k body dacc) | Root _ -> k body dacc From 354963bde1314ff706d744b74ef2be4159589ad2 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 30 Dec 2019 19:36:10 +0000 Subject: [PATCH 08/80] work --- middle_end/flambda2.0/terms/expr.rec.mli | 5 +- .../flambda2.0/terms/flambda_static.mli | 134 +----------------- 2 files changed, 7 insertions(+), 132 deletions(-) diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index 40c28a3e4151..91483e6a2509 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -24,9 +24,12 @@ include Expr_std.S with type t := t type descr = private | Let of Let_expr.t - (** Bind a variable. There can be no effect on control flow (save for + (** Bind variable(s). There can be no effect on control flow (save for asynchronous operations such as the invocation of finalisers or signal handlers as a result of reaching a safe point). *) + | Let_symbol of Let_symbol.t + (** Bind code and/or data symbol(s). This form of expression is only + allowed in contexts where it is certain to be executed only once. *) | Let_cont of Let_cont_expr.t (** Define one or more continuations. *) | Apply of Apply.t diff --git a/middle_end/flambda2.0/terms/flambda_static.mli b/middle_end/flambda2.0/terms/flambda_static.mli index 4adfe7cd7a86..f17f9647d56b 100644 --- a/middle_end/flambda2.0/terms/flambda_static.mli +++ b/middle_end/flambda2.0/terms/flambda_static.mli @@ -16,127 +16,8 @@ (** Language terms that represent statically-allocated values. *) -module Of_kind_value : sig - (** The various possible inhabitants of fields of statically-allocated - blocks. *) - type t = - | Symbol of Symbol.t - (** A field containing the address of the given symbol. *) - | Tagged_immediate of Immediate.t - (** A field containing the given tagged immediate. *) - | Dynamically_computed of Variable.t - (** A field containing the value of the variable that arose from - a previous [computation] (see below). *) - - (** Printing, total ordering, etc. *) - include Identifiable.S with type t := t -end - -module Static_part : sig - type 'a or_variable = - | Const of 'a - | Var of Variable.t - - (** The mutability status of a block field. *) - type mutable_or_immutable = Mutable | Immutable - - (** A piece of code, comprising of the parameters and body of a function, - together with a field indicating whether the piece of code is a newer - version of one that existed previously (and may still exist), for - example after a round of simplification. *) - type code = { - params_and_body : Flambda.Function_params_and_body.t or_deleted; - newer_version_of : Code_id.t option; - } - and 'a or_deleted = - | Present of 'a - | Deleted - - (** The possibly-recursive declaration of pieces of code and any associated - set of closures. *) - type code_and_set_of_closures = { - code : code Code_id.Map.t; - (* CR mshinwell: Check the free names of the set of closures *) - set_of_closures : Flambda.Set_of_closures.t option; - } - - (** The static structure of a symbol, possibly with holes, ready to be - filled with values computed at runtime. *) - type 'k t = - | Block : Tag.Scannable.t * mutable_or_immutable - * (Of_kind_value.t list) -> Flambda_kind.value t - | Fabricated_block : Variable.t -> Flambda_kind.value t - | Code_and_set_of_closures : code_and_set_of_closures - -> Flambda_kind.fabricated t - | Boxed_float : Numbers.Float_by_bit_pattern.t or_variable - -> Flambda_kind.value t - | Boxed_int32 : Int32.t or_variable -> Flambda_kind.value t - | Boxed_int64 : Int64.t or_variable -> Flambda_kind.value t - | Boxed_nativeint : Targetint.t or_variable -> Flambda_kind.value t - | Immutable_float_array : Numbers.Float_by_bit_pattern.t or_variable list - -> Flambda_kind.value t - | Mutable_string : { initial_value : string or_variable; } - -> Flambda_kind.value t - | Immutable_string : string or_variable -> Flambda_kind.value t - - (** Print a static structure definition to a formatter. *) - val print : Format.formatter -> _ t -> unit - - (** All names free in the given static part. (Note that this will - descend into function bodies to find symbols.) *) - val free_names : _ t -> Name_occurrences.t -end - -type static_part_iterator = { - f : 'k. ('k Static_part.t -> unit); -} - -type static_part_mapper = { - f : 'k. ('k Static_part.t -> 'k Static_part.t); -} - module Program_body : sig - module Computation : sig - type t = { - expr : Flambda.Expr.t; - (** The expression that is to be evaluated. It must have no free - variables and call [return_cont] with its results. *) - return_continuation : Continuation.t; - (** The return continuation of [expr]. *) - exn_continuation : Exn_continuation.t; - (** The uncaught exception continuation of [expr]. *) - computed_values : Kinded_parameter.t list; - (** Variables, with their kinds, used to reference results of the - computation [expr] inside the [static_structure] (see below). This - list of variables must be in bijection with the parameters of the - [return_cont]. - Since we don't really do any transformations on these structures, the - [computed_values] variables are not treated up to alpha conversion. *) - } - - val print : Format.formatter -> t -> unit - - val iter_expr : t -> f:(Flambda.Expr.t -> unit) -> unit - val map_expr : t -> f:(Flambda.Expr.t -> Flambda.Expr.t) -> t - end - - module Bound_symbols : sig - type 'k t = - | Singleton : Symbol.t -> Flambda_kind.value t - (** A binding of a single symbol of kind [Value]. *) - | Code_and_set_of_closures : { - code_ids : Code_id.Set.t; - closure_symbols : Symbol.t Closure_id.Map.t; - } -> Flambda_kind.fabricated t - (** A recursive binding of possibly multiple symbols to the individual - closures within a set of closures; and/or bindings of code to - code IDs. *) - - val print : Format.formatter -> _ t -> unit - - val being_defined : _ t -> Symbol.Set.t - end module Static_structure : sig (** The bindings in a [Static_structure] are ordered: symbols bound later @@ -177,17 +58,7 @@ module Program_body : sig end module Definition : sig - type t = { - computation : Computation.t option; - (** A computation which provides values to fill in parts of the - statically-declared structure of one or more symbols. - [computation] may not reference the symbols bound by the same - definition's [static_structure]. *) - static_structure : Static_structure.t; - (** The statically-declared structure of the symbols being declared. - Bindings of symbols in each element of a list comprising a - [static_structure] are simultaneous, not ordered, or recursive. *) - } + val print : Format.formatter -> t -> unit @@ -248,7 +119,8 @@ end module Program : sig type t = { imported_symbols : Flambda_kind.t Symbol.Map.t; - body : Program_body.t; + exn_continuation : Continuation.t; + body : Expr.t; } (** Perform well-formedness checks on the program. *) From 724624e2b017b21cb339d1d8fbd66b2f833cf505 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 11:17:21 +0000 Subject: [PATCH 09/80] terms --- .../compilenv_deps/flambda_colours.ml | 1 + .../compilenv_deps/flambda_colours.mli | 1 + middle_end/flambda2.0/terms/dune | 4 + middle_end/flambda2.0/terms/expr.rec.mli | 2 +- middle_end/flambda2.0/terms/flambda_static.ml | 16 +- .../flambda2.0/terms/flambda_static.mli | 150 ++++------------- .../flambda2.0/terms/let_symbol_expr.rec.ml | 155 ++++++++++++++++++ .../flambda2.0/terms/let_symbol_expr.rec.mli | 51 ++++++ middle_end/flambda2.0/terms/rec_modules | 2 + .../flambda2.0/terms/static_const.rec.mli | 77 +++++++++ 10 files changed, 335 insertions(+), 124 deletions(-) create mode 100644 middle_end/flambda2.0/terms/let_symbol_expr.rec.ml create mode 100644 middle_end/flambda2.0/terms/let_symbol_expr.rec.mli create mode 100644 middle_end/flambda2.0/terms/static_const.rec.mli diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml index 3d13b1d843c9..9ce887a70d5b 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml @@ -40,6 +40,7 @@ let variable () = C.fg_256 111 let closure_element () = C.fg_256 31 let let_bound_var () = C.fg_256 37 +let let_bound_symbol () = (C.fg_256 37) ^ (C.bg_256 240) let expr_keyword () = C.fg_256 51 let static_keyword () = (C.fg_256 255) ^ (C.bg_256 240) diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli index 98c87e65535c..b0b14dcb0575 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli @@ -38,6 +38,7 @@ val variable : unit -> string val closure_element : unit -> string val let_bound_var : unit -> string +val let_bound_symbol : unit -> string val expr_keyword : unit -> string val static_keyword : unit -> string diff --git a/middle_end/flambda2.0/terms/dune b/middle_end/flambda2.0/terms/dune index f93bb6d4d518..aa0689591cad 100644 --- a/middle_end/flambda2.0/terms/dune +++ b/middle_end/flambda2.0/terms/dune @@ -17,12 +17,16 @@ let_cont_expr.rec.mli let_expr.rec.ml let_expr.rec.mli + let_symbol_expr.rec.ml + let_symbol_expr.rec.mli named.rec.ml named.rec.mli non_recursive_let_cont_handler.rec.ml non_recursive_let_cont_handler.rec.mli recursive_let_cont_handlers.rec.ml recursive_let_cont_handlers.rec.mli + static_const.rec.ml + static_const.rec.mli ) (action (run ../scripts/assemble_rec_modules.sh template/flambda.templ.ml diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index 91483e6a2509..3c033a23670e 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -29,7 +29,7 @@ type descr = private signal handlers as a result of reaching a safe point). *) | Let_symbol of Let_symbol.t (** Bind code and/or data symbol(s). This form of expression is only - allowed in contexts where it is certain to be executed only once. *) + allowed in certain "toplevel" contexts. *) | Let_cont of Let_cont_expr.t (** Define one or more continuations. *) | Apply of Apply.t diff --git a/middle_end/flambda2.0/terms/flambda_static.ml b/middle_end/flambda2.0/terms/flambda_static.ml index f0dd4542cfc7..2c66c8c8825f 100644 --- a/middle_end/flambda2.0/terms/flambda_static.ml +++ b/middle_end/flambda2.0/terms/flambda_static.ml @@ -14,7 +14,21 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "+a-30-40-41-42"] + +type t = { + imported_symbols : Flambda_kind.t Symbol.Map.t; + root_symbol : Symbol.t; + exn_continuation : Continuation.t; + body : Expr.t; +} + +let create ~imported_symbols ~root_symbol ~exn_continuation ~body = + { imported_symbols; + root_symbol; + exn_continuation; + body; + } let fprintf = Format.fprintf diff --git a/middle_end/flambda2.0/terms/flambda_static.mli b/middle_end/flambda2.0/terms/flambda_static.mli index f17f9647d56b..89bb4c5f313f 100644 --- a/middle_end/flambda2.0/terms/flambda_static.mli +++ b/middle_end/flambda2.0/terms/flambda_static.mli @@ -14,135 +14,41 @@ (* *) (**************************************************************************) -(** Language terms that represent statically-allocated values. *) +(** The Flambda representation of a single compilation unit's code. *) -module Program_body : sig +[@@@ocaml.warning "+a-30-40-41-42"] +type t = { + imported_symbols : Flambda_kind.t Symbol.Map.t; + root_symbol : Symbol.t; + exn_continuation : Continuation.t; + body : Expr.t; +} - module Static_structure : sig - (** The bindings in a [Static_structure] are ordered: symbols bound later - in the list cannot be referred to by [Static_part]s earlier in the - list. - Allowing multiple bindings here enables several static parts to use - the same results from a given [computation]. *) - type t0 = - | S : 'k Bound_symbols.t * 'k Static_part.t -> t0 +(** Perform well-formedness checks on the program. *) +val invariant : t -> unit - type t = t0 list +(** Print a program to a formatter. *) +val print : Format.formatter -> t -> unit - (* CR mshinwell: Add a creation function *) - (* CR mshinwell: make [t] abstract *) +val create + : imported_symbols:Flambda_kind.t Symbol.Map.t + -> root_symbol:Symbol.t + -> exn_continuation:Continuation.t + -> body:Expr.t + -> t - val print : Format.formatter -> t -> unit +(** All free names in the given program. Imported symbols are not treated + as free. *) +val free_names : t -> Name_occurrences.t - val is_empty : t -> bool +val used_closure_vars : t -> Var_within_closure.Set.t - val being_defined : t -> Symbol.Set.t +(** All symbols imported from other compilation units by the given program. *) +val imported_symbols : t -> Flambda_kind.t Symbol.Map.t - val delete_bindings - : t - -> free_names_after:Name_occurrences.t - -> Code_age_relation.t - -> t +(** The module block symbol for the given program (the only symbol that + can never be eliminated). *) +val root_symbol : t -> Symbol.t - val free_names : t -> Name_occurrences.t - - (** If [newer_versions_of] maps [id1] to [id2] then [id1] is a newer - version of [id2]. *) - val pieces_of_code - : ?newer_versions_of:Code_id.t Code_id.Map.t - -> ?set_of_closures: - (Symbol.t Closure_id.Map.t * Flambda.Set_of_closures.t) - -> Flambda.Function_params_and_body.t Code_id.Map.t - -> t0 - end - - module Definition : sig - - - val print : Format.formatter -> t -> unit - - val singleton_symbol : Symbol.t -> Flambda_kind.value Static_part.t -> t - - (** If [newer_versions_of] maps [id1] to [id2] then [id1] is a newer - version of [id2]. *) - val pieces_of_code - : ?newer_versions_of:Code_id.t Code_id.Map.t - -> Flambda.Function_params_and_body.t Code_id.Map.t - -> t - - val get_pieces_of_code - : t - -> (Flambda.Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t - - val being_defined : t -> Symbol.Set.t - - val code_being_defined : t -> Code_id.Set.t - - val iter_computation : t -> f:(Computation.t -> unit) -> unit - - val map_computation : t -> f:(Computation.t -> Computation.t) -> t - - val iter_static_parts : t -> static_part_iterator -> unit - - val map_static_parts : t -> static_part_mapper -> t - end - - type t - - (** Print a list of symbol definitions to a formatter. *) - val print : Format.formatter -> t -> unit - - (** Define the given symbol(s). No symbol defined by the - [definition] may be referenced by the same definition, only by - subsequent [define_symbol] constructs. *) - val define_symbol : Definition.t -> body:t -> Code_age_relation.t -> t - - (** The module block symbol for the compilation unit. *) - val root : Symbol.t -> t - - val free_names : t -> Name_occurrences.t - - val iter_definitions : t -> f:(Definition.t -> unit) -> unit - - type descr = private - (* CR mshinwell: Rename [Definition] to [Definition]. It doesn't - always define a symbol now. *) - | Definition of Definition.t * t - | Root of Symbol.t - - val descr : t -> descr -end - -(** A "program" is the contents of one compilation unit. It describes the - various values that are assigned to symbols in the object file. *) -module Program : sig - type t = { - imported_symbols : Flambda_kind.t Symbol.Map.t; - exn_continuation : Continuation.t; - body : Expr.t; - } - - (** Perform well-formedness checks on the program. *) - val invariant : t -> unit - - (** Print a program to a formatter. *) - val print : Format.formatter -> t -> unit - - (** All free names in the given program. Imported symbols are not treated - as free. *) - val free_names : t -> Name_occurrences.t - - val used_closure_vars : t -> Var_within_closure.Set.t - - (** All symbols imported from other compilation units by the given program. *) - val imported_symbols : t -> Flambda_kind.t Symbol.Map.t - - (** The module block symbol for the given program (the only symbol that - can never be eliminated). *) - val root_symbol : t -> Symbol.t - - val iter_body : t -> f:(Program_body.t -> unit) -> unit - - val map_body : t -> f:(Program_body.t -> Program_body.t) -> t -end +val body : t -> Expr.t diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml new file mode 100644 index 000000000000..84638a732387 --- /dev/null +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 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. *) +(* *) +(**************************************************************************) + +module Bound_symbols = struct + type t = + | Singleton : Symbol.t -> t + | Code_and_set_of_closures of { + code_ids : Code_id.Set.t; + closure_symbols : Symbol.t Closure_id.Map.t; + } + + (* CR mshinwell: Share with [Bindable_let_bound] *) + let print_closure_binding ppf (closure_id, sym) = + Format.fprintf ppf "@[(%a \u{21a6} %a)@]" + Closure_id.print closure_id + Symbol.print sym + + let print ppf t = + match t with + | Singleton sym -> + Format.fprintf ppf "@[%a@ \u{2237}@ %a@ @<0>%s=@<0>%s@ @]" + Symbol.print sym + K.print K.value + (Flambda_colours.elide ()) + (Flambda_colours.normal ()) + | Code_and_set_of_closures { code_ids; closure_symbols; } -> + Format.fprintf ppf "@[\ + @[(code_ids@ %a)@]@ \ + @[(closure_symbols@ {%a})@]\ + @]" + Code_id.Set.print code_ids + (Format.pp_print_list ~pp_sep:Format.pp_print_space + print_closure_binding) + (Closure_id.Map.bindings closure_symbols) + + (* CR mshinwell: This should have an [invariant] function. One thing to + check is that the [closure_symbols] are all distinct. *) + + let being_defined t = + match t with + | Singleton sym -> Symbol.Set.singleton sym + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + Symbol.Set.of_list (Closure_id.Map.data closure_symbols) + + let closure_symbols_being_defined t = + match t with + | Singleton _sym -> Symbol.Set.empty + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + Symbol.Set.of_list (Closure_id.Map.data closure_symbols) + + let code_being_defined t = + match t with + | Singleton _ -> Code_id.Set.empty + | Code_and_set_of_closures { code_ids; closure_symbols = _; } -> code_ids + + let apply_name_permutation t _perm = t + + let free_names t = + match t with + | Singleton sym -> Name_occurrences.singleton_symbol sym + | Code_and_set_of_closures { code_ids; closure_symbols; } -> + let from_code_ids = + Code_id.Set.fold (fun code_id from_code_ids -> + Name_occurrences.add_code_id from_code_ids code_id Name_mode.normal) + code_ids + Name_occurrences.empty + in + Closure_id.Map.fold (fun _closure_id closure_sym bound_names -> + Name_occurrences.add_symbol bound_names closure_sym Name_mode.normal) + closure_symbols + from_code_ids +end + +type t = { + bound_symbols : Bound_symbols.t; + defining_expr : Static_const.t; + body : Expr.t; +} + +let create bound_symbols defining_expr body = + { bound_symbols; + defining_expr; + body; + } + +let bound_symbols t = t.bound_symbols +let defining_expr t = t.defining_expr +let body t = t.body + +let print_with_cache ~cache ppf ({ bound_symbols; defining_expr; body; } as t) = + let rec let_body (expr : Expr.t) = + match Expr.descr expr with + | Let ({ bound_symbols; defining_expr; body; } as t) -> + fprintf ppf + "@ @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" + (Flambda_colours.let_bound_symbol ()) + Bound_symbols.print bound_symbols + (Flambda_colours.elide ()) + (Flambda_colours.normal ()) + (Named.print_with_cache ~cache) defining_expr; + let_body body + | _ -> expr + in + fprintf ppf "@[(@<0>%slet_symbol@<0>%s@ (@[\ + @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" + (Flambda_colours.expr_keyword ()) + (Flambda_colours.normal ()) + (Flambda_colours.let_bound_symbol ()) + Bound_symbols.print bound_symbols + (Flambda_colours.elide ()) + (Flambda_colours.normal ()) + (Static_const.print_with_cache ~cache) defining_expr; + let expr = let_body body in + fprintf ppf "@])@ %a)@]" (Expr.print_with_cache ~cache) body + +let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t + +let invariant env { bound_symbols = _; defining_expr; body; } = + Named.invariant env defining_expr; + Expr.invariant env body + +let free_names { bound_symbols; defining_expr; body; } = + match defining_expr with + | Singleton sym -> + | Code_and_set_of_closures _ -> + let from_bound_symbols = Bound_symbols.free_names bound_symbols in + let from_defining_expr = + Name_occurrences.diff (Static_const.free_names defining_expr) + from_bound_symbols + in + Name_occurrences.union from_defining_expr + (Name_occurrences.diff (Expr.free_names body) from_bound_symbols + +let apply_name_permutation ({ bound_symbols; defining_expr; body; } as t) perm = + let defining_expr' = Static_const.apply_name_permutation defining_expr perm in + let body' = Expr.apply_name_permutation body perm in + if defining_expr == defining_expr' && body == body' then t + else + { bound_symbols; + defining_expr; + body; + } diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli new file mode 100644 index 000000000000..9e827d0da7c5 --- /dev/null +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 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. *) +(* *) +(**************************************************************************) + +(** The form of expression that binds symbols to statically-allocated + constants. *) + +module Bound_symbols : sig + type t = + | Singleton : Symbol.t -> t + (** A binding of a single symbol of kind [Value]. *) + | Code_and_set_of_closures of { + code_ids : Code_id.Set.t; + closure_symbols : Symbol.t Closure_id.Map.t; + } + (** A recursive binding of possibly multiple symbols to the individual + closures within a set of closures; and/or bindings of code to + code IDs. *) + + val being_defined : t -> Symbol.Set.t + + val code_being_defined : t -> Code_id.Set.t + + val closure_symbols_being_defined : t -> Symbol.Set.t + + include Expr_std.S with type t := t +end + +type t + +val create : Bound_symbols.t -> Static_const.t -> Expr.t -> t + +val bound_symbols : t -> Bound_symbols.t + +val defining_expr : t -> Static_const.t + +val body : t -> Expr.t + +include Expr_std.S with type t := t diff --git a/middle_end/flambda2.0/terms/rec_modules b/middle_end/flambda2.0/terms/rec_modules index c7da7fa6e01d..046c0ef6aca3 100644 --- a/middle_end/flambda2.0/terms/rec_modules +++ b/middle_end/flambda2.0/terms/rec_modules @@ -5,6 +5,8 @@ expr.rec.ml function_params_and_body.rec.ml let_cont_expr.rec.ml let_expr.rec.ml +let_symbol_expr.rec.ml named.rec.ml non_recursive_let_cont_handler.rec.ml recursive_let_cont_handlers.rec.ml +static_const.rec.ml \ No newline at end of file diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli new file mode 100644 index 000000000000..e5ec603ff7e9 --- /dev/null +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 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. *) +(* *) +(**************************************************************************) + +(** Language terms that represent statically-allocated values. *) + +module Field_of_block : sig + (** Inhabitants (of kind [Value]) of fields of statically-allocated blocks. *) + type t = + | Symbol of Symbol.t + (** The address of the given symbol. *) + | Tagged_immediate of Immediate.t + (** The given tagged immediate. *) + | Dynamically_computed of Variable.t + (** The value of the given variable. *) + + (** Printing, total ordering, etc. *) + include Identifiable.S with type t := t +end + +type 'a or_variable = + | Const of 'a + | Var of Variable.t + +(** The mutability status of a block field. *) +type mutable_or_immutable = Mutable | Immutable + +(** A piece of code, comprising of the parameters and body of a function, + together with a field indicating whether the piece of code is a newer + version of one that existed previously (and may still exist), for + example after a round of simplification. *) +type code = { + params_and_body : Flambda.Function_params_and_body.t or_deleted; + newer_version_of : Code_id.t option; +} +and 'a or_deleted = + | Present of 'a + | Deleted + +(** The possibly-recursive declaration of pieces of code and any associated set + of closures. *) +type code_and_set_of_closures = { + code : code Code_id.Map.t; + (* CR mshinwell: Check the free names of the set of closures *) + set_of_closures : Flambda.Set_of_closures.t option; +} + +(** The static structure of a symbol, possibly with holes, ready to be filled + with values computed at runtime. *) +type t = + | Block of Tag.Scannable.t * mutable_or_immutable * (Field_of_block.t list) + | Fabricated_block of Variable.t + | Code_and_set_of_closures of code_and_set_of_closures + | Boxed_float of Numbers.Float_by_bit_pattern.t or_variable + | Boxed_int32 of Int32.t or_variable + | Boxed_int64 of Int64.t or_variable + | Boxed_nativeint of Targetint.t or_variable + | Immutable_float_array of Numbers.Float_by_bit_pattern.t or_variable list + | Mutable_string of { initial_value : string; } + | Immutable_string of string + +(** Print a static structure definition to a formatter. *) +val print : Format.formatter -> t -> unit + +include Contains_names.S with type t := t From 8572790dc20b6ade7af869cdd728dedf2f58c142 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 11:33:05 +0000 Subject: [PATCH 10/80] terms --- middle_end/flambda2.0/simplify/dune | 10 +- .../simplify/generic_simplify_let_cont.rec.ml | 145 --------------- .../generic_simplify_let_cont.rec.mli | 58 ------ middle_end/flambda2.0/simplify/rec_modules | 5 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 169 ++++++++++++++---- .../flambda2.0/simplify/simplify_import.mli | 1 + ...ic.rec.ml => simplify_static_const.rec.ml} | 0 ....rec.mli => simplify_static_const.rec.mli} | 0 middle_end/flambda2.0/terms/expr.rec.ml | 12 ++ middle_end/flambda2.0/terms/expr.rec.mli | 7 +- middle_end/flambda2.0/terms/flambda.mli | 4 +- .../{flambda_static.ml => flambda_unit.ml} | 0 .../{flambda_static.mli => flambda_unit.mli} | 0 .../flambda2.0/terms/let_symbol_expr.rec.ml | 20 +-- .../terms/template/flambda.templ.ml | 4 +- 15 files changed, 176 insertions(+), 259 deletions(-) delete mode 100644 middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.ml delete mode 100644 middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.mli rename middle_end/flambda2.0/simplify/{simplify_static.rec.ml => simplify_static_const.rec.ml} (100%) rename middle_end/flambda2.0/simplify/{simplify_static.rec.mli => simplify_static_const.rec.mli} (100%) rename middle_end/flambda2.0/terms/{flambda_static.ml => flambda_unit.ml} (100%) rename middle_end/flambda2.0/terms/{flambda_static.mli => flambda_unit.mli} (100%) diff --git a/middle_end/flambda2.0/simplify/dune b/middle_end/flambda2.0/simplify/dune index ccf27afc358e..9ecea49d18cd 100644 --- a/middle_end/flambda2.0/simplify/dune +++ b/middle_end/flambda2.0/simplify/dune @@ -2,17 +2,15 @@ (targets simplify.ml) (deps rec_modules - generic_simplify_let_cont.rec.ml - generic_simplify_let_cont.rec.mli template/simplify.templ.ml simplify_expr.rec.ml simplify_named.rec.ml - simplify_static.rec.ml - simplify_toplevel.rec.ml + simplify_static_const.rec.ml + simplify_unit.rec.ml simplify_expr.rec.mli simplify_named.rec.mli - simplify_static.rec.mli - simplify_toplevel.rec.mli + simplify_static_const.rec.mli + simplify_unit.rec.mli ) (action (run ../scripts/assemble_rec_modules.sh template/simplify.templ.ml diff --git a/middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.ml b/middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.ml deleted file mode 100644 index cf7f19c63433..000000000000 --- a/middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.ml +++ /dev/null @@ -1,145 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2019 OCamlPro SAS *) -(* Copyright 2014--2019 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-30-40-41-42"] - -open! Simplify_import - -module Make (CHL : Continuation_handler_like_intf.S) = struct - type 'body simplify_body = { - simplify_body : 'a. - Downwards_acc.t - -> 'body - -> (Continuation_uses_env.t - -> Simplify_env_and_result.Result.t - -> ('a * Upwards_acc.t)) - -> 'body * 'a * Upwards_acc.t; - } - - let simplify_body_of_non_recursive_let_cont dacc cont cont_handler - ~(simplify_body : _ simplify_body) ~body - ~simplify_continuation_handler_like ~user_data k = - let body, (result, uenv', user_data), uacc = - let scope = DE.get_continuation_scope_level (DA.denv dacc) in - let is_exn_handler = CHL.is_exn_handler cont_handler in - CHL.pattern_match cont_handler ~f:(fun handler -> - let params = CHL.Opened.params handler in - let denv = DE.define_parameters (DA.denv dacc) ~params in - let dacc = - DA.with_denv dacc (DE.increment_continuation_scope_level denv) - in - simplify_body.simplify_body dacc body (fun cont_uses_env r -> -(* - Format.eprintf "Parameters for %a: %a\n%!" - Continuation.print cont - KP.List.print params; -*) - let denv = - DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants r) - in - let uses = - CUE.compute_handler_env cont_uses_env cont ~params - ~definition_typing_env_with_params_defined:(DE.typing_env denv) - in - let handler, user_data, uacc, is_single_inlinable_use = - match uses with - | No_uses -> - (* Don't simplify the handler if there aren't any uses: otherwise, - its code will be deleted but any continuation usage information - collected during its simplification will remain. *) - let user_data, uacc = k cont_uses_env r in - cont_handler, user_data, uacc, false - | Uses { handler_typing_env; arg_types_by_use_id; - extra_params_and_args; is_single_inlinable_use; } -> - let typing_env, extra_params_and_args = - match Continuation.sort cont with - | Normal when is_single_inlinable_use -> - assert (not is_exn_handler); - handler_typing_env, extra_params_and_args - | Normal | Toplevel_return -> - assert (not is_exn_handler); - let param_types = TE.find_params handler_typing_env params in - Unbox_continuation_params.make_unboxing_decisions - handler_typing_env ~arg_types_by_use_id ~params - ~param_types extra_params_and_args - | Return -> - assert (not is_exn_handler); - handler_typing_env, extra_params_and_args - | Exn -> - assert is_exn_handler; - handler_typing_env, extra_params_and_args - in - let dacc = - DA.create (DE.with_typing_env denv typing_env) cont_uses_env r - in - try - let handler, user_data, uacc = - simplify_continuation_handler_like dacc ~extra_params_and_args - cont handler ~user_data k - in - handler, user_data, uacc, is_single_inlinable_use - with Misc.Fatal_error -> begin - if !Clflags.flambda2_context_on_error then begin - Format.eprintf "\n%sContext is:%s simplifying continuation \ - handler (inlinable? %b)@ %a@ with \ - [extra_params_and_args]@ %a@ \ - with downwards accumulator:@ %a\n" - (Flambda_colours.error ()) - (Flambda_colours.normal ()) - is_single_inlinable_use - CHL.print cont_handler - Continuation_extra_params_and_args.print - extra_params_and_args - DA.print dacc - end; - raise Misc.Fatal_error - end - in - let uenv = UA.uenv uacc in - let uenv_to_return = uenv in - let uenv = - match uses with - | No_uses -> uenv - | Uses _ -> - match CHL.behaviour handler with - | Unreachable { arity; } -> - UE.add_unreachable_continuation uenv cont scope arity - | Alias_for { arity; alias_for; } -> - UE.add_continuation_alias uenv cont arity ~alias_for - | Apply_cont_with_constant_arg - { cont = destination_cont; arg = destination_arg; arity; } -> - UE.add_continuation_apply_cont_with_constant_arg uenv cont - scope arity ~destination_cont ~destination_arg - | Unknown { arity; } -> - let can_inline = - if is_single_inlinable_use && (not is_exn_handler) then - CHL.real_handler handler - else - None - in - match can_inline with - | None -> UE.add_continuation uenv cont scope arity - | Some handler -> - UE.add_continuation_to_inline uenv cont scope arity handler - in - let uacc = UA.with_uenv uacc uenv in - (handler, uenv_to_return, user_data), uacc)) - in - (* The upwards environment of [uacc] is replaced so that out-of-scope - continuation bindings do not end up in the accumulator. *) - let uacc = UA.with_uenv uacc uenv' in - body, result, user_data, uacc -end diff --git a/middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.mli b/middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.mli deleted file mode 100644 index cb3db108838b..000000000000 --- a/middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.mli +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2019 OCamlPro SAS *) -(* Copyright 2014--2019 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-30-40-41-42"] - -(** Logic for the simplification of continuation bindings that is parameterised - over the notions of "continuation handler" and "body" (the latter being the - scope of a continuation). This enables the code to be reused for simplifying - [Flambda_static] expressions, where there is no [Expr.t] (and thus no - [Continuation_handler.t]) associated with the logic of return or exception - continuations, in addition to normal [Let_cont] constructs. -*) - -module Make (Continuation_handler_like : Continuation_handler_like_intf.S) : sig - type 'body simplify_body = { - simplify_body : 'a. - Downwards_acc.t - -> 'body - -> (Continuation_uses_env.t - -> Simplify_env_and_result.Result.t - -> ('a * Upwards_acc.t)) - -> 'body * 'a * Upwards_acc.t; - } - - val simplify_body_of_non_recursive_let_cont - : Downwards_acc.t - -> Continuation.t - -> Continuation_handler_like.t - -> simplify_body:'body simplify_body - -> body:'body - -> simplify_continuation_handler_like:(Downwards_acc.t - -> extra_params_and_args:Continuation_extra_params_and_args.t - -> Continuation.t - -> Continuation_handler_like.Opened.t - -> user_data:'user_data - -> (Continuation_uses_env.t - -> Simplify_env_and_result.Result.t - -> ('a * Upwards_acc.t)) - -> Continuation_handler_like.t * 'a * Upwards_acc.t) - -> user_data:'user_data - -> (Continuation_uses_env.t - -> Simplify_env_and_result.Result.t - -> ('a * Upwards_acc.t)) - -> 'body * Continuation_handler_like.t * 'a * Upwards_acc.t -end diff --git a/middle_end/flambda2.0/simplify/rec_modules b/middle_end/flambda2.0/simplify/rec_modules index 0003aeb3e24d..3012f0322396 100644 --- a/middle_end/flambda2.0/simplify/rec_modules +++ b/middle_end/flambda2.0/simplify/rec_modules @@ -1,5 +1,4 @@ -generic_simplify_let_cont.rec.ml simplify_expr.rec.ml simplify_named.rec.ml -simplify_static.rec.ml -simplify_toplevel.rec.ml \ No newline at end of file +simplify_static_const.rec.ml +simplify_unit.rec.ml diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 1836702b81a7..eaae23a21910 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -27,29 +27,6 @@ open! Simplify_import type 'a k = CUE.t -> R.t -> ('a * UA.t) -module Continuation_handler = struct - include Continuation_handler - let real_handler t = Some t - - module Opened = struct - type nonrec t = { - params : KP.t list; - handler : Expr.t; - original : t; - } - - let create ~params ~handler original = { params; handler; original; } - let params t = t.params - let original t = t.original - end - - let pattern_match t ~f = - Continuation_params_and_handler.pattern_match (params_and_handler t) - ~f:(fun params ~handler -> f (Opened.create ~params ~handler t)) -end - -module Simplify_let_cont = Generic_simplify_let_cont.Make (Continuation_handler) - let rec simplify_let : 'a. DA.t -> Let.t -> 'a k -> Expr.t * 'a * UA.t = fun dacc let_expr k -> @@ -62,6 +39,26 @@ let rec simplify_let let body, user_data, uacc = simplify_expr dacc body k in Simplify_common.bind_let_bound ~bindings ~body, user_data, uacc) +and simplify_let_symbol + : 'a. DA.t -> Let_symbol.t -> 'a k -> Expr.t * 'a * UA.t += fun dacc let_symbol_expr k -> + let module LS = Flambda.Let_symbol in + let bound_symbols = LS.bound_symbols let_symbol_expr in + let defining_expr = LS.defining_expr let_symbol_expr in + let body = LS.body let_symbol_expr in + let { Simplify_static_const. bindings_outermost_first = bindings; dacc; } = + Simplify_static_const.simplify_static_const dacc ~bound_symbols + defining_expr + in + let body, user_data, uacc = simplify_expr dacc body k in + let expr = + List.fold_left (fun body (bound_symbols, defining_expr) -> + Expr.create_let_symbol (LS.create bound_symbols defining_expr body)) + body + (List.rev bindings_outermost_first) + in + expr, user_data, uacc + and simplify_one_continuation_handler : 'a. bool -> DA.t -> extra_params_and_args:Continuation_extra_params_and_args.t @@ -159,16 +156,124 @@ and simplify_non_recursive_let_cont_handler let cont_handler = Non_recursive_let_cont_handler.handler non_rec_handler in Non_recursive_let_cont_handler.pattern_match non_rec_handler ~f:(fun cont ~body -> - let simplify_body : _ Simplify_let_cont.simplify_body = - { simplify_body = simplify_expr; } - in let body, handler, user_data, uacc = - Simplify_let_cont.simplify_body_of_non_recursive_let_cont dacc - cont cont_handler ~simplify_body ~body - ~simplify_continuation_handler_like: - (simplify_one_continuation_handler false) - ~user_data:() - k + let body, (result, uenv', user_data), uacc = + let scope = DE.get_continuation_scope_level (DA.denv dacc) in + let is_exn_handler = CH.is_exn_handler cont_handler in + CH.pattern_match cont_handler ~f:(fun handler -> + let params = CH.Opened.params handler in + let denv = DE.define_parameters (DA.denv dacc) ~params in + let dacc = + DA.with_denv dacc (DE.increment_continuation_scope_level denv) + in + simplify_expr dacc body (fun cont_uses_env r -> + (* + Format.eprintf "Parameters for %a: %a\n%!" + Continuation.print cont + KP.List.print params; + *) + let denv = + DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants r) + in + let uses = + CUE.compute_handler_env cont_uses_env cont ~params + ~definition_typing_env_with_params_defined: + (DE.typing_env denv) + in + let handler, user_data, uacc, is_single_inlinable_use = + match uses with + | No_uses -> + (* Don't simplify the handler if there aren't any uses: + otherwise, its code will be deleted but any continuation + usage information collected during its simplification will + remain. *) + let user_data, uacc = k cont_uses_env r in + cont_handler, user_data, uacc, false + | Uses { handler_typing_env; arg_types_by_use_id; + extra_params_and_args; is_single_inlinable_use; } -> + let typing_env, extra_params_and_args = + match Continuation.sort cont with + | Normal when is_single_inlinable_use -> + assert (not is_exn_handler); + handler_typing_env, extra_params_and_args + | Normal | Toplevel_return -> + assert (not is_exn_handler); + let param_types = + TE.find_params handler_typing_env params + in + Unbox_continuation_params.make_unboxing_decisions + handler_typing_env ~arg_types_by_use_id ~params + ~param_types extra_params_and_args + | Return -> + assert (not is_exn_handler); + handler_typing_env, extra_params_and_args + | Exn -> + assert is_exn_handler; + handler_typing_env, extra_params_and_args + in + let dacc = + DA.create (DE.with_typing_env denv typing_env)xi + cont_uses_env r + in + try + let handler, user_data, uacc = + simplify_one_continuation_handler dacc + ~extra_params_and_args cont handler ~user_data k + in + handler, user_data, uacc, is_single_inlinable_use + with Misc.Fatal_error -> begin + if !Clflags.flambda2_context_on_error then begin + Format.eprintf "\n%sContext is:%s simplifying + continuation \ handler (inlinable? %b)@ %a@ with \ + [extra_params_and_args]@ %a@ \ + with downwards accumulator:@ %a\n" + (Flambda_colours.error ()) + (Flambda_colours.normal ()) + is_single_inlinable_use + CH.print cont_handler + Continuation_extra_params_and_args.print + extra_params_and_args + DA.print dacc + end; + raise Misc.Fatal_error + end + in + let uenv = UA.uenv uacc in + let uenv_to_return = uenv in + let uenv = + match uses with + | No_uses -> uenv + | Uses _ -> + match CH.behaviour handler with + | Unreachable { arity; } -> + UE.add_unreachable_continuation uenv cont scope arity + | Alias_for { arity; alias_for; } -> + UE.add_continuation_alias uenv cont arity ~alias_for + | Apply_cont_with_constant_arg + { cont = destination_cont; arg = destination_arg; + arity; } -> + UE.add_continuation_apply_cont_with_constant_arg uenv cont + scope arity ~destination_cont ~destination_arg + | Unknown { arity; } -> + let can_inline = + if is_single_inlinable_use && (not is_exn_handler) then + CH.real_handler handler + else + None + in + match can_inline with + | None -> UE.add_continuation uenv cont scope arity + | Some handler -> + UE.add_continuation_to_inline uenv cont scope arity + handler + in + let uacc = UA.with_uenv uacc uenv in + (handler, uenv_to_return, user_data), uacc)) + in + (* The upwards environment of [uacc] is replaced so that out-of-scope + continuation bindings do not end up in the accumulator. *) + let uacc = UA.with_uenv uacc uenv' in + body, result, user_data, uacc in Let_cont.create_non_recursive cont handler ~body, user_data, uacc) diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index 688291a970ce..5b1c1ccb2ef9 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -36,6 +36,7 @@ module Recursive_let_cont_handlers = Flambda.Recursive_let_cont_handlers module Set_of_closures = Flambda.Set_of_closures module Switch = Flambda.Switch +module CH = Continuation_handler module CUE = Continuation_uses_env module DA = Downwards_acc module DE = Simplify_env_and_result.Downwards_env diff --git a/middle_end/flambda2.0/simplify/simplify_static.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml similarity index 100% rename from middle_end/flambda2.0/simplify/simplify_static.rec.ml rename to middle_end/flambda2.0/simplify/simplify_static_const.rec.ml diff --git a/middle_end/flambda2.0/simplify/simplify_static.rec.mli b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli similarity index 100% rename from middle_end/flambda2.0/simplify/simplify_static.rec.mli rename to middle_end/flambda2.0/simplify/simplify_static_const.rec.mli diff --git a/middle_end/flambda2.0/terms/expr.rec.ml b/middle_end/flambda2.0/terms/expr.rec.ml index 1398b1c05d06..405f29c5986b 100644 --- a/middle_end/flambda2.0/terms/expr.rec.ml +++ b/middle_end/flambda2.0/terms/expr.rec.ml @@ -18,6 +18,7 @@ type descr = | Let of Let_expr.t + | Let_symbol of Let_symbol.t | Let_cont of Let_cont_expr.t | Apply of Apply.t | Apply_cont of Apply_cont.t @@ -55,6 +56,12 @@ let descr t = let let_expr' = Let_expr.apply_name_permutation let_expr perm in if let_expr == let_expr' then t.descr else Let let_expr' + | Let_symbol let_symbol_expr -> + let let_symbol_expr' = + Let_symbol_expr.apply_name_permutation let_symbol_expr perm + in + if let_symbol_expr == let_symbol_expr' then t.descr + else Let_symbol let_symbol_expr' | Let_cont let_cont -> let let_cont' = Let_cont_expr.apply_name_permutation let_cont perm in if let_cont == let_cont' then t.descr @@ -76,6 +83,7 @@ let descr t = let invariant env t = match descr t with | Let let_expr -> Let_expr.invariant env let_expr + | Let_symbol let_symbol_expr -> Let_symbol_expr.invariant env let_symbol_expr | Let_cont let_cont -> Let_cont_expr.invariant env let_cont | Apply_cont apply_cont -> Apply_cont.invariant env apply_cont | Apply apply -> Apply.invariant env apply @@ -88,6 +96,8 @@ let invariant env t = let print_with_cache ~cache ppf (t : t) = match descr t with | Let let_expr -> Let_expr.print_with_cache ~cache ppf let_expr + | Let let_symbol_expr -> + Let_symbol_expr.print_with_cache ~cache ppf let_symbol_expr | Let_cont let_cont -> Let_cont_expr.print_with_cache ~cache ppf let_cont | Apply apply -> Format.fprintf ppf "@[(@<0>%sapply@<0>%s@ %a)@]" @@ -112,6 +122,7 @@ let free_names t = | Not_computed -> match descr t with | Let let_expr -> Let_expr.free_names let_expr + | Let let_symbol_expr -> Let_symbol_expr.free_names let_symbol_expr | Let_cont let_cont -> Let_cont_expr.free_names let_cont | Apply apply -> Apply.free_names apply | Apply_cont apply_cont -> Apply_cont.free_names apply_cont @@ -327,6 +338,7 @@ let create_pattern_let bound_vars defining_expr body : t = let expr, _ = create_pattern_let0 bound_vars defining_expr body in expr +let create_let_symbol let_symbol = create (Let_symbol let_symbol) let create_let_cont let_cont = create (Let_cont let_cont) let create_apply apply = create (Apply apply) let create_apply_cont apply_cont = create (Apply_cont apply_cont) diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index 3c033a23670e..86993fc6ca12 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -63,11 +63,16 @@ val create_pattern_let0 whether something got deleted. *) val create_let : Var_in_binding_pos.t -> Named.t -> t -> t +(** Bind a symbol to a statically-allocated constant. *) +val create_let_symbol : Let_symbol_expr.t -> t + (** Create a [Let]-expression that may bind more than a single [Variable] (such as is required to bind a [Set_of_closures]). *) (* CR mshinwell: Rename [Bindable_let_bound] -> [Let_pattern]? *) val create_pattern_let : Bindable_let_bound.t -> Named.t -> t -> t +val create_let_cont : Let_cont_expr.t -> t + (** Create an application expression. *) val create_apply : Apply.t -> t @@ -125,5 +130,3 @@ val bind_parameters_to_simples -> target:Simple.t list -> t -> t - -val create_let_cont : Let_cont_expr.t -> t diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index d87b8ebb612b..c63d1898862e 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -428,6 +428,7 @@ module Function_declaration = Function_declaration module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr +module Let_symbol = Let_symbol_expr module Set_of_closures = Set_of_closures (** The idea is that you should typically do "open! Flambda" at the top of @@ -442,8 +443,9 @@ module Import : sig module Function_declaration = Function_declaration module Function_declarations = Function_declarations module Function_params_and_body = Function_params_and_body - module Let_cont = Let_cont module Let = Let + module Let_cont = Let_cont + module Let_symbol = Let_symbol_expr module Named = Named module Non_recursive_let_cont_handler = Non_recursive_let_cont_handler module Recursive_let_cont_handlers = Recursive_let_cont_handlers diff --git a/middle_end/flambda2.0/terms/flambda_static.ml b/middle_end/flambda2.0/terms/flambda_unit.ml similarity index 100% rename from middle_end/flambda2.0/terms/flambda_static.ml rename to middle_end/flambda2.0/terms/flambda_unit.ml diff --git a/middle_end/flambda2.0/terms/flambda_static.mli b/middle_end/flambda2.0/terms/flambda_unit.mli similarity index 100% rename from middle_end/flambda2.0/terms/flambda_static.mli rename to middle_end/flambda2.0/terms/flambda_unit.mli diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 84638a732387..2448d931bce7 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -31,11 +31,9 @@ module Bound_symbols = struct let print ppf t = match t with | Singleton sym -> - Format.fprintf ppf "@[%a@ \u{2237}@ %a@ @<0>%s=@<0>%s@ @]" + Format.fprintf ppf "@[%a@ \u{2237}@ %a@]" Symbol.print sym K.print K.value - (Flambda_colours.elide ()) - (Flambda_colours.normal ()) | Code_and_set_of_closures { code_ids; closure_symbols; } -> Format.fprintf ppf "@[\ @[(code_ids@ %a)@]@ \ @@ -133,16 +131,16 @@ let invariant env { bound_symbols = _; defining_expr; body; } = Expr.invariant env body let free_names { bound_symbols; defining_expr; body; } = - match defining_expr with - | Singleton sym -> - | Code_and_set_of_closures _ -> - let from_bound_symbols = Bound_symbols.free_names bound_symbols in - let from_defining_expr = + let from_bound_symbols = Bound_symbols.free_names bound_symbols in + let from_defining_expr = + match defining_expr with + | Singleton sym -> Name_occurrences.singleton_symbol sym + | Code_and_set_of_closures _ -> Name_occurrences.diff (Static_const.free_names defining_expr) from_bound_symbols - in - Name_occurrences.union from_defining_expr - (Name_occurrences.diff (Expr.free_names body) from_bound_symbols + in + Name_occurrences.union from_defining_expr + (Name_occurrences.diff (Expr.free_names body) from_bound_symbols let apply_name_permutation ({ bound_symbols; defining_expr; body; } as t) perm = let defining_expr' = Static_const.apply_name_permutation defining_expr perm in diff --git a/middle_end/flambda2.0/terms/template/flambda.templ.ml b/middle_end/flambda2.0/terms/template/flambda.templ.ml index 391eca2b560c..b1f4cffc95b6 100644 --- a/middle_end/flambda2.0/terms/template/flambda.templ.ml +++ b/middle_end/flambda2.0/terms/template/flambda.templ.ml @@ -43,6 +43,7 @@ module Function_declaration = Function_declaration module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr +module Let_symbol = Let_symbol_expr module Set_of_closures = Set_of_closures module Import = struct @@ -55,8 +56,9 @@ module Import = struct module Function_declaration = Function_declaration module Function_declarations = Function_declarations module Function_params_and_body = Function_params_and_body - module Let_cont = Let_cont module Let = Let + module Let_cont = Let_cont + module Let_symbol = Let_symbol_expr module Named = Named module Non_recursive_let_cont_handler = Non_recursive_let_cont_handler module Recursive_let_cont_handlers = Recursive_let_cont_handlers From e0a9f9576c20fd95d50661b9082a05e8a97334ed Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 14:26:35 +0000 Subject: [PATCH 11/80] terms --- middle_end/flambda2.0/basic/simple.mli | 2 + .../from_lambda/closure_conversion.ml | 131 +-- .../from_lambda/closure_conversion.mli | 6 +- middle_end/flambda2.0/simplify/dune | 2 - .../simplify/env/simplify_env_and_result.ml | 22 +- .../env/simplify_env_and_result_intf.ml | 10 +- middle_end/flambda2.0/simplify/rec_modules | 1 - middle_end/flambda2.0/simplify/simplify.mli | 4 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 84 +- .../flambda2.0/simplify/simplify_import.ml | 1 + .../flambda2.0/simplify/simplify_import.mli | 2 + .../flambda2.0/simplify/simplify_named.rec.ml | 58 +- .../simplify/simplify_named.rec.mli | 2 - .../simplify/simplify_static_const.rec.ml | 847 ++---------------- .../simplify/simplify_static_const.rec.mli | 13 +- .../simplify/template/simplify.templ.ml | 63 +- middle_end/flambda2.0/terms/flambda_unit.ml | 781 +--------------- middle_end/flambda2.0/terms/flambda_unit.mli | 26 +- 18 files changed, 331 insertions(+), 1724 deletions(-) diff --git a/middle_end/flambda2.0/basic/simple.mli b/middle_end/flambda2.0/basic/simple.mli index 6fe9ac430c68..eeb12cda9649 100644 --- a/middle_end/flambda2.0/basic/simple.mli +++ b/middle_end/flambda2.0/basic/simple.mli @@ -85,6 +85,8 @@ val const_zero : t val const_one : t +val const_unit : t + (** The constant representing the unit value. *) val unit : t diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index ec01417d969b..0c1571def2d9 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -23,6 +23,7 @@ module Expr = Flambda.Expr module Function_decls = Closure_conversion_aux.Function_decls module Function_decl = Function_decls.Function_decl module Function_params_and_body = Flambda.Function_params_and_body +module Let_symbol = Flambda.Let_symbol module Named = Flambda.Named module Program_body = Flambda_static.Program_body module Static_part = Flambda_static.Static_part @@ -841,8 +842,8 @@ and close_one_function t ~external_env ~by_closure_id decl Closure_id.Map.add unboxed_version fun_decl (Closure_id.Map.add closure_id generic_function_stub by_closure_id) -let ilambda_to_flambda ~backend ~module_ident ~size ~filename - (ilam : Ilambda.program) : Flambda_static.Program.t = +let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words + ~filename (ilam : Ilambda.program) = let module Backend = (val backend : Flambda2_backend_intf.S) in let compilation_unit = Compilation_unit.get_current_exn () in let t = @@ -860,24 +861,37 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename let module_block_var = Variable.create "module_block" in let return_cont = Continuation.create ~sort:Toplevel_return () in let field_vars = - List.init size (fun pos -> + List.init module_block_size_in_words (fun pos -> let pos_str = string_of_int pos in Variable.create ("cv_field_" ^ pos_str), K.value) in - (* For review, skip down to "let expr =" below, read the comment then - come back here. *) let load_fields_body = let field_vars = - List.init size (fun pos -> + List.init module_block_size_in_words (fun pos -> let pos_str = string_of_int pos in pos, Variable.create ("field_" ^ pos_str)) in - let body : Expr.t = - let fields = List.map (fun (_, var) -> Simple.var var) field_vars in - let apply_cont = - Flambda.Apply_cont.create return_cont ~args:fields ~dbg:Debuginfo.none + let body = + let static_const : Static_const.t = + let field_vars = + List.map (fun (var, _) : Static_const.Field_of_block.t -> + Dynamically_computed var) + field_vars + in + Block (module_block_tag, Immutable, field_vars) + in + let return = + (* Module initialisers return unit, but since that is taken care of + during Cmm generation, we can instead "return" [module_symbol] + here to ensure that its associated [Let_symbol] doesn't get + deleted. *) + Flambda.Apply_cont.create return_cont + ~args:[Simple.symbol module_symbol] + ~dbg:Debuginfo.none + |> Expr.create_apply_cont in - Flambda.Expr.create_apply_cont apply_cont + Let_symbol.create (Singleton module_symbol) static_const return + |> Flambda.create_let_symbol in List.fold_left (fun body (pos, var) -> let var = VB.create var Name_mode.normal in @@ -904,13 +918,12 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename ~stub:false (* CR mshinwell: remove "stub" notion *) ~is_exn_handler:false in - let expr = + let body = (* This binds the return continuation that is free (or, at least, not bound) in the incoming Ilambda code. The handler for the continuation receives a - tuple with fields indexed from zero to [size]. The handler extracts the - fields; the variables bound to such fields are returned as the - [computed_values], below. The compilation of the [Define_symbol] - constructions below then causes the actual module block to be created. *) + tuple with fields indexed from zero to [module_block_size_in_words]. The + handler extracts the fields; the variables bound to such fields are then + used to define the module block symbol. *) let body = close t Env.empty ilam.expr in Flambda.Let_cont.create_non_recursive ilam.return_continuation load_fields_cont_handler @@ -922,52 +935,16 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename Misc.fatal_error "Ilambda toplevel exception continuation cannot have \ extra arguments" end; - let exn_continuation = - Exn_continuation.create ~exn_handler:ilam.exn_continuation.exn_handler - ~extra_args:[] - in - let computed_values = - List.map (fun (var, kind) -> KP.create (Parameter.wrap var) kind) - field_vars - in - let computation : Program_body.Computation.t = - { expr; - return_continuation = return_cont; - exn_continuation; - computed_values; - } - in - let static_part : K.value Static_part.t = - let field_vars = - List.map (fun (var, _) : Flambda_static.Of_kind_value.t -> - Dynamically_computed var) - field_vars - in - Block (module_block_tag, Immutable, field_vars) - in - let program_body : Program_body.t = - let bound_symbols : K.value Program_body.Bound_symbols.t = - Singleton module_symbol - in - let definition : Program_body.Definition.t = - { computation = Some computation; - static_structure = [S (bound_symbols, static_part)]; - } - in - Program_body.define_symbol definition - ~body:(Program_body.root module_symbol) - Code_age_relation.empty - in - let program_body = - List.fold_left - (fun program_body (code_id, params_and_body) : Program_body.t -> - let bound_symbols : K.fabricated Program_body.Bound_symbols.t = + let exn_continuation = ilam.exn_continuation.exn_handler in + let body = + List.fold_left (fun body (code_id, params_and_body) : body.t -> + let bound_symbols : Let_symbol.Bound_symbols.t = Code_and_set_of_closures { code_ids = Code_id.Set.singleton code_id; closure_symbols = Closure_id.Map.empty; } in - let static_part : K.fabricated Static_part.t = + let static_const : Static_const.t = let code : Static_part.code = { params_and_body = Present params_and_body; newer_version_of = None; @@ -978,35 +955,16 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename set_of_closures = None; } in - let static_structure : Program_body.Static_structure.t = - [S (bound_symbols, static_part)] - in - let definition : Program_body.Definition.t = - { computation = None; - static_structure; - } - in - Program_body.define_symbol definition ~body:program_body - Code_age_relation.empty) - program_body + Let_symbol.create bound_symbols static_const body + |> Flambda.create_let_symbol) + body t.code in - let program_body = - (* CR mshinwell: Share with [Simplify_program] *) - List.fold_left (fun body (symbol, static_part) : Program_body.t -> - let bound_symbols : K.value Program_body.Bound_symbols.t = - Singleton symbol - in - let static_structure : Program_body.Static_structure.t = - [S (bound_symbols, static_part)] - in - let definition : Program_body.Definition.t = - { computation = None; - static_structure; - } - in - Program_body.define_symbol definition ~body Code_age_relation.empty) - program_body + let body = + List.fold_left (fun body (symbol, static_const) : body.t -> + Let_symbol.create (Singleton symbol) static_const body + |> Flambda.create_let_symbol) + body t.declared_symbols in let imported_symbols = @@ -1021,6 +979,5 @@ let ilambda_to_flambda ~backend ~module_ident ~size ~filename Backend.all_predefined_exception_symbols imported_symbols in - { imported_symbols; - body = program_body; - } + Flambda_unit.create ~imported_symbols ~return_continuation:return_cont + ~exn_continuation ~body diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.mli b/middle_end/flambda2.0/from_lambda/closure_conversion.mli index 48c8189c35ad..f9fec9c20c33 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.mli +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.mli @@ -21,7 +21,7 @@ val ilambda_to_flambda : backend:(module Flambda2_backend_intf.S) -> module_ident:Ident.t - -> size:int - -> filename:string + -> module_block_size_in_words:int + -> filename:string (* CR mshinwell: Filename of what? *) -> Ilambda.program - -> Flambda_static.Program.t + -> Flambda_unit.t diff --git a/middle_end/flambda2.0/simplify/dune b/middle_end/flambda2.0/simplify/dune index 9ecea49d18cd..8fd019344ba2 100644 --- a/middle_end/flambda2.0/simplify/dune +++ b/middle_end/flambda2.0/simplify/dune @@ -6,11 +6,9 @@ simplify_expr.rec.ml simplify_named.rec.ml simplify_static_const.rec.ml - simplify_unit.rec.ml simplify_expr.rec.mli simplify_named.rec.mli simplify_static_const.rec.mli - simplify_unit.rec.mli ) (action (run ../scripts/assemble_rec_modules.sh template/simplify.templ.ml diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index e4e2118f7adc..14380a35f0ec 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -36,12 +36,13 @@ end = struct inlining_depth_increment : int; float_const_prop : bool; code : Function_params_and_body.t Code_id.Map.t; + at_unit_toplevel : bool; } let print ppf { backend = _; round; typing_env; inlined_debuginfo; can_inline; inlining_depth_increment; float_const_prop; - code; + code; at_unit_toplevel; } = Format.fprintf ppf "@[(\ @[(round@ %d)@]@ \ @@ -50,6 +51,8 @@ end = struct @[(can_inline@ %b)@]@ \ @[(inlining_depth_increment@ %d)@]@ \ @[(float_const_prop@ %b)@] \ + @[(at_unit_toplevel@ %b)@] \ + @[(unit_toplevel_exn_continuation@ %a)@] \ @[(code@ %a)@]\ )@]" round @@ -58,11 +61,13 @@ end = struct can_inline inlining_depth_increment float_const_prop + at_unit_toplevel + Continuation.print unit_toplevel_exn_continuation (Code_id.Map.print Function_params_and_body.print) code let invariant _t = () - let create ~round ~backend ~float_const_prop = + let create ~round ~backend ~float_const_prop ~unit_toplevel_exn_continuation = (* CR mshinwell: [resolver] should come from [backend] *) let resolver _export_id = None in { backend; @@ -73,6 +78,8 @@ end = struct inlining_depth_increment = 0; float_const_prop; code = Code_id.Map.empty; + at_unit_toplevel = true; + unit_toplevel_exn_continuation; } let resolver t = TE.resolver t.typing_env @@ -82,6 +89,14 @@ end = struct let get_continuation_scope_level t = TE.current_scope t.typing_env let can_inline t = t.can_inline let float_const_prop t = t.float_const_prop + + let unit_toplevel_exn_continuation t = t.unit_toplevel_exn_continuation + + let at_unit_toplevel t = t.at_unit_toplevel + + let set_not_at_unit_toplevel t = + { t with at_unit_toplevel = false; } + let get_inlining_depth_increment t = t.inlining_depth_increment let set_inlining_depth_increment t inlining_depth_increment = @@ -100,7 +115,7 @@ end = struct let enter_closure { backend; round; typing_env; inlined_debuginfo = _; can_inline; inlining_depth_increment = _; - float_const_prop; code; + float_const_prop; code; not_at_unit_toplevel = _; } = { backend; round; @@ -110,6 +125,7 @@ end = struct inlining_depth_increment = 0; float_const_prop; code; + at_unit_toplevel = false; } let define_variable t var kind = diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index 160a494ea2a5..4d8b0d564258 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -29,11 +29,13 @@ module type Downwards_env = sig (** Print a human-readable version of the given environment. *) val print : Format.formatter -> t -> unit - (** Create a new environment. *) + (** Create a new environment, marked as being at the toplevel of a + compilation unit. *) val create : round:int -> backend:(module Flambda2_backend_intf.S) -> float_const_prop:bool + -> unit_toplevel_exn_continuation:Continuation.t -> t (** Obtain the first-class module that gives information about the @@ -44,6 +46,12 @@ module type Downwards_env = sig val float_const_prop : t -> bool + val at_unit_toplevel : t -> bool + + val set_not_at_unit_toplevel : t -> bool + + val unit_toplevel_exn_continuation : t -> Continuation.t + val enter_closure : t -> t val increment_continuation_scope_level : t -> t diff --git a/middle_end/flambda2.0/simplify/rec_modules b/middle_end/flambda2.0/simplify/rec_modules index 3012f0322396..e376aeedbf78 100644 --- a/middle_end/flambda2.0/simplify/rec_modules +++ b/middle_end/flambda2.0/simplify/rec_modules @@ -1,4 +1,3 @@ simplify_expr.rec.ml simplify_named.rec.ml simplify_static_const.rec.ml -simplify_unit.rec.ml diff --git a/middle_end/flambda2.0/simplify/simplify.mli b/middle_end/flambda2.0/simplify/simplify.mli index 0f8b70957851..53ae36bb1acd 100644 --- a/middle_end/flambda2.0/simplify/simplify.mli +++ b/middle_end/flambda2.0/simplify/simplify.mli @@ -25,5 +25,5 @@ val run : backend:(module Flambda2_backend_intf.S) -> round:int - -> Flambda_static.Program.t - -> Flambda_static.Program.t + -> Flambda_unit.t + -> Flambda_unit.t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index eaae23a21910..fa4df7fa0015 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -43,14 +43,36 @@ and simplify_let_symbol : 'a. DA.t -> Let_symbol.t -> 'a k -> Expr.t * 'a * UA.t = fun dacc let_symbol_expr k -> let module LS = Flambda.Let_symbol in + if not (DE.at_unit_toplevel (DA.denv dacc)) then begin + Misc.fatal_errorf "[Let_symbol] is only allowed at the toplevel of \ + compilation units (not even at the toplevel of function bodies):@ %a" + LS.print let_symbol_expr + end; let bound_symbols = LS.bound_symbols let_symbol_expr in + Symbol.Set.iter (fun sym -> + if DE.mem_symbol (DA.denv dacc) sym then begin + Misc.fatal_errorf "Symbol %a is already defined:@ %a" + Symbol.print sym + LS.print let_symbol_expr + end) + (LS.Bound_symbols.being_defined bound_symbols); + Code_id.Set.iter (fun code_id -> + if DE.mem_code_id (DA.denv dacc) code_id then begin + Misc.fatal_errorf "Code ID %a is already defined:@ %a" + Code_id.print sym + LS.print let_symbol_expr + end) + (LS.Bound_symbols.code_being_defined bound_symbols); let defining_expr = LS.defining_expr let_symbol_expr in let body = LS.body let_symbol_expr in - let { Simplify_static_const. bindings_outermost_first = bindings; dacc; } = - Simplify_static_const.simplify_static_const dacc ~bound_symbols - defining_expr + let static_const, dacc = + Simplify_static_const.simplify_static_const dacc bound_symbols defining_expr in + (* XXX Retrieve and add lifted constants here (some of which may need to + go in [defining_expr]. *) let body, user_data, uacc = simplify_expr dacc body k in + (* XXX This should do the deletion of the [Let_symbol], since we need the + code age relation to do that. *) let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> Expr.create_let_symbol (LS.create bound_symbols defining_expr body)) @@ -92,20 +114,23 @@ Format.eprintf "About to simplify handler %a, params %a, EPA %a\n%!" *) let free_names = Expr.free_names handler in let used_params = - if is_recursive then params else - let first = ref true in - List.filter (fun param -> - (* CR mshinwell: We should have a robust means of propagating which - parameter is the exception bucket. Then this hack can be - removed. *) - if !first && Continuation.is_exn cont then begin - first := false; - true - end else begin - first := false; - Name_occurrences.mem_var free_names (KP.var param) - end) - params + (* Removal of unused parameters of recursive continuations is not + currently supported. *) + if is_recursive then params + else + let first = ref true in + List.filter (fun param -> + (* CR mshinwell: We should have a robust means of propagating which + parameter is the exception bucket. Then this hack can be + removed. *) + if !first && Continuation.is_exn cont then begin + first := false; + true + end else begin + first := false; + Name_occurrences.mem_var free_names (KP.var param) + end) + params in let used_extra_params = List.filter (fun extra_param -> @@ -156,6 +181,25 @@ and simplify_non_recursive_let_cont_handler let cont_handler = Non_recursive_let_cont_handler.handler non_rec_handler in Non_recursive_let_cont_handler.pattern_match non_rec_handler ~f:(fun cont ~body -> + let free_names_of_body = Expr.free_names body in + let denv = DA.denv dacc in + let unit_toplevel_exn_cont = DE.unit_toplevel_exn_continuation denv in + let at_unit_toplevel = + (* We try to show that [handler] postdominates [body] (which is done by + showing that [body] can only return through [cont]) and that if + [body] raises any exceptions then it only does so to toplevel. + If this can be shown and we are currently at the toplevel of a + compilation unit, the handler for the environment can remain marked + as toplevel (and suitable for [Let_symbol] bindings); otherwise, it + cannot. *) + DE.at_unit_toplevel denv + && (not (Continuation_handler.is_exn_handler cont_handler)) + && Variable.Set.is_empty + (Name_occurrences.variables free_names_of_body) + && Continuation.Set.subset + (Name_occurrences.continuations free_names_of_body) + (Continuation.Set.of_list [cont; unit_toplevel_exn_cont]) + in let body, handler, user_data, uacc = let body, (result, uenv', user_data), uacc = let scope = DE.get_continuation_scope_level (DA.denv dacc) in @@ -212,9 +256,13 @@ and simplify_non_recursive_let_cont_handler handler_typing_env, extra_params_and_args in let dacc = - DA.create (DE.with_typing_env denv typing_env)xi + DA.create (DE.with_typing_env denv typing_env) cont_uses_env r in + let dacc = + if at_unit_toplevel then dacc + else DA.map_denv dacc ~f:DE.set_not_at_unit_toplevel + in try let handler, user_data, uacc = simplify_one_continuation_handler dacc diff --git a/middle_end/flambda2.0/simplify/simplify_import.ml b/middle_end/flambda2.0/simplify/simplify_import.ml index 688291a970ce..c2d3175974f5 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.ml +++ b/middle_end/flambda2.0/simplify/simplify_import.ml @@ -42,6 +42,7 @@ module DE = Simplify_env_and_result.Downwards_env module EA = Continuation_extra_params_and_args.Extra_arg module EPA = Continuation_extra_params_and_args module FD = Function_declaration +module FU = Flambda_unit module K = Flambda_kind module KP = Kinded_parameter module NM = Name_mode diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index 5b1c1ccb2ef9..c9e519f7add2 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -43,12 +43,14 @@ module DE = Simplify_env_and_result.Downwards_env module EA = Continuation_extra_params_and_args.Extra_arg module EPA = Continuation_extra_params_and_args module FD = Function_declaration +module FU = Flambda_unit module K = Flambda_kind module KP = Kinded_parameter module NM = Name_mode module P = Flambda_primitive module R = Simplify_env_and_result.Result module S = Simplify_simple +module SC = Static_const module T = Flambda_type module TE = Flambda_type.Typing_env module TEE = Flambda_type.Typing_env_extension diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index e2053a230a1d..9535b069219c 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -267,10 +267,9 @@ type simplify_set_of_closures0_result = { newer_versions_of : Code_id.t Code_id.Map.t; code : Flambda.Function_params_and_body.t Code_id.Map.t; dacc : Downwards_acc.t; - result_dacc : Downwards_acc.t; } -let simplify_set_of_closures0 dacc ~result_dacc set_of_closures +let simplify_set_of_closures0 dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types = let function_decls = Set_of_closures.function_decls set_of_closures in let all_function_decls_in_set = Function_declarations.funs function_decls in @@ -323,8 +322,6 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures fun_types Name_in_binding_pos.Map.empty in - (* We have to compute [dacc] and [result_dacc] for the same reasons as - described in [Simplify_static.simplify_static_part_of_kind_value]. *) (* CR mshinwell: Maybe [my_closure] is missing here... *) let existing_typing_env = DE.typing_env (DA.denv dacc) in (* CR mshinwell: Try to tidy up (cf. simplify_static_part_of_kind_value). *) @@ -352,30 +349,6 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures closure_types_by_bound_name suitable_for_denv) in - let result_dacc = - DA.map_denv (DA.with_r result_dacc r) ~f:(fun denv -> - let denv = - DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants r) - in - let suitable_for_denv = - Closure_id.Map.fold (fun _closure_id bound_name denv -> - DE.define_name denv bound_name K.value) - closure_bound_names - denv - in - let suitable_for = DE.typing_env suitable_for_denv in - Name_in_binding_pos.Map.fold (fun bound_name closure_type denv -> - let env_extension = - T.make_suitable_for_environment closure_type - existing_typing_env - ~suitable_for - ~bind_to:(Name_in_binding_pos.to_name bound_name) - in - DE.with_typing_env denv - (TE.add_env_extension suitable_for ~env_extension)) - closure_types_by_bound_name - suitable_for_denv) - in let set_of_closures = Set_of_closures.create (Function_declarations.create all_function_decls_in_set) @@ -387,7 +360,6 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures newer_versions_of; code; dacc; - result_dacc; } let simplify_and_lift_set_of_closures dacc ~closure_bound_vars @@ -404,12 +376,11 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars Symbol.create (Compilation_unit.get_current_exn ()) name) (Function_declarations.funs function_decls) in - let _set_of_closures, _dacc, result_dacc, static_structure_types, + let _set_of_closures, dacc, static_structure_types, static_structure = - Simplify_static.simplify_set_of_closures0 dacc ~result_dacc:dacc + Simplify_static.simplify_set_of_closures0 dacc set_of_closures ~closure_symbols ~closure_elements ~closure_element_types in - let dacc = result_dacc in let r = let definition : Definition.t = { computation = None; @@ -452,32 +423,31 @@ let simplify_non_lifted_set_of_closures dacc ~bound_vars ~closure_bound_vars closure_types_by_bound_name = _; newer_versions_of; code; - dacc = _; - result_dacc; + dacc; } = - simplify_set_of_closures0 dacc ~result_dacc:dacc set_of_closures - ~closure_bound_names ~closure_elements ~closure_element_types + simplify_set_of_closures0 dacc set_of_closures ~closure_bound_names + ~closure_elements ~closure_element_types in let defining_expr = Reachable.reachable (Named.create_set_of_closures set_of_closures) in - let result_dacc = - DA.map_r result_dacc ~f:(fun r -> + let dacc = + DA.map_r dacc ~f:(fun r -> R.new_lifted_constant r - (Lifted_constant.create_pieces_of_code (DA.denv result_dacc) + (Lifted_constant.create_pieces_of_code (DA.denv dacc) code ~newer_versions_of)) in - let result_dacc = + let dacc = (* CR mshinwell: This seems weird. Should there ever be lifted constants in the [r] component of a [dacc] that are not in the [denv] component of a dacc? If not maybe we could enforce that via a check. - (This comment predates the addition of the code to [result_dacc] + (This comment predates the addition of the code to [dacc] just above.) *) - DA.map_denv result_dacc ~f:(fun denv -> + DA.map_denv dacc ~f:(fun denv -> DE.add_lifted_constants denv - ~lifted:(R.get_lifted_constants (DA.r result_dacc))) + ~lifted:(R.get_lifted_constants (DA.r dacc))) in - [bound_vars, defining_expr], result_dacc + [bound_vars, defining_expr], dacc type can_lift = | Can_lift diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.mli b/middle_end/flambda2.0/simplify/simplify_named.rec.mli index d28621a294f4..eccbcb6cedde 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.mli +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.mli @@ -37,12 +37,10 @@ type simplify_set_of_closures0_result = private { newer_versions_of : Code_id.t Code_id.Map.t; code : Flambda.Function_params_and_body.t Code_id.Map.t; dacc : Downwards_acc.t; - result_dacc : Downwards_acc.t; } val simplify_set_of_closures0 : Downwards_acc.t - -> result_dacc:Downwards_acc.t -> Flambda.Set_of_closures.t -> closure_bound_names:Name_in_binding_pos.t Closure_id.Map.t -> closure_elements:Simple.t Var_within_closure.Map.t diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index 97da6950cf2a..d492c5947c73 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -18,117 +18,12 @@ open! Simplify_import -module Bound_symbols = Flambda_static.Program_body.Bound_symbols -module Definition = Flambda_static.Program_body.Definition -module Of_kind_value = Flambda_static.Of_kind_value -module Program = Flambda_static.Program -module Program_body = Flambda_static.Program_body -module Static_part = Flambda_static.Static_part -module Static_structure = Flambda_static.Program_body.Static_structure - -module Return_cont_handler = struct - type t = { - computed_values : KP.t list; - static_structure : Static_structure.t; - } - - let print ppf { computed_values; static_structure; } = - Format.fprintf ppf "@[(\ - @[(computed_values@ %a)@]@ \ - @[(static_structure@ %a)@]\ - )@]" - KP.List.print computed_values - Static_structure.print static_structure - - let is_exn_handler _t = false - let stub _t = false - - (* CR mshinwell: Stop duplicating types of this form *) - type behaviour = - | Unreachable of { arity : Flambda_arity.t; } - | Alias_for of { arity : Flambda_arity.t; alias_for : Continuation.t; } - | Apply_cont_with_constant_arg of { - cont : Continuation.t; - arg : Simple.Const.t; - arity : Flambda_arity.t; - } - | Unknown of { arity : Flambda_arity.t; } - - (* Silence warning 37. *) - let _ = Unreachable { arity = []; } - let _ = Apply_cont_with_constant_arg { - cont = Continuation.dummy; - arg = Tagged_immediate Immediate.zero; - arity = []; - } - let _ = Alias_for { arity = []; alias_for = Continuation.dummy; } - - let arity t = KP.List.arity t.computed_values - - let behaviour t = Unknown { arity = arity t; } - - let real_handler _t = None - - module Opened = struct - type nonrec t = t - (* CR mshinwell: Document why these aren't freshened *) - let params t = t.computed_values - end - - let pattern_match t ~f = f t -end - -module Exn_cont_handler = struct - type t = unit - - let print ppf () = Format.pp_print_string ppf "()" - - let is_exn_handler _t = true - let stub _t = false - - type behaviour = - | Unreachable of { arity : Flambda_arity.t; } - | Alias_for of { arity : Flambda_arity.t; alias_for : Continuation.t; } - | Apply_cont_with_constant_arg of { - cont : Continuation.t; - arg : Simple.Const.t; - arity : Flambda_arity.t; - } - | Unknown of { arity : Flambda_arity.t; } - - (* Silence warning 37. *) - let _ = Unreachable { arity = []; } - let _ = Apply_cont_with_constant_arg { - cont = Continuation.dummy; - arg = Tagged_immediate Immediate.zero; - arity = []; - } - let _ = Alias_for { arity = []; alias_for = Continuation.dummy; } - - let arity _t = [K.value] - - let behaviour t = Unknown { arity = arity t; } - - let real_handler _t = None - - module Opened = struct - type nonrec t = KP.t - let params t = [t] - end - - let pattern_match _t ~f = - f (KP.create (Parameter.wrap (Variable.create "exn")) K.value) -end - -module Simplify_return_cont = - Generic_simplify_let_cont.Make (Return_cont_handler) - -module Simplify_exn_cont = - Generic_simplify_let_cont.Make (Exn_cont_handler) +module Bound_symbols = Let_symbol.Bound_symbols +module Field_of_block = Static_const.Field_of_block (* CR-someday mshinwell: Finish improved simplification using types *) -let simplify_of_kind_value dacc (of_kind_value : Of_kind_value.t) = +let simplify_field_of_block dacc (of_kind_value : Field_of_block.t) = let denv = DA.denv dacc in match of_kind_value with | Symbol sym -> @@ -144,16 +39,16 @@ let simplify_of_kind_value dacc (of_kind_value : Of_kind_value.t) = of_kind_value, T.bottom K.value | Ok simple, ty -> match Simple.descr simple with - | Name (Symbol sym) -> Of_kind_value.Symbol sym, ty + | Name (Symbol sym) -> Field_of_block.Symbol sym, ty | Name (Var _) -> of_kind_value, ty - | Const (Tagged_immediate imm) -> Of_kind_value.Tagged_immediate imm, ty + | Const (Tagged_immediate imm) -> Field_of_block.Tagged_immediate imm, ty | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _) -> (* CR mshinwell: This should be "invalid" and propagate up *) of_kind_value, ty let simplify_or_variable dacc type_for_const - (or_variable : _ Static_part.or_variable) = + (or_variable : _ static_const.or_variable) = let denv = DA.denv dacc in match or_variable with | Const const -> or_variable, type_for_const const @@ -162,8 +57,8 @@ let simplify_or_variable dacc type_for_const to the various cases below. *) or_variable, DE.find_variable denv var -let simplify_set_of_closures0 dacc ~result_dacc set_of_closures - ~closure_symbols ~closure_elements ~closure_element_types = +let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols + ~closure_elements ~closure_element_types = let closure_bound_names = Closure_id.Map.map Name_in_binding_pos.symbol closure_symbols in @@ -173,20 +68,19 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures newer_versions_of; code; dacc; - result_dacc; } = - Simplify_named.simplify_set_of_closures0 dacc ~result_dacc set_of_closures + Simplify_named.simplify_set_of_closures0 dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types in let static_structure : Program_body.Static_structure.t = let code = - Code_id.Map.mapi (fun code_id params_and_body : Static_part.code -> + Code_id.Map.mapi (fun code_id params_and_body : static_const.code -> { params_and_body = Present params_and_body; newer_version_of = Code_id.Map.find_opt code_id newer_versions_of; }) code in - let static_part : K.fabricated Static_part.t = + let static_const : K.fabricated static_const.t = Code_and_set_of_closures { code; set_of_closures = Some set_of_closures; @@ -198,7 +92,7 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures closure_symbols; } in - [S (bound_symbols, static_part)] + [S (bound_symbols, static_const)] in let static_structure_types = Name_in_binding_pos.Map.fold @@ -208,9 +102,9 @@ let simplify_set_of_closures0 dacc ~result_dacc set_of_closures closure_types_by_bound_name Symbol.Map.empty in - set_of_closures, dacc, result_dacc, static_structure_types, static_structure + set_of_closures, dacc, static_structure_types, static_structure -let simplify_set_of_closures dacc ~result_dacc set_of_closures +let simplify_set_of_closures dacc set_of_closures ~closure_symbols = let { Simplify_named. can_lift = _; @@ -220,151 +114,100 @@ let simplify_set_of_closures dacc ~result_dacc set_of_closures Simplify_named.type_closure_elements_and_make_lifting_decision dacc ~min_name_mode:Name_mode.normal set_of_closures in - simplify_set_of_closures0 dacc ~result_dacc set_of_closures - ~closure_symbols ~closure_elements ~closure_element_types - -let simplify_static_part_of_kind_value dacc ~result_dacc - (static_part : K.value Static_part.t) ~result_sym - : K.value Static_part.t * DA.t * DA.t = - (* [dacc] holds the environment for simplifying the [Static_part]; it contains - bindings for any computed values in addition to the types of everything - prior to the current [Definition]. + simplify_set_of_closures0 dacc set_of_closures ~closure_symbols + ~closure_elements ~closure_element_types - [result_dacc] holds the environment, which we are computing, that will be - in effect immediately after the current [Definition]. - - We have to return both a new [dacc] and a new [result_dacc] since there may - be multiple (ordered) symbol bindings in any given [Static_structure]. For - simplifying the (N+1)th of those, we need the starting [dacc], plus the - types for the (0..N)th bindings too. We can't just use [result_dacc] as it - doesn't contain the bindings for the computed values. *) +let simplify_static_const_of_kind_value dacc + (static_const : Static_const.t) ~result_sym + : Static_const.t * DA.t = let bind_result_sym typ = - (* CR mshinwell: tidy up. *) - let existing_typing_env = DE.typing_env (DA.denv dacc) in - let dacc = - DA.map_denv dacc ~f:(fun denv -> - let suitable_for = - (* [result_sym] will already be defined when we are lifting - reified computed values (see below). *) - DE.typing_env (DE.define_symbol_if_undefined denv result_sym K.value) - in - let env_extension = - T.make_suitable_for_environment typ - existing_typing_env - ~suitable_for - ~bind_to:(Name.symbol result_sym) - in - DE.with_typing_env denv - (TE.add_env_extension suitable_for ~env_extension)) - in - let result_dacc = - DA.map_denv result_dacc ~f:(fun result_denv -> - let suitable_for = - DE.typing_env (DE.define_symbol result_denv result_sym K.value) - in - let env_extension = - T.make_suitable_for_environment typ - existing_typing_env - ~suitable_for - ~bind_to:(Name.symbol result_sym) - in - DE.with_typing_env result_denv - (TE.add_env_extension suitable_for ~env_extension)) - in - dacc, result_dacc + DA.map_denv dacc ~f:(fun denv -> + let denv = + (* [result_sym] will already be defined when we are lifting + reified computed values (see below). *) + DE.typing_env (DE.define_symbol_if_undefined denv result_sym K.value) + in + DE.add_equation_on_symbol denv result_sym typ) in - match static_part with + match static_const with | Block (tag, is_mutable, fields) -> let fields_with_tys = - List.map (fun of_kind_value -> - simplify_of_kind_value dacc of_kind_value) - fields + List.map (fun field -> simplify_field_of_block dacc field) fields in let fields, field_tys = List.split fields_with_tys in let ty = T.immutable_block (Tag.Scannable.to_tag tag) ~field_kind:K.value ~fields:field_tys in - let dacc, result_dacc = bind_result_sym ty in - Block (tag, is_mutable, fields), dacc, result_dacc - | Fabricated_block var -> - DE.check_variable_is_bound (DA.denv dacc) var; - let dacc, result_dacc = bind_result_sym (T.any_value ()) in - static_part, dacc, result_dacc + let dacc = bind_result_sym ty in + Block (tag, is_mutable, fields), dacc (* CR mshinwell: Need to reify to change Equals types into new terms *) | Boxed_float or_var -> let or_var, ty = simplify_or_variable dacc (fun f -> T.this_boxed_float f) or_var in - let dacc, result_dacc = bind_result_sym ty in - Boxed_float or_var, dacc, result_dacc + let dacc = bind_result_sym ty in + Boxed_float or_var, dacc | Boxed_int32 or_var -> let or_var, ty = simplify_or_variable dacc (fun f -> T.this_boxed_int32 f) or_var in - let dacc, result_dacc = bind_result_sym ty in - Boxed_int32 or_var, dacc, result_dacc + let dacc = bind_result_sym ty in + Boxed_int32 or_var, dacc | Boxed_int64 or_var -> let or_var, ty = simplify_or_variable dacc (fun f -> T.this_boxed_int64 f) or_var in - let dacc, result_dacc = bind_result_sym ty in - Boxed_int64 or_var, dacc, result_dacc + let dacc = bind_result_sym ty in + Boxed_int64 or_var, dacc | Boxed_nativeint or_var -> let or_var, ty = simplify_or_variable dacc (fun f -> T.this_boxed_nativeint f) or_var in - let dacc, result_dacc = bind_result_sym ty in - Boxed_nativeint or_var, dacc, result_dacc + let dacc = bind_result_sym ty in + Boxed_nativeint or_var, dacc | Immutable_float_array fields -> let fields_with_tys = List.map (fun field -> - simplify_or_variable dacc - (fun f -> T.this_naked_float f) - field) + simplify_or_variable dacc (fun f -> T.this_naked_float f) field) fields in let fields, _field_tys = List.split fields_with_tys in - let dacc, result_dacc = bind_result_sym (T.any_value ()) in - Immutable_float_array fields, dacc, result_dacc + let dacc = bind_result_sym (T.any_value ()) in + Immutable_float_array fields, dacc | Mutable_string { initial_value; } -> - let initial_value, str_ty = - simplify_or_variable dacc (fun initial_value -> - T.mutable_string ~size:(String.length initial_value)) - initial_value - in - let static_part : K.value Static_part.t = + let str_ty = T.mutable_string ~size:(String.length initial_value) in + let static_const : K.value static_const.t = Mutable_string { initial_value; } in - let dacc, result_dacc = bind_result_sym str_ty in - static_part, dacc, result_dacc - | Immutable_string or_var -> - let or_var, ty = - simplify_or_variable dacc (fun str -> T.this_immutable_string str) - or_var - in - let dacc, result_dacc = bind_result_sym ty in - Immutable_string or_var, dacc, result_dacc - -let simplify_static_part_of_kind_fabricated dacc ~result_dacc - (static_part : K.fabricated Static_part.t) - ~code_ids ~closure_symbols - : K.fabricated Static_part.t * DA.t * DA.t = - match static_part with + let dacc = bind_result_sym str_ty in + static_const, dacc + | Immutable_string str -> + let ty = T.this_immutable_string str in + let dacc = bind_result_sym ty in + Immutable_string str, dacc + | Code_and_set_of_closures _ -> + Misc.fatal_errorf "[Code_and_set_of_closures] cannot be bound by a \ + [Singleton] binding:@ %a" + SC.print t + +let simplify_static_const_of_kind_fabricated dacc + (static_const : Static_const.t) ~result_sym + : Static_const.t * DA.t = | Code_and_set_of_closures { code; set_of_closures; } -> let code_ids' = Code_id.Map.keys code in if not (Code_id.Set.equal code_ids code_ids') then begin Misc.fatal_errorf "Mismatch on declared code IDs (%a and %a):@ %a" Code_id.Set.print code_ids Code_id.Set.print code_ids' - Static_part.print static_part + static_const.print static_const end; - let dacc, result_dacc = + let dacc = Code_id.Map.fold - (fun code_id ({ params_and_body; newer_version_of; } : Static_part.code) - (dacc, result_dacc) -> + (fun code_id ({ params_and_body; newer_version_of; } : static_const.code) + dacc -> (* CR mshinwell: Add invariant check to ensure there are no unbound names in the code, since we're not simplifying on the way down. *) @@ -375,564 +218,32 @@ let simplify_static_part_of_kind_fabricated dacc ~result_dacc DE.define_code denv ?newer_version_of ~code_id ~params_and_body in let dacc = DA.map_denv dacc ~f:define_code in - let result_dacc = DA.map_denv result_dacc ~f:define_code in - dacc, result_dacc) + dacc) code - (dacc, result_dacc) + dacc in - let set_of_closures, dacc, result_dacc = + let set_of_closures, dacc = match set_of_closures with - | None -> None, dacc, result_dacc + | None -> None, dacc | Some set_of_closures -> - let set_of_closures, dacc, result_dacc, _static_structure_types, - _static_structure = - simplify_set_of_closures dacc ~result_dacc set_of_closures + let set_of_closures, dacc, _static_structure_types, _static_structure = + simplify_set_of_closures dacc set_of_closures ~closure_symbols in - Some set_of_closures, dacc, result_dacc + Some set_of_closures, dacc in - Code_and_set_of_closures { code; set_of_closures; }, dacc, result_dacc + Code_and_set_of_closures { code; set_of_closures; }, dacc + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _ -> + Misc.fatal_errorf "Only [Code_and_set_of_closures] can be bound by a \ + [Code_and_set_of_closures] binding:@ %a" + SC.print t -let simplify_piece_of_static_structure (type k) dacc ~result_dacc - (bound_syms : k Program_body.Bound_symbols.t) - (static_part : k Static_part.t) - : k Static_part.t * DA.t * DA.t = - (* - Format.eprintf "Piece: dacc:@ %a@ result_dacc:@ %a@ %a\n%!" - DA.print dacc - DA.print result_dacc - Static_part.print static_part; - *) +let simplify_static_const (type k) dacc (bound_syms : Bound_symbols.t) + (static_const : SC.t) : SC.t * DA.t = match bound_syms with | Singleton result_sym -> - simplify_static_part_of_kind_value dacc ~result_dacc static_part - ~result_sym + simplify_static_const_of_kind_value dacc static_const ~result_sym | Code_and_set_of_closures { code_ids; closure_symbols; } -> - simplify_static_part_of_kind_fabricated dacc ~result_dacc static_part - ~code_ids ~closure_symbols - -let simplify_static_structure dacc ~result_dacc pieces - : DA.t * Program_body.Static_structure.t = - let str_rev, _dacc, result_dacc = - List.fold_left - (fun (str_rev, dacc, result_dacc) - (Static_structure.S (bound_syms, static_part)) -> - let static_part, dacc, result_dacc = - simplify_piece_of_static_structure dacc ~result_dacc - bound_syms static_part - in - let binding : Program_body.Static_structure.t0 = - S (bound_syms, static_part) - in - let str_rev = binding :: str_rev in - str_rev, dacc, result_dacc) - ([], dacc, result_dacc) - pieces - in - result_dacc, List.rev str_rev - -let reify_types_of_computed_values dacc ~result_dacc computed_values = - let typing_env = DE.typing_env (DA.denv dacc) in - Variable.Set.fold - (fun var (result_dacc, dacc, reified_definitions) -> - let ty = TE.find typing_env (Name.var var) in - let existing_symbol = - (* We must avoid attempting to create aliases between symbols or - (equivalently) defining static parts that already have symbols. - This could happen if [var] is actually equal to another of the - computed value variables. *) - let typing_env = DE.typing_env (DA.denv dacc) in - match - TE.get_canonical_simple typing_env ~min_name_mode:NM.normal - (Simple.var var) - with - | Bottom | Ok None -> None - | Ok (Some simple) -> - match Simple.descr simple with - | Name (Symbol symbol) -> Some symbol - | Name (Var _) | Const _ -> None - in - match existing_symbol with - | Some _ -> result_dacc, dacc, reified_definitions - | None -> - begin match - T.reify ~allowed_free_vars:computed_values typing_env - ~min_name_mode:NM.normal ty - with - | Lift to_lift -> - let static_part = Reification.create_static_part to_lift in - let symbol = - Symbol.create (Compilation_unit.get_current_exn ()) - (Linkage_name.create (Variable.unique_name var)) - in - let dacc = - DA.map_denv dacc ~f:(fun denv -> - DE.add_equation_on_name (DE.define_symbol denv symbol K.value) - (Name.var var) - (T.alias_type_of K.value (Simple.symbol symbol))) - in - let static_structure_part : Static_structure.t0 = - S (Singleton symbol, static_part) - in - result_dacc, dacc, (var, static_structure_part) :: reified_definitions - | Lift_set_of_closures { closure_id; function_decls; closure_vars; } -> - let closure_symbols = - Closure_id.Map.mapi (fun closure_id _function_decl -> - (* CR mshinwell: share name computation with [Simplify_named] *) - let name = - closure_id - |> Closure_id.rename - |> Closure_id.to_string - |> Linkage_name.create - in - Symbol.create (Compilation_unit.get_current_exn ()) name) - function_decls - in - (* - Format.eprintf "Var %a: set of closures:@ %a@ vars:@ %a\n%!" - Variable.print var - (Closure_id.Map.print Symbol.print) closure_symbols - (Var_within_closure.Map.print Simple.print) closure_vars; - *) - let dacc = - DA.map_denv dacc ~f:(fun denv -> - let denv = - Closure_id.Map.fold (fun _closure_id symbol denv -> - DE.define_symbol denv symbol K.value) - closure_symbols - denv - in - match Closure_id.Map.find closure_id closure_symbols with - | exception Not_found -> - Misc.fatal_errorf "Variable %a claimed to hold closure with \ - closure ID %a, but no symbol was found for that closure ID" - Variable.print var - Closure_id.print closure_id - | symbol -> - DE.add_equation_on_name denv - (Name.var var) - (T.alias_type_of K.value (Simple.symbol symbol))) - in - let module I = T.Function_declaration_type.Inlinable in - (* The same code might be reified multiple times and we don't currently - dedup, so we must assign fresh code IDs. *) - let fresh_code_ids = - Closure_id.Map.map (fun inlinable -> - Code_id.rename (I.code_id inlinable)) - function_decls - in - let newer_versions_of = - Closure_id.Map.fold (fun closure_id inlinable newer_versions_of -> - let code_id = I.code_id inlinable in - let fresh_code_id = - Closure_id.Map.find closure_id fresh_code_ids - in - Code_id.Map.add fresh_code_id code_id newer_versions_of) - function_decls - Code_id.Map.empty - in - let set_of_closures = - let function_decls = - Closure_id.Map.mapi (fun closure_id inlinable -> - let code_id = Closure_id.Map.find closure_id fresh_code_ids in - Function_declaration.create ~code_id - ~params_arity:(I.param_arity inlinable) - ~result_arity:(I.result_arity inlinable) - ~stub:(I.stub inlinable) - ~dbg:(I.dbg inlinable) - ~inline:(I.inline inlinable) - ~is_a_functor:(I.is_a_functor inlinable) - ~recursive:(I.recursive inlinable)) - function_decls - |> Function_declarations.create - in - Set_of_closures.create function_decls ~closure_elements:closure_vars - in - let by_code_id = - Closure_id.Map.fold (fun closure_id _inlinable by_code_id -> - let code_id = Closure_id.Map.find closure_id fresh_code_ids in - let params_and_body = DE.find_code (DA.denv dacc) code_id in - Code_id.Map.add code_id params_and_body by_code_id) - function_decls - Code_id.Map.empty - in - let static_structure_part = - Static_structure.pieces_of_code ~newer_versions_of - ~set_of_closures:(closure_symbols, set_of_closures) - by_code_id - in - result_dacc, dacc, (var, static_structure_part) :: reified_definitions - | Simple _ | Cannot_reify | Invalid -> - result_dacc, dacc, reified_definitions - end) - computed_values - (result_dacc, dacc, []) - -module Bindings_top_sort = - Top_closure.Make - (struct - type t = Variable.Set.t - type elt = Variable.t - let empty = Variable.Set.empty - let add t elt = Variable.Set.add elt t - let mem t elt = Variable.Set.mem elt t - end) - (struct - type 'a t = 'a - let return t = t - let (>>=) t f = f t - end) - -let simplify_return_continuation_handler dacc - ~(extra_params_and_args : Continuation_extra_params_and_args.t) - cont (return_cont_handler : Return_cont_handler.Opened.t) - ~user_data:result_dacc _k = - let result_dacc = - (* [DA.r dacc] contains the lifted constants etc. arising from the - simplification of any associated [computation]. *) - let r = DA.r dacc in - DA.map_denv (DA.with_r result_dacc r) ~f:(fun denv -> - DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants r)) - in - let allowed_free_vars = - Variable.Set.union (KP.List.var_set return_cont_handler.computed_values) - (KP.List.var_set extra_params_and_args.extra_params) - in - let static_structure, result_dacc = - let result_dacc, dacc, reified_definitions = - (* If the type of a computed value can be reified (to a term possibly - involving any extra params and args that are present, from unboxing - etc.) then lift that computed value to its own [Static_part]. *) - reify_types_of_computed_values dacc ~result_dacc allowed_free_vars - in - let top_sorted_reified_definitions = - (* Use a topological sort to try to order the bindings so that as many - computed value variables can be changed into symbols as possible. - If there is a cycle, we just pick an order. The worst that will happen - is that some variables won't simplify to symbols (and will remain - as computed values). *) - (* CR mshinwell: I'm a bit concerned that if the top-sort fails, then - we could end up with symbols being defined after they are used, - in the list of static parts. Should we completely abort in this - case and fall back to the original environment that doesn't have the - equalities to symbols in it? *) - match - Bindings_top_sort.top_closure reified_definitions - ~key:(fun (var, Static_structure.S (_symbols, _static_part)) -> var) - ~deps:(fun (_var, Static_structure.S (symbols, static_part)) -> - let var_deps = - static_part - |> Static_part.free_names - |> Name_occurrences.variables - |> Variable.Set.elements - in - (* - Format.eprintf "Deps for %a are %a\n%!" - Variable.print var - Variable.Set.print (Variable.Set.of_list var_deps); - *) - (* Everything except the [var] in the following list will be - ignored. *) - List.map (fun var -> var, Static_structure.S (symbols, static_part)) - var_deps) - with - | Ok sorted -> sorted - | Error _ -> reified_definitions - in - (* XXX If top sort fails, change types of the variables involved to "=v" - where each v is another thing like a computed value variable, but will - assume the value of the symbol. *) - let static_structure : Static_structure.t = - let top_sorted_reified_definitions = - (* The [List.rev] relies on the following property: - Let the list L be a topological sort of a directed graph G. - Then the reverse of L is a topological sort of the transpose of G. - *) - List.map (fun (_var, static_structure_part) -> static_structure_part) - (List.rev top_sorted_reified_definitions) - in - (* - Format.eprintf "New defs:@ %a\n" - Static_structure.print top_sorted_reified_definitions; - Format.eprintf "Existing defs:@ %a\n" - Static_structure.print return_cont_handler.static_structure; - *) - top_sorted_reified_definitions @ return_cont_handler.static_structure - in - let result_dacc, static_structure = - simplify_static_structure dacc ~result_dacc static_structure - in - static_structure, result_dacc - in - let handler, result_dacc, uacc = - let free_variables = - Name_occurrences.variables - (Static_structure.free_names static_structure) - in - let used_computed_values = - List.filter (fun param -> - Variable.Set.mem (KP.var param) free_variables) - return_cont_handler.computed_values - in - let used_extra_params = - List.filter (fun extra_param -> - Variable.Set.mem (KP.var extra_param) free_variables) - extra_params_and_args.extra_params - in - let computed_values = used_computed_values @ used_extra_params in - let handler : Return_cont_handler.t = - { computed_values; - static_structure; - } - in - let rewrite = - Apply_cont_rewrite.create - ~original_params:return_cont_handler.computed_values - ~used_params:(KP.Set.of_list used_computed_values) - ~extra_params:extra_params_and_args.extra_params - ~extra_args:extra_params_and_args.extra_args - ~used_extra_params:(KP.Set.of_list used_extra_params) - in - let uenv = UE.add_apply_cont_rewrite UE.empty cont rewrite in - handler, result_dacc, UA.create uenv (DA.r result_dacc) - in - (* CR mshinwell: It would maybe be easier to avoid returning [result_dacc]. - This would also match [Simplify_expr]. *) - (* CR mshinwell: Returning [computed_values] and [static_structure] is - redundant, they're in [handler]. *) - handler, - (handler.Return_cont_handler.computed_values, - handler.Return_cont_handler.static_structure, - result_dacc), uacc - -let simplify_exn_continuation_handler dacc - ~extra_params_and_args:_ _cont - (_handler : Exn_cont_handler.Opened.t) ~user_data:_ k = - let handler : Exn_cont_handler.t = () in - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in - handler, user_data, uacc - -let simplify_definition dacc (defn : Program_body.Definition.t) = - let dacc, computation, static_structure = - match defn.computation with - | None -> - let dacc, static_structure = - simplify_static_structure dacc ~result_dacc:dacc defn.static_structure - in - dacc, None, static_structure - | Some computation -> - let return_continuation = computation.return_continuation in - let return_cont_handler : Return_cont_handler.t = - { computed_values = computation.computed_values; - static_structure = defn.static_structure; - } - in - let exn_continuation = computation.exn_continuation in - let exn_cont_handler : Exn_cont_handler.t = () in - let result_dacc = dacc in - let expr, _handler, (computed_values, static_structure, result_dacc), - uacc = - let simplify_body dacc expr k = - let expr, _handler, user_data, uacc = - let simplify_body : _ Simplify_exn_cont.simplify_body = - { simplify_body = Simplify_expr.simplify_expr; } - in - Simplify_exn_cont.simplify_body_of_non_recursive_let_cont dacc - (Exn_continuation.exn_handler exn_continuation) - exn_cont_handler - ~simplify_body - ~body:expr - ~simplify_continuation_handler_like: - simplify_exn_continuation_handler - ~user_data:result_dacc - k - in - expr, user_data, uacc - in - let simplify_body : _ Simplify_return_cont.simplify_body = - { simplify_body; } - in - Simplify_return_cont.simplify_body_of_non_recursive_let_cont dacc - return_continuation - return_cont_handler - ~simplify_body - ~body:computation.expr - ~simplify_continuation_handler_like: - simplify_return_continuation_handler - ~user_data:result_dacc - (fun _cont_uses_env r -> - let uacc = UA.create UE.empty r in - (* CR mshinwell: This should return an "invalid" node. *) - (computation.computed_values, defn.static_structure, - result_dacc), uacc) - in - let dacc = result_dacc in - let dacc = DA.with_r dacc (UA.r uacc) in (* CR mshinwell: needed? *) - let computation_can_be_deleted = - match Expr.descr expr with - | Apply_cont apply_cont -> - begin match Apply_cont.to_goto apply_cont with - | Some cont when Continuation.equal cont return_continuation -> true - | _ -> false - end - | Let _ | Let_cont _ | Apply _ | Switch _ | Invalid _ -> false - in - let computation : Program_body.Computation.t option = - if computation_can_be_deleted then None - else - Some ({ - expr; - return_continuation; - exn_continuation = computation.exn_continuation; - computed_values; - }) - in - dacc, computation, static_structure - in - let definition : Program_body.Definition.t = - { static_structure; - computation; - } - in - definition, dacc - -(* CR mshinwell: We should simplify code on the way up if we don't delete it. *) - -let define_lifted_constants lifted_constants ~current_definition = - let defined_symbols_current_definition = - Definition.being_defined current_definition - in - let defined_code_ids_current_definition = - Definition.code_being_defined current_definition - in - List.fold_left - (fun (add_to_current_definition, add_around_body) lifted_constant -> - let definition = Lifted_constant.definition lifted_constant in - assert (Option.is_none definition.computation); - let free_names = - Static_structure.free_names definition.static_structure - in - let free_symbols = Name_occurrences.symbols free_names in - let free_code_ids = Name_occurrences.code_ids free_names in - let no_overlap_with_current_definition = - let no_overlap_with_symbols = - Symbol.Set.is_empty - (Symbol.Set.inter free_symbols - defined_symbols_current_definition) - in - let no_overlap_with_code_ids = - Code_id.Set.is_empty - (Code_id.Set.inter free_code_ids - defined_code_ids_current_definition) - in - no_overlap_with_symbols && no_overlap_with_code_ids - in - if no_overlap_with_current_definition then - (* XXX This should add things to the current definition if there - is recursion - - Also for normal reify (not computed values reify), we also need - to check if we have symbols currently being defined in the reified - type, and if so not lift (except for closures). - An alternative: add a computation that reads from the symbol - being defined and fills in the fields. *) - let add_around_body = - definition :: add_around_body - in - add_to_current_definition, add_around_body - else - let add_to_current_definition = - List.flatten [definition.static_structure; add_to_current_definition] - in - add_to_current_definition, add_around_body) - ([], []) - lifted_constants - -let rec simplify_program_body0 dacc (body : Program_body.t) k = - match Program_body.descr body with - | Definition (defn, body) -> - let dacc = DA.map_r dacc ~f:(fun r -> R.clear_lifted_constants r) in - let defn, dacc = simplify_definition dacc defn in - let r = DA.r dacc in - simplify_program_body0 dacc body (fun body dacc -> - let add_to_current_definition, add_around_body = - define_lifted_constants (R.get_lifted_constants r) - ~current_definition:defn - in - let defn = - { defn with - static_structure = add_to_current_definition @ defn.static_structure; - } - in - let body = - Program_body.define_symbol defn ~body - (TE.code_age_relation (DE.typing_env (DA.denv dacc))) - in - let body = - List.fold_left (fun body (defn : Definition.t) -> - let static_structure = - (* CR mshinwell: We should have deletion of unused symbols - automatically -- needs to be done for non-lifted constants - too *) - Static_structure.delete_bindings defn.static_structure - ~free_names_after:(Program_body.free_names body) - (TE.code_age_relation (DE.typing_env (DA.denv dacc))) - in - if Static_structure.is_empty static_structure then body - else - let defn : Program_body.Definition.t = - { computation = None; - static_structure; - } - in - Program_body.define_symbol defn ~body - (TE.code_age_relation (DE.typing_env (DA.denv dacc)))) - body - (List.rev add_around_body) - in - k body dacc) - | Root _ -> k body dacc - -let simplify_program_body dacc body = - simplify_program_body0 dacc body (fun body dacc -> body, dacc) - -let check_imported_symbols_don't_overlap_predef_exns - ~imported_symbols ~predef_exn_symbols ~descr = - let wrong_symbols = - Symbol.Set.inter (Symbol.Map.keys imported_symbols) - (Symbol.Map.keys predef_exn_symbols) - in - if not (Symbol.Set.is_empty wrong_symbols) then begin - Misc.fatal_errorf "Program's [imported_symbols] (%s) must not contain \ - predefined exception symbols" - descr - end - -let simplify_program denv (program : Program.t) : Program.t = - let backend = DE.backend denv in - let module Backend = (val backend : Flambda2_backend_intf.S) in - let predef_exn_symbols = - Symbol.Set.fold (fun symbol predef_exn_symbols -> - Symbol.Map.add symbol K.value predef_exn_symbols) - Backend.all_predefined_exception_symbols - Symbol.Map.empty - in - let denv = - Symbol.Map.fold (fun symbol kind denv -> - DE.add_symbol denv symbol (T.unknown kind)) - (Symbol.Map.disjoint_union program.imported_symbols predef_exn_symbols) - denv - in - check_imported_symbols_don't_overlap_predef_exns - ~imported_symbols:program.imported_symbols ~predef_exn_symbols - ~descr:"before simplification"; - let r = R.create ~resolver:(DE.resolver denv) in - let dacc = DA.create denv Continuation_uses_env.empty r in - let body, dacc = simplify_program_body dacc program.body in - let r = DA.r dacc in - let imported_symbols = R.imported_symbols r in - check_imported_symbols_don't_overlap_predef_exns - ~imported_symbols:imported_symbols ~predef_exn_symbols - ~descr:"after simplification"; - { imported_symbols; - body; - } + simplify_static_const_of_kind_fabricated dacc static_const ~code_ids + ~closure_symbols diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli index 2435ad1822de..cd1cb21e7328 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli @@ -14,24 +14,23 @@ (* *) (**************************************************************************) -(** Simplification of toplevel definitions. *) +(** Simplification of statically-allocated constants bound to symbols. *) [@@@ocaml.warning "+a-4-30-40-41-42"] val simplify_set_of_closures0 : Downwards_acc.t - -> result_dacc:Downwards_acc.t -> Flambda.Set_of_closures.t -> closure_symbols:Symbol.t Closure_id.Map.t -> closure_elements:Simple.t Var_within_closure.Map.t -> closure_element_types:Flambda_type.t Var_within_closure.Map.t -> Flambda.Set_of_closures.t - * Downwards_acc.t * Downwards_acc.t * Flambda_type.t Symbol.Map.t * Flambda_static.Program_body.Static_structure.t -val simplify_program - : Simplify_env_and_result.Downwards_env.t - -> Flambda_static.Program.t - -> Flambda_static.Program.t +val simplify_static_const + : Simplify_env_and_result.Downwards_acc.t + -> Let_symbol_expr.Bound_symbols.t + -> Static_const.t + -> Static_const.t * Simplify_env_and_result.Downwards_acc.t diff --git a/middle_end/flambda2.0/simplify/template/simplify.templ.ml b/middle_end/flambda2.0/simplify/template/simplify.templ.ml index e8f48aaf27d3..eebb0d12e5e7 100644 --- a/middle_end/flambda2.0/simplify/template/simplify.templ.ml +++ b/middle_end/flambda2.0/simplify/template/simplify.templ.ml @@ -18,12 +18,69 @@ (* CR mshinwell: Fix warning 60 *) [@@@ocaml.warning "-60"] +open! Simplify_import + (* -- module rec binding here -- *) -let run ~backend ~round program = +let check_imported_symbols_don't_overlap_predef_exns + ~imported_symbols ~predef_exn_symbols ~descr = + let wrong_symbols = + Symbol.Set.inter (Symbol.Map.keys imported_symbols) + (Symbol.Map.keys predef_exn_symbols) + in + if not (Symbol.Set.is_empty wrong_symbols) then begin + Misc.fatal_errorf "Program's [imported_symbols] (%s) must not contain \ + predefined exception symbols" + descr + end + +let run ~backend ~round unit = + let backend = DE.backend denv in + let module Backend = (val backend : Flambda2_backend_intf.S) in + let predef_exn_symbols = + Symbol.Set.fold (fun symbol predef_exn_symbols -> + Symbol.Map.add symbol K.value predef_exn_symbols) + Backend.all_predefined_exception_symbols + Symbol.Map.empty + in + let imported_symbols = FU.imported_symbols unit in + check_imported_symbols_don't_overlap_predef_exns + ~imported_symbols:imported_symbols ~predef_exn_symbols + ~descr:"before simplification"; + let return_continuation = FU.return_continuation unit in + let exn_continuation = FU.exn_continuation unit in let denv = - Simplify_env_and_result.Downwards_env.create ~round + DE.create ~round ~backend ~float_const_prop:!Clflags.float_const_prop + ~unit_toplevel_exn_continuation:exn_continuation + in + let denv = + Symbol.Map.fold (fun symbol kind denv -> + DE.add_symbol denv symbol (T.unknown kind)) + (Symbol.Map.disjoint_union imported_symbols predef_exn_symbols) + denv + in + let return_cont_scope = DE.continuation_scope_level denv in + let denv = DE.increment_continuation_scope_level denv in + let exn_cont_scope = DE.continuation_scope_level denv in + let denv = DE.increment_continuation_scope_level denv in + let r = R.create ~resolver:(DE.resolver denv) in + let dacc = DA.create denv Continuation_uses_env.empty r in + let body, _cont_uses_env, r = + let exn_continuation = + Exn_continuation.create ~exn_handler:exn_continuation ~extra_args:[] + in + Simplify_toplevel.simplify_toplevel dacc body ~return_continuation + ~return_arity:[K.value] exn_continuation ~return_cont_scope + ~exn_cont_scope in - Simplify_static.simplify_program denv program + let imported_symbols = R.imported_symbols r in + check_imported_symbols_don't_overlap_predef_exns + ~imported_symbols:imported_symbols ~predef_exn_symbols + ~descr:"after simplification"; + FU.create ~imported_symbols + ~root_symbol:(FU.root_symbol unit) + ~return_continuation + ~exn_continuation + body diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index 2c66c8c8825f..e75d3bce98ef 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -23,779 +23,26 @@ type t = { body : Expr.t; } -let create ~imported_symbols ~root_symbol ~exn_continuation ~body = +let create ~imported_symbols ~root_symbol ~return_continuation + ~exn_continuation ~body = { imported_symbols; root_symbol; + return_continuation; exn_continuation; body; } -let fprintf = Format.fprintf +let imported_symbols t = t.imported_symbols +let root_symbol t = t.root_symbol +let return_continuation t = t.return_continuation +let exn_continuation t = t.exn_continuation +let body t = t.body -module K = Flambda_kind +let print ppf t = + Format.fprintf ppf "@[(@[(imported_symbols %a)@]@ @[<1>(body@ %a)@])@]" + (Symbol.Map.print K.print) t.imported_symbols + Program_body.print t.body -module Of_kind_value = struct - type t = - | Symbol of Symbol.t - | Tagged_immediate of Immediate.t - | Dynamically_computed of Variable.t +let invariant _t = () - include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Tagged_immediate t1, Tagged_immediate t2 -> Immediate.compare t1 t2 - | Dynamically_computed v1, Dynamically_computed v2 -> Variable.compare v1 v2 - | Symbol _, Tagged_immediate _ -> -1 - | Tagged_immediate _, Symbol _ -> 1 - | Symbol _, Dynamically_computed _ -> -1 - | Dynamically_computed _, Symbol _ -> 1 - | Tagged_immediate _, Dynamically_computed _ -> -1 - | Dynamically_computed _, Tagged_immediate _ -> 1 - - let equal t1 t2 = - compare t1 t2 = 0 - - let hash t = - match t with - | Symbol symbol -> Hashtbl.hash (0, Symbol.hash symbol) - | Tagged_immediate immediate -> - Hashtbl.hash (1, Immediate.hash immediate) - | Dynamically_computed var -> Hashtbl.hash (2, Variable.hash var) - - let print ppf t = - match t with - | Symbol symbol -> Symbol.print ppf symbol - | Tagged_immediate immediate -> Immediate.print ppf immediate - | Dynamically_computed var -> Variable.print ppf var - - let output chan t = - print (Format.formatter_of_out_channel chan) t - end) - - let free_names t = - match t with - | Dynamically_computed var -> - Name_occurrences.singleton_variable var Name_mode.normal - | Symbol sym -> - Name_occurrences.singleton_symbol sym Name_mode.normal - | Tagged_immediate _ -> Name_occurrences.empty - -(* - let invariant env t = - let module E = Invariant_env in - match t with - | Symbol sym -> E.check_symbol_is_bound env sym - | Tagged_immediate _ -> () - | Dynamically_computed var -> - E.check_variable_is_bound_and_of_kind env var K.value -*) -end - -module Static_part = struct - type 'a or_variable = - | Const of 'a - | Var of Variable.t - - type mutable_or_immutable = Mutable | Immutable - - type code = { - params_and_body : Flambda.Function_params_and_body.t or_deleted; - newer_version_of : Code_id.t option; - } - and 'a or_deleted = - | Present of 'a - | Deleted - - type code_and_set_of_closures = { - code : code Code_id.Map.t; - set_of_closures : Flambda.Set_of_closures.t option; - } - - type 'k t = - | Block : Tag.Scannable.t * mutable_or_immutable - * (Of_kind_value.t list) -> K.value t - | Fabricated_block : Variable.t -> K.value t - (* CR mshinwell: This used to say K.fabricated. Use a different - index from [K.t]? *) - | Code_and_set_of_closures : code_and_set_of_closures - -> Flambda_kind.fabricated t - | Boxed_float : Numbers.Float_by_bit_pattern.t or_variable - -> K.value t - | Boxed_int32 : Int32.t or_variable -> K.value t - | Boxed_int64 : Int64.t or_variable -> K.value t - | Boxed_nativeint : Targetint.t or_variable -> K.value t - | Immutable_float_array : Numbers.Float_by_bit_pattern.t or_variable list - -> K.value t - | Mutable_string : { initial_value : string or_variable; } - -> K.value t - | Immutable_string : string or_variable -> K.value t - - let get_pieces_of_code (type k) (t : k t) = - match t with - | Code_and_set_of_closures { code; set_of_closures = _; } -> - Code_id.Map.filter_map code - ~f:(fun _code_id { params_and_body; newer_version_of; } -> - match params_and_body with - | Present params_and_body -> Some (params_and_body, newer_version_of) - | Deleted -> None) - | Block _ - | Fabricated_block _ - | Boxed_float _ - | Boxed_int32 _ - | Boxed_int64 _ - | Boxed_nativeint _ - | Immutable_float_array _ - | Mutable_string _ - | Immutable_string _ -> Code_id.Map.empty - - let free_names (type k) (t : k t) = - match t with - | Block (_tag, _mut, fields) -> - List.fold_left (fun fvs field -> - Name_occurrences.union fvs (Of_kind_value.free_names field)) - (Name_occurrences.empty) - fields - | Fabricated_block v -> - Name_occurrences.singleton_variable v Name_mode.normal - | Code_and_set_of_closures { code; set_of_closures; } -> - let from_set_of_closures = - match set_of_closures with - | None -> Name_occurrences.empty - | Some set -> Flambda.Set_of_closures.free_names set - in - Code_id.Map.fold - (fun code_id { params_and_body; newer_version_of; } free_names -> - let from_newer_version_of = - match newer_version_of with - | None -> Name_occurrences.empty - | Some older -> - Name_occurrences.add_newer_version_of_code_id - Name_occurrences.empty older Name_mode.normal - in - let from_params_and_body = - match params_and_body with - | Deleted -> Name_occurrences.empty - | Present params_and_body -> - Flambda.Function_params_and_body.free_names params_and_body - in - Name_occurrences.union_list [ - (Name_occurrences.add_code_id Name_occurrences.empty - code_id Name_mode.normal); - from_params_and_body; - from_newer_version_of; - free_names; - ]) - code - from_set_of_closures - | Boxed_float (Var v) - | Boxed_int32 (Var v) - | Boxed_int64 (Var v) - | Boxed_nativeint (Var v) - | Mutable_string { initial_value = Var v; } - | Immutable_string (Var v) -> - Name_occurrences.singleton_variable v Name_mode.normal - | Boxed_float (Const _) - | Boxed_int32 (Const _) - | Boxed_int64 (Const _) - | Boxed_nativeint (Const _) - | Mutable_string { initial_value = Const _; } - | Immutable_string (Const _) -> Name_occurrences.empty - | Immutable_float_array fields -> - List.fold_left (fun fns (field : _ or_variable) -> - match field with - | Var v -> - Name_occurrences.add_variable fns v Name_mode.normal - | Const _ -> fns) - (Name_occurrences.empty) - fields - - let print_params_and_body_with_cache ~cache ppf params_and_body = - match params_and_body with - | Deleted -> Format.fprintf ppf "@[(params_and_body@ Deleted)@]" - | Present params_and_body -> - Flambda.Function_params_and_body.print_with_cache ~cache ppf - params_and_body - - let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = - (* CR mshinwell: elide "newer_version_of" when None *) - Format.fprintf ppf "@[(\ - @[(newer_version_of@ %a)@]@ \ - %a\ - )@]" - (Misc.Stdlib.Option.print Code_id.print) newer_version_of - (print_params_and_body_with_cache ~cache) params_and_body - - let print_with_cache (type k) ~cache ppf (t : k t) = - let print_float_array_field ppf = function - | Const f -> fprintf ppf "%a" Numbers.Float_by_bit_pattern.print f - | Var v -> Variable.print ppf v - in - match t with - | Block (tag, mut, fields) -> - fprintf ppf "@[(@<0>%s%sblock@<0>%s (tag %a) (%a))@]" - (Flambda_colours.static_part ()) - (match mut with Immutable -> "Immutable_" | Mutable -> "Mutable_") - (Flambda_colours.normal ()) - Tag.Scannable.print tag - (Format.pp_print_list ~pp_sep:Format.pp_print_space - Of_kind_value.print) fields - | Fabricated_block field -> - fprintf ppf "@[@<0>%sFabricated_block@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print field - | Code_and_set_of_closures { code; set_of_closures; } -> - fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ - @[(code@ (%a))@]@ \ - @[(set_of_closures@ (%a))@]\ - ))@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Code_id.Map.print (print_code_with_cache ~cache)) code - (Misc.Stdlib.Option.print - (Flambda.Set_of_closures.print_with_cache ~cache)) - set_of_closures - | Boxed_float (Const f) -> - fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Numbers.Float_by_bit_pattern.print f - | Boxed_float (Var v) -> - fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Boxed_int32 (Const n) -> - fprintf ppf "@[@<0>%sBoxed_int32@<0>%s %ld)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - n - | Boxed_int32 (Var v) -> - fprintf ppf "@[@<0>%sBoxed_int32@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Boxed_int64 (Const n) -> - fprintf ppf "@[@<0>%sBoxed_int64@<0>%s %Ld)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - n - | Boxed_int64 (Var v) -> - fprintf ppf "@[@<0>%sBoxed_int64@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Boxed_nativeint (Const n) -> - fprintf ppf "@[@<0>%sBoxed_nativeint@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Targetint.print n - | Boxed_nativeint (Var v) -> - fprintf ppf "@[@<0>%sBoxed_nativeint@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Immutable_float_array fields -> - fprintf ppf "@[@<0>%sImmutable_float_array@<0>%s@ @[[| %a |]@])@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") - print_float_array_field) - fields - | Mutable_string { initial_value = Const s; } -> - fprintf ppf "@[@<0>%sMutable_string@<0>%s@ \"%s\")@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - s - | Mutable_string { initial_value = Var v; } -> - fprintf ppf "@[@<0>%sMutable_string@<0>%s@ %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Immutable_string (Const s) -> - fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ \"%s\")@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - s - | Immutable_string (Var v) -> - fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - - let print ppf t = - print_with_cache ~cache:(Printing_cache.create ()) ppf t - -(* - let _invariant (type k) env (t : k t) = - try - let module E = Invariant_env in - match t with - | Block (_tag, _mut, fields) -> - List.iter (fun field -> Of_kind_value.invariant env field) fields - | Fabricated_block field -> - E.check_variable_is_bound_and_of_kind env field K.fabricated - | Set_of_closures set -> - Flambda.Set_of_closures.invariant env set - | Boxed_float (Var v) -> - E.check_variable_is_bound_and_of_kind env v K.naked_float - | Boxed_int32 (Var v) -> - E.check_variable_is_bound_and_of_kind env v K.naked_int32 - | Boxed_int64 (Var v) -> - E.check_variable_is_bound_and_of_kind env v K.naked_int64 - | Boxed_nativeint (Var v) -> - E.check_variable_is_bound_and_of_kind env v K.naked_nativeint - | Mutable_string { initial_value = Var v; } - | Immutable_string (Var v) -> - E.check_variable_is_bound_and_of_kind env v K.value - | Boxed_float (Const _) - | Boxed_int32 (Const _) - | Boxed_int64 (Const _) - | Boxed_nativeint (Const _) - | Mutable_string { initial_value = Const _; } - | Immutable_string (Const _) -> () - | Immutable_float_array fields -> - List.iter (fun (field : _ or_variable) -> - match field with - | Var v -> - E.check_variable_is_bound_and_of_kind env v - K.naked_float - | Const _ -> ()) - fields - with Misc.Fatal_error -> - Misc.fatal_errorf "(during invariant checks) Context is:@ %a" print t -*) -end - -type static_part_iterator = { - f : 'k. ('k Static_part.t -> unit); -} - -type static_part_mapper = { - f : 'k. ('k Static_part.t -> 'k Static_part.t); -} - -module Program_body = struct - module Computation = struct - type t = { - expr : Flambda.Expr.t; - return_continuation : Continuation.t; - exn_continuation : Exn_continuation.t; - computed_values : Kinded_parameter.t list; - } - - let print ppf { expr; return_continuation; exn_continuation; - computed_values; } = - Format.fprintf ppf "@[(\ - @[(expr@ %a)@]@ \ - @[(return_continuation@ %a)@]@ \ - @[(exn_continuation@ %a)@]@ \ - @[(computed_values@ (%a))@]\ - )@]" - Flambda.Expr.print expr - Continuation.print return_continuation - Exn_continuation.print exn_continuation - Kinded_parameter.List.print computed_values - - let free_names t = Flambda.Expr.free_names t.expr - - let iter_expr t ~f = f t.expr - - let map_expr t ~f = - { t with - expr = f t.expr; - } - end - - module Bound_symbols = struct - type 'k t = - | Singleton : Symbol.t -> K.value t - | Code_and_set_of_closures : { - code_ids : Code_id.Set.t; - closure_symbols : Symbol.t Closure_id.Map.t; - } -> K.fabricated t - - (* CR mshinwell: Share with [Bindable_let_bound] *) - let print_closure_binding ppf (closure_id, sym) = - Format.fprintf ppf "@[(%a \u{21a6} %a)@]" - Closure_id.print closure_id - Symbol.print sym - - let print (type k) ppf (t : k t) = - match t with - | Singleton sym -> - Format.fprintf ppf "@[%a@ \u{2237}@ %a@ @<0>%s=@<0>%s@ @]" - Symbol.print sym - K.print K.value - (Flambda_colours.elide ()) - (Flambda_colours.normal ()) - | Code_and_set_of_closures { code_ids; closure_symbols; } -> - Format.fprintf ppf "@[\ - @[(code_ids@ %a)@]@ \ - @[(closure_symbols@ {%a})@]\ - @]" - Code_id.Set.print code_ids - (Format.pp_print_list ~pp_sep:Format.pp_print_space - print_closure_binding) - (Closure_id.Map.bindings closure_symbols) - - (* CR mshinwell: This should have an [invariant] function. One thing to - check is that the [closure_symbols] are all distinct. *) - - let being_defined (type k) (t : k t) = - match t with - | Singleton sym -> Symbol.Set.singleton sym - | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> - Symbol.Set.of_list (Closure_id.Map.data closure_symbols) - - let code_being_defined (type k) (t : k t) = - match t with - | Singleton _ -> Code_id.Set.empty - | Code_and_set_of_closures { code_ids; closure_symbols = _; } -> code_ids - end - - module Static_structure = struct - type t0 = - | S : 'k Bound_symbols.t * 'k Static_part.t -> t0 - - let print_t0_with_cache ~cache ppf (S (bound_symbols, static_part)) = - Format.fprintf ppf "@[(\ - @[%a@]@ \ - @[(%a)@]\ - )@]" - Bound_symbols.print bound_symbols - (Static_part.print_with_cache ~cache) static_part - - type t = t0 list - - let print_with_cache ~cache ppf t = - Format.pp_print_list ~pp_sep:Format.pp_print_space - (print_t0_with_cache ~cache) ppf t - - let print ppf t = - print_with_cache ~cache:(Printing_cache.create ()) ppf t - - let is_empty t = - match t with - | [] -> true - | _::_ -> false - - let being_defined t = - List.fold_left (fun being_defined (S (bound_syms, _static_part)) -> - Symbol.Set.union (Bound_symbols.being_defined bound_syms) - being_defined) - Symbol.Set.empty - t - - let code_being_defined t = - List.fold_left (fun code_being_defined (S (bound_syms, _static_part)) -> - Code_id.Set.union (Bound_symbols.code_being_defined bound_syms) - code_being_defined) - Code_id.Set.empty - t - - let free_names t = - List.fold_left (fun free_names (S (_bound_syms, static_part)) -> - Name_occurrences.union free_names - (Static_part.free_names static_part)) - Name_occurrences.empty - t - - let delete_bindings t ~free_names_after code_age_relation = - let rec delete t ~free_names_after ~result = - match t with - | [] -> result - | ((S (bound_syms, static_part)) as part)::t -> - let symbols_after = Name_occurrences.symbols free_names_after in - let can_delete_symbols = - Symbol.Set.is_empty ( - Symbol.Set.inter (Bound_symbols.being_defined bound_syms) - symbols_after) - in - let code_ids_being_defined = - Bound_symbols.code_being_defined bound_syms - in - let code_ids_after = Name_occurrences.code_ids free_names_after in - let code_unused = - Code_id.Set.is_empty - (Code_id.Set.inter code_ids_being_defined code_ids_after) - in - let can_delete_code = - code_unused - && - Code_id.Set.for_all (fun code_id -> - Code_age_relation.newer_versions_form_linear_chain - code_age_relation code_id) - code_ids_being_defined - in - let free_names_after = - Name_occurrences.union free_names_after - (Static_part.free_names static_part) - in - if can_delete_code && can_delete_symbols then - delete t ~free_names_after ~result - else - delete t ~free_names_after ~result:(part :: result) - in - delete (List.rev t) ~free_names_after ~result:[] - - let iter_static_parts t (iter : static_part_iterator) = - List.iter (fun (S (_bound_syms, static_part)) -> - iter.f static_part) - t - - let map_static_parts t (mapper : static_part_mapper) = - List.map (fun (S (bound_syms, static_part)) -> - S (bound_syms, mapper.f static_part)) - t - - let get_pieces_of_code t = - let code = - List.fold_left (fun code (S (_bound_syms, static_part)) -> - Code_id.Map.disjoint_union code - (Static_part.get_pieces_of_code static_part)) - Code_id.Map.empty - t - in - assert (Code_id.Set.equal (Code_id.Map.keys code) - (code_being_defined t)); - code - - let pieces_of_code ?newer_versions_of ?set_of_closures code = - let newer_versions_of = - Option.value newer_versions_of ~default:Code_id.Map.empty - in - let code = - Code_id.Map.mapi (fun id params_and_body : Static_part.code -> - let newer_version_of = - Code_id.Map.find_opt id newer_versions_of - in - { params_and_body = Present params_and_body; - newer_version_of; - }) - code - in - let static_part : K.fabricated Static_part.t = - let set_of_closures = Option.map snd set_of_closures in - Code_and_set_of_closures { - code; - set_of_closures; - } - in - let bound_symbols : K.fabricated Bound_symbols.t = - let closure_symbols = - Option.value (Option.map fst set_of_closures) - ~default:Closure_id.Map.empty - in - Code_and_set_of_closures { - code_ids = Code_id.Map.keys code; - closure_symbols; - } - in - S (bound_symbols, static_part) - end - - module Definition = struct - type t = { - computation : Computation.t option; - static_structure : Static_structure.t; - } - - let print_with_cache ~cache ppf { computation; static_structure; } = - Format.fprintf ppf "@[(\ - @[@<0>%s(computation@ %a)@<0>%s@]@ \ - @[(%a)@]\ - )@]" - (if Option.is_none computation then Flambda_colours.elide () - else Flambda_colours.normal ()) - (Misc.Stdlib.Option.print Computation.print) computation - (Flambda_colours.normal ()) - (Static_structure.print_with_cache ~cache) static_structure - - let print ppf t = - print_with_cache ~cache:(Printing_cache.create ()) ppf t - - let free_names t = - let free_in_computation = - match t.computation with - | None -> Name_occurrences.empty - | Some computation -> Computation.free_names computation - in - let free_in_static_structure = - Static_structure.free_names t.static_structure - in - Name_occurrences.union free_in_computation free_in_static_structure - - let static_structure t = t.static_structure - - let singleton_symbol symbol static_part = - { computation = None; - static_structure = [S (Singleton symbol, static_part)]; - } - - let pieces_of_code ?newer_versions_of code = - let static_structure_part : Static_structure.t0 = - Static_structure.pieces_of_code ?newer_versions_of code - in - { computation = None; - static_structure = [static_structure_part]; - } - - let iter_computation t ~f = - match t.computation with - | None -> () - | Some computation -> f computation - - let map_computation t ~f = - { t with - computation = Option.map f t.computation; - } - - let only_generative_effects t = - (* CR-someday mshinwell: Could do a proper effects check. *) - Option.is_none t.computation - - let iter_static_parts t iter = - Static_structure.iter_static_parts t.static_structure iter - - let map_static_parts t mapper = - { t with - static_structure = - Static_structure.map_static_parts t.static_structure mapper; - } - - let being_defined t = Static_structure.being_defined t.static_structure - - let code_being_defined t = - Static_structure.code_being_defined t.static_structure - - let get_pieces_of_code t = - Static_structure.get_pieces_of_code t.static_structure - - let delete_bindings t ~free_names_after code_age_relation = - let static_structure = - Static_structure.delete_bindings t.static_structure ~free_names_after - code_age_relation - in - { computation = t.computation; - static_structure; - } - end - - type t = - | Definition of { - free_names : Name_occurrences.t; - defn : Definition.t; - body : t; - } - | Root of Symbol.t - - let rec print_with_cache ~cache ppf t = - match t with - | Definition { free_names = _; defn; body; } -> - Format.fprintf ppf "@[(@<0>%sDefinition@<0>%s@ %a)@]@;" - (Flambda_colours.static_keyword ()) - (Flambda_colours.normal ()) - (Definition.print_with_cache ~cache) defn; - print_with_cache ~cache ppf body - | Root sym -> - Format.fprintf ppf "@[(@<0>%sRoot@<0>%s %a)@]" - (Flambda_colours.static_keyword ()) - (Flambda_colours.normal ()) - Symbol.print sym - - let print ppf t = - print_with_cache ~cache:(Printing_cache.create ()) ppf t - - let _invariant _env _t = () - - let free_names t = - match t with - | Definition { free_names; _ } -> free_names - | Root sym -> Name_occurrences.singleton_symbol sym Name_mode.normal - - let used_closure_vars t = - match t with - | Definition { free_names; _ } -> - Name_occurrences.closure_vars free_names - | Root _ -> Var_within_closure.Set.empty - - let define_symbol defn ~body code_age_relation = - let free_names_of_body = free_names body in - let defn = - Definition.delete_bindings defn ~free_names_after:free_names_of_body - code_age_relation - in - let can_delete = - Definition.only_generative_effects defn - && Static_structure.is_empty (Definition.static_structure defn) - in - if can_delete then body - else - let free_names = - Name_occurrences.union (Definition.free_names defn) - free_names_of_body - in - Definition { free_names; defn; body; } - - let root sym = Root sym - - let rec iter_definitions t ~f = - match t with - | Definition { defn; body; _ } -> - f defn; - iter_definitions body ~f - | Root _ -> () - - type descr = - | Definition of Definition.t * t - | Root of Symbol.t - - let descr (t : t) : descr = - match t with - | Definition { defn; body; free_names = _; } -> - Definition (defn, body) - | Root sym -> Root sym -end - -module Program = struct - type t = { - imported_symbols : K.t Symbol.Map.t; - body : Program_body.t; - } - - let print ppf t = - Format.fprintf ppf "@[(@[(imported_symbols %a)@]@ @[<1>(body@ %a)@])@]" - (Symbol.Map.print K.print) t.imported_symbols - Program_body.print t.body - - let free_names t = - (* N.B. [imported_symbols] are not treated as free. *) - Program_body.free_names t.body - - let used_closure_vars t = - Program_body.used_closure_vars t.body - - let imported_symbols t = t.imported_symbols - - let root_symbol t = - let rec loop (body : Program_body.t) = - match body with - | Definition { body; _ } -> loop body - | Root root -> root - in - loop t.body - - let invariant _t = () - - let iter_body t ~f = f t.body - - let map_body t ~f = - { t with - body = f t.body; - } -end +let used_closure_vars t = Program_body.used_closure_vars t.body diff --git a/middle_end/flambda2.0/terms/flambda_unit.mli b/middle_end/flambda2.0/terms/flambda_unit.mli index 89bb4c5f313f..b9148b53394d 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.mli +++ b/middle_end/flambda2.0/terms/flambda_unit.mli @@ -18,37 +18,31 @@ [@@@ocaml.warning "+a-30-40-41-42"] -type t = { - imported_symbols : Flambda_kind.t Symbol.Map.t; - root_symbol : Symbol.t; - exn_continuation : Continuation.t; - body : Expr.t; -} - -(** Perform well-formedness checks on the program. *) +type t + +(** Perform well-formedness checks on the unit. *) val invariant : t -> unit -(** Print a program to a formatter. *) +(** Print a unit to a formatter. *) val print : Format.formatter -> t -> unit +(** Create a unit. *) val create : imported_symbols:Flambda_kind.t Symbol.Map.t -> root_symbol:Symbol.t + -> return_continuation:Continuation.t -> exn_continuation:Continuation.t -> body:Expr.t -> t -(** All free names in the given program. Imported symbols are not treated - as free. *) -val free_names : t -> Name_occurrences.t - +(** All closure variables used in the given unit. *) val used_closure_vars : t -> Var_within_closure.Set.t -(** All symbols imported from other compilation units by the given program. *) +(** All symbols imported from other compilation units by the given unit. *) val imported_symbols : t -> Flambda_kind.t Symbol.Map.t -(** The module block symbol for the given program (the only symbol that - can never be eliminated). *) +(** The module block symbol for the given unit (the only symbol that can never + be eliminated). *) val root_symbol : t -> Symbol.t val body : t -> Expr.t From 176afb3209c1c54254c19781a90e7365a31a824b Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 15:02:33 +0000 Subject: [PATCH 12/80] terms --- middle_end/flambda2.0/basic/simple.ml | 1 + middle_end/flambda2.0/flambda2_middle_end.ml | 14 +- middle_end/flambda2.0/flambda2_middle_end.mli | 4 +- .../from_lambda/closure_conversion.ml | 4 +- .../flambda2.0/inlining/inlining_cost.ml | 2 + .../flambda2.0/parser/fexpr_to_flambda.ml | 3 + .../simplify/env/simplify_env_and_result.ml | 51 +- .../env/simplify_env_and_result_intf.ml | 8 +- .../simplify/simplify_static_const.rec.ml | 14 +- .../simplify/typing_helpers/reification.mli | 4 +- middle_end/flambda2.0/terms/expr.rec.mli | 3 +- middle_end/flambda2.0/terms/flambda.mli | 117 ++++- .../flambda2.0/terms/let_symbol_expr.rec.ml | 35 ++ .../flambda2.0/terms/let_symbol_expr.rec.mli | 8 + .../flambda2.0/terms/static_const.rec.ml | 484 ++++++++++++++++++ .../flambda2.0/terms/static_const.rec.mli | 4 + .../terms/template/flambda.templ.ml | 2 +- 17 files changed, 712 insertions(+), 46 deletions(-) create mode 100644 middle_end/flambda2.0/terms/static_const.rec.ml diff --git a/middle_end/flambda2.0/basic/simple.ml b/middle_end/flambda2.0/basic/simple.ml index e7160ee5c71c..5d6e62ada2fd 100644 --- a/middle_end/flambda2.0/basic/simple.ml +++ b/middle_end/flambda2.0/basic/simple.ml @@ -143,6 +143,7 @@ let const_int i = Const (Const.const_int i) let const_true = Const Const.const_true let const_false = Const Const.const_false +let const_unit = Const Const.const_unit let untagged_const_true = Const Const.untagged_const_true let untagged_const_false = Const Const.untagged_const_false diff --git a/middle_end/flambda2.0/flambda2_middle_end.ml b/middle_end/flambda2.0/flambda2_middle_end.ml index 89b4807badfb..852bbe2c1a3b 100644 --- a/middle_end/flambda2.0/flambda2_middle_end.ml +++ b/middle_end/flambda2.0/flambda2_middle_end.ml @@ -74,8 +74,8 @@ let print_flambda name ppf program = Flambda_static.Program.print program end -let middle_end0 ppf ~prefixname:_ ~backend ~size ~filename - ~module_ident ~module_initializer = +let middle_end0 ppf ~prefixname:_ ~backend ~filename ~module_ident + ~module_block_size_in_words ~module_initializer = Misc.Color.setup !Clflags.color; Profile.record_call "flambda2.0" (fun () -> let prepared_lambda, recursive_static_catches = @@ -104,7 +104,7 @@ let middle_end0 ppf ~prefixname:_ ~backend ~size ~filename let flambda = Profile.record_call "closure_conversion" (fun () -> Closure_conversion.ilambda_to_flambda ~backend ~module_ident - ~size ~filename ilambda) + ~module_block_size_in_words ~filename ilambda) in print_rawflambda ppf flambda; check_invariants flambda; @@ -115,11 +115,11 @@ let middle_end0 ppf ~prefixname:_ ~backend ~size ~filename print_flambda "simplify" ppf flambda; flambda) -let middle_end ~ppf_dump:ppf ~prefixname ~backend ~size ~filename ~module_ident - ~module_initializer = +let middle_end ~ppf_dump:ppf ~prefixname ~backend ~filename ~module_ident + ~module_block_size_in_words ~module_initializer = try - middle_end0 ppf ~prefixname ~backend ~size ~filename ~module_ident - ~module_initializer + middle_end0 ppf ~prefixname ~backend ~filename ~module_ident + ~module_block_size_in_words ~module_initializer with Misc.Fatal_error -> begin Format.eprintf "\n%sOriginal backtrace is:%s\n%s\n" (Flambda_colours.error ()) diff --git a/middle_end/flambda2.0/flambda2_middle_end.mli b/middle_end/flambda2.0/flambda2_middle_end.mli index bac50d0ce067..550ef92222ec 100644 --- a/middle_end/flambda2.0/flambda2_middle_end.mli +++ b/middle_end/flambda2.0/flambda2_middle_end.mli @@ -22,8 +22,8 @@ val middle_end : ppf_dump:Format.formatter -> prefixname:string -> backend:(module Flambda2_backend_intf.S) - -> size:int -> filename:string -> module_ident:Ident.t + -> module_block_size_in_words:int -> module_initializer:Lambda.lambda - -> Flambda_static.Program.t + -> Flambda_unit.t diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index 0c1571def2d9..7c916904829f 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -937,7 +937,7 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words end; let exn_continuation = ilam.exn_continuation.exn_handler in let body = - List.fold_left (fun body (code_id, params_and_body) : body.t -> + List.fold_left (fun body (code_id, params_and_body) -> let bound_symbols : Let_symbol.Bound_symbols.t = Code_and_set_of_closures { code_ids = Code_id.Set.singleton code_id; @@ -961,7 +961,7 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words t.code in let body = - List.fold_left (fun body (symbol, static_const) : body.t -> + List.fold_left (fun body (symbol, static_const) -> Let_symbol.create (Singleton symbol) static_const body |> Flambda.create_let_symbol) body diff --git a/middle_end/flambda2.0/inlining/inlining_cost.ml b/middle_end/flambda2.0/inlining/inlining_cost.ml index 0deadd383943..ace6d176caab 100644 --- a/middle_end/flambda2.0/inlining/inlining_cost.ml +++ b/middle_end/flambda2.0/inlining/inlining_cost.ml @@ -84,6 +84,8 @@ let smaller' denv expr ~than:threshold = named_size denv (Let.defining_expr let_expr); Let.pattern_match let_expr ~f:(fun ~bound_vars:_ ~body -> expr_size denv body) + | Let_symbol let_symbol_expr -> + expr_size denv (Let_symbol.body let_symbol_expr) | Let_cont (Non_recursive { handler; _ }) -> Non_recursive_let_cont_handler.pattern_match handler ~f:(fun _cont ~body -> expr_size denv body); diff --git a/middle_end/flambda2.0/parser/fexpr_to_flambda.ml b/middle_end/flambda2.0/parser/fexpr_to_flambda.ml index 30566e190279..96f85f7e7dc7 100644 --- a/middle_end/flambda2.0/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2.0/parser/fexpr_to_flambda.ml @@ -1,3 +1,4 @@ +(* Needs fixing module Program_body = Flambda_static.Program_body module Named = Flambda.Named module E = Flambda.Expr @@ -600,3 +601,5 @@ let conv ~backend fexpr : Flambda_static.Program.t = let body = conv_top ~backend init_fenv fexpr in { imported_symbols = Symbol.Map.empty; body; } +*) +let conv ~backend:_ _fexpr = assert false diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 14380a35f0ec..07ea75059591 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -37,12 +37,13 @@ end = struct float_const_prop : bool; code : Function_params_and_body.t Code_id.Map.t; at_unit_toplevel : bool; + unit_toplevel_exn_continuation : Continuation.t; } let print ppf { backend = _; round; typing_env; inlined_debuginfo; can_inline; inlining_depth_increment; float_const_prop; - code; at_unit_toplevel; + code; at_unit_toplevel; unit_toplevel_exn_continuation; } = Format.fprintf ppf "@[(\ @[(round@ %d)@]@ \ @@ -115,7 +116,8 @@ end = struct let enter_closure { backend; round; typing_env; inlined_debuginfo = _; can_inline; inlining_depth_increment = _; - float_const_prop; code; not_at_unit_toplevel = _; + float_const_prop; code; at_unit_toplevel = _; + unit_toplevel_exn_continuation; } = { backend; round; @@ -126,6 +128,7 @@ end = struct float_const_prop; code; at_unit_toplevel = false; + unit_toplevel_exn_continuation; } let define_variable t var kind = @@ -337,9 +340,10 @@ end = struct List.fold_left (fun denv lifted_constant -> let denv_at_definition = LC.denv_at_definition lifted_constant in let types_of_symbols = LC.types_of_symbols lifted_constant in - let definition = LC.definition lifted_constant in + let bound_symbols = LC.bound_symbols lifted_constant in + let defining_expr = LC.defining_expr lifted_constant in let being_defined = - Flambda_static.Program_body.Definition.being_defined definition + Let_symbol.Bound_symbols.being_defined bound_symbols in let already_bound = Symbol.Set.filter (fun sym -> mem_symbol denv sym) @@ -379,8 +383,7 @@ end = struct (fun code_id (params_and_body, newer_version_of) denv -> if mem_code denv code_id then denv else define_code denv ?newer_version_of ~code_id ~params_and_body) - (Flambda_static.Program_body.Definition.get_pieces_of_code - definition) + (Static_const.get_pieces_of_code defining_expr) (with_typing_env denv typing_env)) t (List.rev lifted) @@ -628,37 +631,46 @@ end and Lifted_constant : sig include Simplify_env_and_result_intf.Lifted_constant with type downwards_env := Downwards_env.t end = struct - module Definition = Flambda_static.Program_body.Definition - type t = { denv : Downwards_env.t; - definition : Definition.t; + bound_symbols : Let_symbol.Bound_symbols.t; + defining_expr : Static_const.t; types_of_symbols : Flambda_type.t Symbol.Map.t; } - let print ppf { denv = _ ; definition; types_of_symbols = _; } = + let print ppf + { denv = _ ; bound_symbols; defining_expr; types_of_symbols = _; } = Format.fprintf ppf "@[(\ - @[(definition@ %a)@]\ + @[(bound_symbols@ %a)@]\ + @[(static_const@ %a)@]\ )@]" - Definition.print definition + Let_symbol.Bound_symbols.print bound_symbols + Static_const.print defining_expr - let create denv definition ~types_of_symbols = - let being_defined = Definition.being_defined definition in + let create denv bound_symbols defining_expr ~types_of_symbols = + let being_defined = Let_symbol.Bound_symbols.being_defined bound_symbols in if not (Symbol.Set.subset (Symbol.Map.keys types_of_symbols) being_defined) then begin Misc.fatal_errorf "[types_of_symbols]:@ %a@ does not cover all symbols \ - in the [Definition]:@ %a" + in the definition:@ %a" (Symbol.Map.print T.print) types_of_symbols - Definition.print definition + Let_symbol.Bound_symbols.print bound_symbols end; + (* CR mshinwell: This should check that [defining_expr] matches + [bound_symbols] in the code/set-of-closures case *) { denv; - definition; + bound_symbols; + defining_expr; types_of_symbols; } let create_pieces_of_code denv ?newer_versions_of code = + let bound_symbols, defining_expr = + Let_symbol.pieces_of_code ?newer_versions_of code + in { denv; - definition = Definition.pieces_of_code ?newer_versions_of code; + bound_symbols; + defining_expr; types_of_symbols = Symbol.Map.empty; } @@ -672,6 +684,7 @@ end = struct (Code_id.Map.singleton code_id params_and_body) let denv_at_definition t = t.denv - let definition t = t.definition + let bound_symbols t = t.bound_symbols + let defining_expr t = t.defining_expr let types_of_symbols t = t.types_of_symbols end diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index 4d8b0d564258..2d140ac60b4c 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -48,7 +48,7 @@ module type Downwards_env = sig val at_unit_toplevel : t -> bool - val set_not_at_unit_toplevel : t -> bool + val set_not_at_unit_toplevel : t -> t val unit_toplevel_exn_continuation : t -> Continuation.t @@ -281,7 +281,8 @@ module type Lifted_constant = sig (** [create] takes the types of symbols to avoid re-inferring them. *) val create : downwards_env - -> Flambda_static.Program_body.Definition.t + -> Flambda.Let_symbol_expr.Bound_symbols.t + -> Flambda.Static_const.t -> types_of_symbols:Flambda_type.t Symbol.Map.t -> t @@ -299,6 +300,7 @@ module type Lifted_constant = sig -> t val denv_at_definition : t -> downwards_env - val definition : t -> Flambda_static.Program_body.Definition.t + val bound_symbols : t -> Flambda.Let_symbol_expr.Bound_symbols.t + val defining_expr : t -> Flambda.Static_const.t val types_of_symbols : t -> Flambda_type.t Symbol.Map.t end diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index d492c5947c73..f6d736614d2e 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -48,7 +48,7 @@ let simplify_field_of_block dacc (of_kind_value : Field_of_block.t) = of_kind_value, ty let simplify_or_variable dacc type_for_const - (or_variable : _ static_const.or_variable) = + (or_variable : _ Static_const.or_variable) = let denv = DA.denv dacc in match or_variable with | Const const -> or_variable, type_for_const const @@ -74,19 +74,19 @@ let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols in let static_structure : Program_body.Static_structure.t = let code = - Code_id.Map.mapi (fun code_id params_and_body : static_const.code -> + Code_id.Map.mapi (fun code_id params_and_body : Static_const.code -> { params_and_body = Present params_and_body; newer_version_of = Code_id.Map.find_opt code_id newer_versions_of; }) code in - let static_const : K.fabricated static_const.t = + let static_const : Static_const.t = Code_and_set_of_closures { code; set_of_closures = Some set_of_closures; } in - let bound_symbols : K.fabricated Program_body.Bound_symbols.t = + let bound_symbols : Program_body.Bound_symbols.t = Code_and_set_of_closures { code_ids = Code_id.Map.keys code; closure_symbols; @@ -177,7 +177,7 @@ let simplify_static_const_of_kind_value dacc Immutable_float_array fields, dacc | Mutable_string { initial_value; } -> let str_ty = T.mutable_string ~size:(String.length initial_value) in - let static_const : K.value static_const.t = + let static_const : Static_const.t = Mutable_string { initial_value; } @@ -196,6 +196,7 @@ let simplify_static_const_of_kind_value dacc let simplify_static_const_of_kind_fabricated dacc (static_const : Static_const.t) ~result_sym : Static_const.t * DA.t = + match static_const with | Code_and_set_of_closures { code; set_of_closures; } -> let code_ids' = Code_id.Map.keys code in if not (Code_id.Set.equal code_ids code_ids') then begin @@ -206,7 +207,8 @@ let simplify_static_const_of_kind_fabricated dacc end; let dacc = Code_id.Map.fold - (fun code_id ({ params_and_body; newer_version_of; } : static_const.code) + (fun code_id + ({ params_and_body; newer_version_of; } : Static_const.code) dacc -> (* CR mshinwell: Add invariant check to ensure there are no unbound names in the code, since we're not simplifying on the diff --git a/middle_end/flambda2.0/simplify/typing_helpers/reification.mli b/middle_end/flambda2.0/simplify/typing_helpers/reification.mli index 181299014f1c..1148542fcaa9 100644 --- a/middle_end/flambda2.0/simplify/typing_helpers/reification.mli +++ b/middle_end/flambda2.0/simplify/typing_helpers/reification.mli @@ -18,9 +18,7 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -val create_static_part - : Flambda_type.to_lift - -> Flambda_kind.value Flambda_static.Static_part.t +val create_static_const : Flambda_type.to_lift -> Flambda.Static_const.t val try_to_reify : Downwards_acc.t diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index 86993fc6ca12..949eca85c2dd 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -29,7 +29,8 @@ type descr = private signal handlers as a result of reaching a safe point). *) | Let_symbol of Let_symbol.t (** Bind code and/or data symbol(s). This form of expression is only - allowed in certain "toplevel" contexts. *) + allowed in certain "toplevel" contexts. The bound symbols are not + treated up to alpha conversion. *) | Let_cont of Let_cont_expr.t (** Define one or more continuations. *) | Apply of Apply.t diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index c63d1898862e..fc3fe89d96b0 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -35,7 +35,8 @@ module Switch = Switch_expr application for an inlined body (unlike in ANF form). *) module rec Expr : sig - (** The type of alpha-equivalence classes of expressions. *) + (** The type of equivalence classes of expressions up to alpha-renaming of + bound [Variable]s and [Continuation]s. *) type t (** Printing, invariant checks, name manipulation, etc. *) @@ -46,6 +47,10 @@ module rec Expr : sig (** Bind a variable. There can be no effect on control flow (save for asynchronous operations such as the invocation of finalisers or signal handlers as a result of reaching a safe point). *) + | Let_symbol of Let_symbol_expr.t + (** Bind code and/or data symbol(s). This form of expression is only + allowed in certain "toplevel" contexts. The bound symbols are not + treated up to alpha conversion. *) | Let_cont of Let_cont_expr.t (** Define one or more continuations. *) | Apply of Apply.t @@ -200,6 +205,47 @@ end and Let_expr : sig : t -> f:(bound_vars:Bindable_let_bound.t -> body:Expr.t -> 'a) -> 'a +end and Let_symbol_expr : sig + module Bound_symbols : sig + type t = + | Singleton : Symbol.t -> t + (** A binding of a single symbol of kind [Value]. *) + | Code_and_set_of_closures of { + code_ids : Code_id.Set.t; + closure_symbols : Symbol.t Closure_id.Map.t; + } + (** A recursive binding of possibly multiple symbols to the individual + closures within a set of closures; and/or bindings of code to + code IDs. *) + + val being_defined : t -> Symbol.Set.t + + val code_being_defined : t -> Code_id.Set.t + + val closure_symbols_being_defined : t -> Symbol.Set.t + + include Expr_std.S with type t := t + end + + type t + + val create : Bound_symbols.t -> Static_const.t -> Expr.t -> t + + val bound_symbols : t -> Bound_symbols.t + + val defining_expr : t -> Static_const.t + + val body : t -> Expr.t + + include Expr_std.S with type t := t + + (** If [newer_versions_of] maps [id1] to [id2] then [id1] is a newer + version of [id2]. *) + val pieces_of_code + : ?newer_versions_of:Code_id.t Code_id.Map.t + -> ?set_of_closures:(Symbol.t Closure_id.Map.t * Set_of_closures.t) + -> Function_params_and_body.t Code_id.Map.t + -> Bound_symbols.t * Static_const.t end and Let_cont_expr : sig (** Values of type [t] represent alpha-equivalence classes of the definitions of continuations: @@ -422,13 +468,79 @@ end and Function_params_and_body : sig -> my_closure:Variable.t -> 'a) -> 'a +end and Static_const : sig + (** Language terms that represent statically-allocated values. *) + + module Field_of_block : sig + (** Inhabitants (of kind [Value]) of fields of statically-allocated + blocks. *) + type t = + | Symbol of Symbol.t + (** The address of the given symbol. *) + | Tagged_immediate of Immediate.t + (** The given tagged immediate. *) + | Dynamically_computed of Variable.t + (** The value of the given variable. *) + + (** Printing, total ordering, etc. *) + include Identifiable.S with type t := t + end + + type 'a or_variable = + | Const of 'a + | Var of Variable.t + + (** The mutability status of a block field. *) + type mutable_or_immutable = Mutable | Immutable + + (** A piece of code, comprising of the parameters and body of a function, + together with a field indicating whether the piece of code is a newer + version of one that existed previously (and may still exist), for + example after a round of simplification. *) + type code = { + params_and_body : Function_params_and_body.t or_deleted; + newer_version_of : Code_id.t option; + } + and 'a or_deleted = + | Present of 'a + | Deleted + + (** The possibly-recursive declaration of pieces of code and any associated + set of closures. *) + type code_and_set_of_closures = { + code : code Code_id.Map.t; + (* CR mshinwell: Check the free names of the set of closures *) + set_of_closures : Set_of_closures.t option; + } + + (** The static structure of a symbol, possibly with holes, ready to be filled + with values computed at runtime. *) + type t = + | Block of Tag.Scannable.t * mutable_or_immutable * (Field_of_block.t list) + | Fabricated_block of Variable.t + | Code_and_set_of_closures of code_and_set_of_closures + | Boxed_float of Numbers.Float_by_bit_pattern.t or_variable + | Boxed_int32 of Int32.t or_variable + | Boxed_int64 of Int64.t or_variable + | Boxed_nativeint of Targetint.t or_variable + | Immutable_float_array of Numbers.Float_by_bit_pattern.t or_variable list + | Mutable_string of { initial_value : string; } + | Immutable_string of string + + (** Print a static structure definition to a formatter. *) + val print : Format.formatter -> t -> unit + + include Contains_names.S with type t := t + + val get_pieces_of_code + : t + -> (Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t end module Function_declaration = Function_declaration module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr -module Let_symbol = Let_symbol_expr module Set_of_closures = Set_of_closures (** The idea is that you should typically do "open! Flambda" at the top of @@ -450,5 +562,6 @@ module Import : sig module Non_recursive_let_cont_handler = Non_recursive_let_cont_handler module Recursive_let_cont_handlers = Recursive_let_cont_handlers module Set_of_closures = Set_of_closures + module Static_const = Static_const module Switch = Switch end diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 2448d931bce7..985f316ed67d 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -151,3 +151,38 @@ let apply_name_permutation ({ bound_symbols; defining_expr; body; } as t) perm = defining_expr; body; } + +(* CR mshinwell: Add a type to just encapsulate bound_symbols and + defining_expr. *) +let pieces_of_code ?newer_versions_of ?set_of_closures code = + let newer_versions_of = + Option.value newer_versions_of ~default:Code_id.Map.empty + in + let code = + Code_id.Map.mapi (fun id params_and_body : Static_const.code -> + let newer_version_of = + Code_id.Map.find_opt id newer_versions_of + in + { params_and_body = Present params_and_body; + newer_version_of; + }) + code + in + let static_part : Static_const.t = + let set_of_closures = Option.map snd set_of_closures in + Code_and_set_of_closures { + code; + set_of_closures; + } + in + let bound_symbols : Bound_symbols.t = + let closure_symbols = + Option.value (Option.map fst set_of_closures) + ~default:Closure_id.Map.empty + in + Code_and_set_of_closures { + code_ids = Code_id.Map.keys code; + closure_symbols; + } + in + bound_symbols, static_const diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli index 9e827d0da7c5..f3f010662c57 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli @@ -49,3 +49,11 @@ val defining_expr : t -> Static_const.t val body : t -> Expr.t include Expr_std.S with type t := t + +(** If [newer_versions_of] maps [id1] to [id2] then [id1] is a newer + version of [id2]. *) +val pieces_of_code + : ?newer_versions_of:Code_id.t Code_id.Map.t + -> ?set_of_closures:(Symbol.t Closure_id.Map.t * Set_of_closures.t) + -> Function_params_and_body.t Code_id.Map.t + -> Bound_symbols.t * Static_const.t diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml new file mode 100644 index 000000000000..e244d182d8ca --- /dev/null +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -0,0 +1,484 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 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-30-40-41-42"] + +let fprintf = Format.fprintf + +module K = Flambda_kind + +module Field_of_block = struct + type t = + | Symbol of Symbol.t + | Tagged_immediate of Immediate.t + | Dynamically_computed of Variable.t + + include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + match t1, t2 with + | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 + | Tagged_immediate t1, Tagged_immediate t2 -> + Immediate.compare t1 t2 + | Dynamically_computed v1, Dynamically_computed v2 -> + Variable.compare v1 v2 + | Symbol _, Tagged_immediate _ -> -1 + | Tagged_immediate _, Symbol _ -> 1 + | Symbol _, Dynamically_computed _ -> -1 + | Dynamically_computed _, Symbol _ -> 1 + | Tagged_immediate _, Dynamically_computed _ -> -1 + | Dynamically_computed _, Tagged_immediate _ -> 1 + + let equal t1 t2 = + compare t1 t2 = 0 + + let hash t = + match t with + | Symbol symbol -> Hashtbl.hash (0, Symbol.hash symbol) + | Tagged_immediate immediate -> + Hashtbl.hash (1, Immediate.hash immediate) + | Dynamically_computed var -> Hashtbl.hash (2, Variable.hash var) + + let print ppf t = + match t with + | Symbol symbol -> Symbol.print ppf symbol + | Tagged_immediate immediate -> Immediate.print ppf immediate + | Dynamically_computed var -> Variable.print ppf var + + let output chan t = + print (Format.formatter_of_out_channel chan) t + end) + + let apply_name_permutation t perm = + match t with + | Symbol _ | Tagged_immediate _ -> t + | Dynamically_computed var -> + let var' = Name_permutation.apply_variable perm var in + if var == var' then t + else Dynamically_computed var' + + let free_names t = + match t with + | Dynamically_computed var -> + Name_occurrences.singleton_variable var Name_mode.normal + | Symbol sym -> + Name_occurrences.singleton_symbol sym Name_mode.normal + | Tagged_immediate _ -> Name_occurrences.empty + +(* + let invariant env t = + let module E = Invariant_env in + match t with + | Symbol sym -> E.check_symbol_is_bound env sym + | Tagged_immediate _ -> () + | Dynamically_computed var -> + E.check_variable_is_bound_and_of_kind env var K.value +*) +end + +module Static_part = struct +type 'a or_variable = + | Const of 'a + | Var of Variable.t + +type mutable_or_immutable = Mutable | Immutable + +type code = { + params_and_body : Flambda.Function_params_and_body.t or_deleted; + newer_version_of : Code_id.t option; +} +and 'a or_deleted = + | Present of 'a + | Deleted + +type code_and_set_of_closures = { + code : code Code_id.Map.t; + set_of_closures : Flambda.Set_of_closures.t option; +} + +type t = + | Block of Tag.Scannable.t * mutable_or_immutable * (Field_of_block.t list) + | Fabricated_block of Variable.t + | Code_and_set_of_closures of code_and_set_of_closures + | Boxed_float of Numbers.Float_by_bit_pattern.t or_variable + | Boxed_int32 of Int32.t or_variable + | Boxed_int64 of Int64.t or_variable + | Boxed_nativeint of Targetint.t or_variable + | Immutable_float_array of Numbers.Float_by_bit_pattern.t or_variable list + | Mutable_string of { initial_value : string; } + | Immutable_string of string + +let get_pieces_of_code t = + match t with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + Code_id.Map.filter_map code + ~f:(fun _code_id { params_and_body; newer_version_of; } -> + match params_and_body with + | Present params_and_body -> Some (params_and_body, newer_version_of) + | Deleted -> None) + | Block _ + | Fabricated_block _ + | Boxed_float _ + | Boxed_int32 _ + | Boxed_int64 _ + | Boxed_nativeint _ + | Immutable_float_array _ + | Mutable_string _ + | Immutable_string _ -> Code_id.Map.empty + +let free_names t = + match t with + | Block (_tag, _mut, fields) -> + List.fold_left (fun fvs field -> + Name_occurrences.union fvs (Field_of_block.free_names field)) + (Name_occurrences.empty) + fields + | Fabricated_block v -> + Name_occurrences.singleton_variable v Name_mode.normal + | Code_and_set_of_closures { code; set_of_closures; } -> + let from_set_of_closures = + match set_of_closures with + | None -> Name_occurrences.empty + | Some set -> Flambda.Set_of_closures.free_names set + in + Code_id.Map.fold + (fun code_id { params_and_body; newer_version_of; } free_names -> + let from_newer_version_of = + match newer_version_of with + | None -> Name_occurrences.empty + | Some older -> + Name_occurrences.add_newer_version_of_code_id + Name_occurrences.empty older Name_mode.normal + in + let from_params_and_body = + match params_and_body with + | Deleted -> Name_occurrences.empty + | Present params_and_body -> + Flambda.Function_params_and_body.free_names params_and_body + in + Name_occurrences.union_list [ + (Name_occurrences.add_code_id Name_occurrences.empty + code_id Name_mode.normal); + from_params_and_body; + from_newer_version_of; + free_names; + ]) + code + from_set_of_closures + | Boxed_float (Var v) + | Boxed_int32 (Var v) + | Boxed_int64 (Var v) + | Boxed_nativeint (Var v) + | Mutable_string { initial_value = Var v; } + | Immutable_string (Var v) -> + Name_occurrences.singleton_variable v Name_mode.normal + | Boxed_float (Const _) + | Boxed_int32 (Const _) + | Boxed_int64 (Const _) + | Boxed_nativeint (Const _) + | Mutable_string { initial_value = Const _; } + | Immutable_string (Const _) -> Name_occurrences.empty + | Immutable_float_array fields -> + List.fold_left (fun fns (field : _ or_variable) -> + match field with + | Var v -> + Name_occurrences.add_variable fns v Name_mode.normal + | Const _ -> fns) + (Name_occurrences.empty) + fields + +let print_params_and_body_with_cache ~cache ppf params_and_body = + match params_and_body with + | Deleted -> Format.fprintf ppf "@[(params_and_body@ Deleted)@]" + | Present params_and_body -> + Flambda.Function_params_and_body.print_with_cache ~cache ppf + params_and_body + +let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = + (* CR mshinwell: elide "newer_version_of" when None *) + Format.fprintf ppf "@[(\ + @[(newer_version_of@ %a)@]@ \ + %a\ + )@]" + (Misc.Stdlib.Option.print Code_id.print) newer_version_of + (print_params_and_body_with_cache ~cache) params_and_body + +let print_with_cache ~cache ppf t = + let print_float_array_field ppf = function + | Const f -> fprintf ppf "%a" Numbers.Float_by_bit_pattern.print f + | Var v -> Variable.print ppf v + in + match t with + | Block (tag, mut, fields) -> + fprintf ppf "@[(@<0>%s%sblock@<0>%s (tag %a) (%a))@]" + (Flambda_colours.static_part ()) + (match mut with Immutable -> "Immutable_" | Mutable -> "Mutable_") + (Flambda_colours.normal ()) + Tag.Scannable.print tag + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Field_of_block.print) fields + | Fabricated_block field -> + fprintf ppf "@[@<0>%sFabricated_block@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print field + | Code_and_set_of_closures { code; set_of_closures; } -> + fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ + @[(code@ (%a))@]@ \ + @[(set_of_closures@ (%a))@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Code_id.Map.print (print_code_with_cache ~cache)) code + (Misc.Stdlib.Option.print + (Flambda.Set_of_closures.print_with_cache ~cache)) + set_of_closures + | Boxed_float (Const f) -> + fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Numbers.Float_by_bit_pattern.print f + | Boxed_float (Var v) -> + fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Boxed_int32 (Const n) -> + fprintf ppf "@[@<0>%sBoxed_int32@<0>%s %ld)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + n + | Boxed_int32 (Var v) -> + fprintf ppf "@[@<0>%sBoxed_int32@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Boxed_int64 (Const n) -> + fprintf ppf "@[@<0>%sBoxed_int64@<0>%s %Ld)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + n + | Boxed_int64 (Var v) -> + fprintf ppf "@[@<0>%sBoxed_int64@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Boxed_nativeint (Const n) -> + fprintf ppf "@[@<0>%sBoxed_nativeint@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Targetint.print n + | Boxed_nativeint (Var v) -> + fprintf ppf "@[@<0>%sBoxed_nativeint@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Immutable_float_array fields -> + fprintf ppf "@[@<0>%sImmutable_float_array@<0>%s@ @[[| %a |]@])@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") + print_float_array_field) + fields + | Mutable_string { initial_value = Const s; } -> + fprintf ppf "@[@<0>%sMutable_string@<0>%s@ \"%s\")@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + s + | Mutable_string { initial_value = Var v; } -> + fprintf ppf "@[@<0>%sMutable_string@<0>%s@ %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Immutable_string (Const s) -> + fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ \"%s\")@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + s + | Immutable_string (Var v) -> + fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + +let print ppf t = + print_with_cache ~cache:(Printing_cache.create ()) ppf t + +(* +let _invariant env t = + try + let module E = Invariant_env in + match t with + | Block (_tag, _mut, fields) -> + List.iter (fun field -> Field_of_block.invariant env field) fields + | Fabricated_block field -> + E.check_variable_is_bound_and_of_kind env field K.fabricated + | Set_of_closures set -> + Flambda.Set_of_closures.invariant env set + | Boxed_float (Var v) -> + E.check_variable_is_bound_and_of_kind env v K.naked_float + | Boxed_int32 (Var v) -> + E.check_variable_is_bound_and_of_kind env v K.naked_int32 + | Boxed_int64 (Var v) -> + E.check_variable_is_bound_and_of_kind env v K.naked_int64 + | Boxed_nativeint (Var v) -> + E.check_variable_is_bound_and_of_kind env v K.naked_nativeint + | Mutable_string { initial_value = Var v; } + | Immutable_string (Var v) -> + E.check_variable_is_bound_and_of_kind env v K.value + | Boxed_float (Const _) + | Boxed_int32 (Const _) + | Boxed_int64 (Const _) + | Boxed_nativeint (Const _) + | Mutable_string { initial_value = Const _; } + | Immutable_string (Const _) -> () + | Immutable_float_array fields -> + List.iter (fun (field : _ or_variable) -> + match field with + | Var v -> + E.check_variable_is_bound_and_of_kind env v + K.naked_float + | Const _ -> ()) + fields + with Misc.Fatal_error -> + Misc.fatal_errorf "(during invariant checks) Context is:@ %a" print t +*) + +let apply_name_permutation t perm = + if Name_permutation.is_empty perm then t + else + match t with + | Block (tag, mut, fields) -> + let changed = ref false in + let fields = + List.map (fun field -> + let field' = Field_of_block.apply_name_permutation field perm in + if not (field == field') then begin + changed := true + end; + field') + fields + in + if not !changed then t + else Block (tag, mut, fields) + | Fabricated_block _ -> Misc.fatal_error "To be removed" + | Code_and_set_of_closures { code; set_of_closures; } -> + let code' = + Code_id.Map.map_sharing + (fun ({ params_and_body; newer_version_of; } as code) -> + let params_and_body' = + match params_and_body with + | Deleted -> Deleted + | Present params_and_body_inner -> + let params_and_body_inner' = + Flambda.Function_params_and_body.apply_name_permutation + params_and_body_inner perm + in + if params_and_body_inner == params_and_body_inner' then + params_and_body + else + Present params_and_body_inner' + in + if params_and_body == params_and_body' then code + else + { params_and_body = params_and_body'; + newer_version_of; + }) + code + in + let set_of_closures' = + match set_of_closures with + | None -> None + | Some set -> + let set' = + Flambda.Set_of_closures.apply_name_permutation set perm + in + if set == set' then set_of_closures + else Some set' + in + if code == code' && set_of_closures == set_of_closures' then t + else + Code_and_set_of_closures { + code = code'; + set_of_closures = set_of_closures'; + } + | Boxed_float (Var v) -> + let v' = Name_permutation.apply_variable perm v in + if v == v' then t + else Boxed_float (Var v') + | Boxed_int32 (Var v) -> + let v' = Name_permutation.apply_variable perm v in + if v == v' then t + else Boxed_int32 (Var v') + | Boxed_int64 (Var v) -> + let v' = Name_permutation.apply_variable perm v in + if v == v' then t + else Boxed_int64 (Var v') + | Boxed_nativeint (Var v) -> + let v' = Name_permutation.apply_variable perm v in + if v == v' then t + else Boxed_nativeint (Var v') + | Mutable_string { initial_value = Var v; } -> + let v' = Name_permutation.apply_variable perm v in + if v == v' then t + else Mutable_string { initial_value = Var v'; } + | Immutable_string (Var v) -> + let v' = Name_permutation.apply_variable perm v in + if v == v' then t + else Immutable_string (Var v') + | Boxed_float (Const _) + | Boxed_int32 (Const _) + | Boxed_int64 (Const _) + | Boxed_nativeint (Const _) + | Mutable_string { initial_value = Const _; } + | Immutable_string (Const _) -> t + | Immutable_float_array fields -> + let changed = ref false in + let fields = + List.map (fun (field : _ or_variable) -> + let field' : _ or_variable = + match field with + | Var v -> Var (Name_permutation.apply_variable perm v) + | Const _ -> field + in + if not (field == field') then begin + changed := true + end; + field') + fields + in + if not !changed then t + else Immutable_float_array fields + +let get_pieces_of_code t = + match t with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + Code_id.Map.filter_map code + ~f:(fun _code_id { params_and_body; newer_version_of; } -> + match params_and_body with + | Present params_and_body -> Some (params_and_body, newer_version_of) + | Deleted -> None) + | Block _ + | Fabricated_block _ + | Boxed_float _ + | Boxed_int32 _ + | Boxed_int64 _ + | Boxed_nativeint _ + | Immutable_float_array _ + | Mutable_string _ + | Immutable_string _ -> Code_id.Map.empty diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index e5ec603ff7e9..7246779d4c88 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -75,3 +75,7 @@ type t = val print : Format.formatter -> t -> unit include Contains_names.S with type t := t + +val get_pieces_of_code + : t + -> (Flambda.Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t diff --git a/middle_end/flambda2.0/terms/template/flambda.templ.ml b/middle_end/flambda2.0/terms/template/flambda.templ.ml index b1f4cffc95b6..0bbce84cd4a9 100644 --- a/middle_end/flambda2.0/terms/template/flambda.templ.ml +++ b/middle_end/flambda2.0/terms/template/flambda.templ.ml @@ -43,7 +43,6 @@ module Function_declaration = Function_declaration module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr -module Let_symbol = Let_symbol_expr module Set_of_closures = Set_of_closures module Import = struct @@ -63,5 +62,6 @@ module Import = struct module Non_recursive_let_cont_handler = Non_recursive_let_cont_handler module Recursive_let_cont_handlers = Recursive_let_cont_handlers module Set_of_closures = Set_of_closures + module Static_const = Static_const module Switch = Switch end From 35dfe82e98f1fa55bf80b12eba1e32f755cee869 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 15:09:15 +0000 Subject: [PATCH 13/80] terms --- .../from_lambda/closure_conversion.ml | 45 ++++++++----------- middle_end/flambda2.0/parser/parse_ilambda.ml | 14 +++--- middle_end/flambda2.0/terms/flambda.mli | 2 + middle_end/flambda2.0/terms/flambda_unit.ml | 26 ++++++++--- middle_end/flambda2.0/terms/flambda_unit.mli | 4 +- 5 files changed, 50 insertions(+), 41 deletions(-) diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index 7c916904829f..34d72ad62bf1 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -23,13 +23,11 @@ module Expr = Flambda.Expr module Function_decls = Closure_conversion_aux.Function_decls module Function_decl = Function_decls.Function_decl module Function_params_and_body = Flambda.Function_params_and_body -module Let_symbol = Flambda.Let_symbol +module Let_symbol = Flambda.Let_symbol_expr module Named = Flambda.Named -module Program_body = Flambda_static.Program_body -module Static_part = Flambda_static.Static_part +module Static_const = Flambda.Static_const module K = Flambda_kind -module KP = Kinded_parameter module LC = Lambda_conversions module P = Flambda_primitive module VB = Var_in_binding_pos @@ -41,7 +39,7 @@ type t = { filename : string; mutable imported_symbols : Symbol.Set.t; (* All symbols in [imported_symbols] are to be of kind [Value]. *) - mutable declared_symbols : (Symbol.t * K.value Static_part.t) list; + mutable declared_symbols : (Symbol.t * Static_const.t) list; mutable code : (Code_id.t * Function_params_and_body.t) list; } @@ -149,7 +147,7 @@ let tupled_function_call_stub in func_decl, code_id, params_and_body -let register_const0 t (constant : K.value Static_part.t) name = +let register_const0 t constant name = let current_compilation_unit = Compilation_unit.get_current_exn () in (* Create a variable to ensure uniqueness of the symbol. *) let var = Variable.create ~current_compilation_unit name in @@ -161,15 +159,15 @@ let register_const0 t (constant : K.value Static_part.t) name = t.declared_symbols <- (symbol, constant) :: t.declared_symbols; symbol -let register_const t constant name : Flambda_static.Of_kind_value.t * string = +let register_const t constant name : Static_const.Field_of_block.t * string = let symbol = register_const0 t constant name in Symbol symbol, name let register_const_string t str = - register_const0 t (Static_part.Immutable_string (Const str)) "string" + register_const0 t (Static_const.Immutable_string str) "string" let rec declare_const t (const : Lambda.structured_constant) - : Flambda_static.Of_kind_value.t * string = + : Static_const.Field_of_block.t * string = match const with | Const_base (Const_int c) -> Tagged_immediate (Immediate.int (Targetint.OCaml.of_int c)), "int" @@ -180,9 +178,9 @@ let rec declare_const t (const : Lambda.structured_constant) | Const_base (Const_string (s, _)) -> let const, name = if Config.safe_string then - Static_part.Immutable_string (Const s), "immstring" + Static_const.Immutable_string s, "immstring" else - Static_part.Mutable_string { initial_value = Const s; }, "string" + Static_const.Mutable_string { initial_value = s; }, "string" in register_const t const name | Const_base (Const_float c) -> @@ -197,17 +195,17 @@ let rec declare_const t (const : Lambda.structured_constant) let c = Targetint.of_int64 (Int64.of_nativeint c) in register_const t (Boxed_nativeint (Const c)) "nativeint" | Const_immstring c -> - register_const t (Immutable_string (Const c)) "immstring" + register_const t (Immutable_string c) "immstring" | Const_float_array c -> (* CR mshinwell: check that Const_float_array is always immutable *) register_const t (Immutable_float_array (List.map (fun s -> let f = Numbers.Float_by_bit_pattern.create (float_of_string s) in - Static_part.Const f) c)) + Static_const.Const f) c)) "float_array" | Const_block (tag, consts) -> - let const : K.value Static_part.t = + let const : Static_const.t = Block (Tag.Scannable.create_exn tag, Immutable, List.map (fun c -> fst (declare_const t c)) consts) @@ -860,11 +858,6 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words let module_block_tag = Tag.Scannable.zero in let module_block_var = Variable.create "module_block" in let return_cont = Continuation.create ~sort:Toplevel_return () in - let field_vars = - List.init module_block_size_in_words (fun pos -> - let pos_str = string_of_int pos in - Variable.create ("cv_field_" ^ pos_str), K.value) - in let load_fields_body = let field_vars = List.init module_block_size_in_words (fun pos -> @@ -874,7 +867,7 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words let body = let static_const : Static_const.t = let field_vars = - List.map (fun (var, _) : Static_const.Field_of_block.t -> + List.map (fun (_, var) : Static_const.Field_of_block.t -> Dynamically_computed var) field_vars in @@ -891,7 +884,7 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words |> Expr.create_apply_cont in Let_symbol.create (Singleton module_symbol) static_const return - |> Flambda.create_let_symbol + |> Flambda.Expr.create_let_symbol in List.fold_left (fun body (pos, var) -> let var = VB.create var Name_mode.normal in @@ -945,7 +938,7 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words } in let static_const : Static_const.t = - let code : Static_part.code = + let code : Static_const.code = { params_and_body = Present params_and_body; newer_version_of = None; } @@ -956,14 +949,14 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words } in Let_symbol.create bound_symbols static_const body - |> Flambda.create_let_symbol) + |> Flambda.Expr.create_let_symbol) body t.code in let body = List.fold_left (fun body (symbol, static_const) -> Let_symbol.create (Singleton symbol) static_const body - |> Flambda.create_let_symbol) + |> Flambda.Expr.create_let_symbol) body t.declared_symbols in @@ -979,5 +972,5 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words Backend.all_predefined_exception_symbols imported_symbols in - Flambda_unit.create ~imported_symbols ~return_continuation:return_cont - ~exn_continuation ~body + Flambda_unit.create ~imported_symbols ~root_symbol:module_symbol + ~return_continuation:return_cont ~exn_continuation ~body diff --git a/middle_end/flambda2.0/parser/parse_ilambda.ml b/middle_end/flambda2.0/parser/parse_ilambda.ml index 4df773c35475..462f05d9a8cf 100644 --- a/middle_end/flambda2.0/parser/parse_ilambda.ml +++ b/middle_end/flambda2.0/parser/parse_ilambda.ml @@ -35,10 +35,10 @@ let parse_program filename = Printexc.raise_with_backtrace e x let check_invariants program = - try Flambda_static.Program.invariant program + try Flambda_unit.invariant program with exn -> Format.eprintf "Program which failed invariant check:@ %a\n%!" - Flambda_static.Program.print program; + Flambda_unit.print program; raise exn let parse_ilambda ~backend file = @@ -52,16 +52,16 @@ let parse_ilambda ~backend file = let fl2 = Closure_conversion.ilambda_to_flambda ~backend ~module_ident:il.module_ident - ~size:il.size + ~module_block_size_in_words:il.size ~filename:"/tmp/toto" il.program in Format.printf "flambda:@.%a@.@." - Flambda_static.Program.print fl2; + Flambda_unit.print fl2; check_invariants fl2; let fl2' = Simplify.run ~backend ~round:1 fl2 in Format.printf "simplify:@.%a@." - Flambda_static.Program.print fl2'; + Flambda_unit.print fl2'; fl2' | Error e -> begin match e with @@ -86,11 +86,11 @@ let parse_flambda ~backend file = Print_fexpr.program program; let fl2 = Fexpr_to_flambda.conv ~backend program in Format.printf "flambda:@.%a@.@." - Flambda_static.Program.print fl2; + Flambda_unit.print fl2; check_invariants fl2; let fl2' = Simplify.run ~backend ~round:1 fl2 in Format.printf "simplify:@.%a@." - Flambda_static.Program.print fl2'; + Flambda_unit.print fl2'; fl2' | Error e -> begin match e with diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index fc3fe89d96b0..a75db1cddc0d 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -88,6 +88,8 @@ module rec Expr : sig (such as is required to bind a [Set_of_closures]). *) val create_pattern_let : Bindable_let_bound.t -> Named.t -> t -> t + val create_let_symbol : Let_symbol_expr.t -> t + (** Create an application expression. *) val create_apply : Apply.t -> t diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index e75d3bce98ef..ce84b781279c 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -19,8 +19,9 @@ type t = { imported_symbols : Flambda_kind.t Symbol.Map.t; root_symbol : Symbol.t; + return_continuation : Continuation.t; exn_continuation : Continuation.t; - body : Expr.t; + body : Flambda.Expr.t; } let create ~imported_symbols ~root_symbol ~return_continuation @@ -38,11 +39,24 @@ let return_continuation t = t.return_continuation let exn_continuation t = t.exn_continuation let body t = t.body -let print ppf t = - Format.fprintf ppf "@[(@[(imported_symbols %a)@]@ @[<1>(body@ %a)@])@]" - (Symbol.Map.print K.print) t.imported_symbols - Program_body.print t.body +let print ppf + { imported_symbols; root_symbol; return_continuation; exn_continuation; + body; + } = + Format.fprintf ppf "@[(\ + @[(imported_symbols@ %a)@]@ \ + @[(root_symbol@ %a)@]@ \ + @[(return_continuation@ %a)@]@ \ + @[(exn_continuation@ %a)@]@ \ + @[(body@ %a)@]\ + )@]" + (Symbol.Map.print Flambda_kind.print) imported_symbols + Symbol.print root_symbol + Continuation.print return_continuation + Continuation.print exn_continuation + Flambda.Expr.print t.body let invariant _t = () -let used_closure_vars t = Program_body.used_closure_vars t.body +let used_closure_vars t = + Name_occurrences.closure_vars (Flambda.Expr.free_names t.body) diff --git a/middle_end/flambda2.0/terms/flambda_unit.mli b/middle_end/flambda2.0/terms/flambda_unit.mli index b9148b53394d..af2c7cc43cab 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.mli +++ b/middle_end/flambda2.0/terms/flambda_unit.mli @@ -32,7 +32,7 @@ val create -> root_symbol:Symbol.t -> return_continuation:Continuation.t -> exn_continuation:Continuation.t - -> body:Expr.t + -> body:Flambda.Expr.t -> t (** All closure variables used in the given unit. *) @@ -45,4 +45,4 @@ val imported_symbols : t -> Flambda_kind.t Symbol.Map.t be eliminated). *) val root_symbol : t -> Symbol.t -val body : t -> Expr.t +val body : t -> Flambda.Expr.t From 1d15de11690e4c8d6215f26710c33d8cdf533f05 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 15:42:48 +0000 Subject: [PATCH 14/80] terms --- asmcomp/asmgen.ml | 13 +- asmcomp/asmgen.mli | 6 +- middle_end/flambda2.0/flambda2_middle_end.ml | 16 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 4 +- .../flambda2.0/simplify/simplify_import.ml | 5 +- .../flambda2.0/simplify/simplify_import.mli | 3 +- middle_end/flambda2.0/terms/flambda.mli | 2 + .../flambda2.0/terms/static_const.rec.ml | 5 + .../flambda2.0/terms/static_const.rec.mli | 2 + middle_end/flambda2.0/to_cmm/un_cps.ml | 310 +----------------- middle_end/flambda2.0/to_cmm/un_cps.mli | 6 +- .../flambda2.0/to_cmm/un_cps_closure.ml | 16 +- .../flambda2.0/to_cmm/un_cps_closure.mli | 6 +- middle_end/flambda2.0/to_cmm/un_cps_static.ml | 297 +++++++++++++++++ .../flambda2.0/to_cmm/un_cps_static.mli | 19 ++ 15 files changed, 378 insertions(+), 332 deletions(-) create mode 100644 middle_end/flambda2.0/to_cmm/un_cps_static.ml create mode 100644 middle_end/flambda2.0/to_cmm/un_cps_static.mli diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 177d16c8888c..4c03ed59d834 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -182,14 +182,15 @@ type middle_end2 = ppf_dump:Format.formatter -> prefixname:string -> backend:(module Flambda2_backend_intf.S) - -> size:int -> filename:string -> module_ident:Ident.t + -> module_block_size_in_words:int -> module_initializer:Lambda.lambda - -> Flambda_static.Program.t + -> Flambda_unit.t -let compile_implementation2 ?toplevel ~backend ~filename ~prefixname ~size - ~module_ident ~module_initializer ~middle_end ~ppf_dump required_globals = +let compile_implementation2 ?toplevel ~backend ~filename ~prefixname + ~size:module_block_size_in_words ~module_ident ~module_initializer + ~middle_end ~ppf_dump required_globals = let asmfile = if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm @@ -199,8 +200,8 @@ let compile_implementation2 ?toplevel ~backend ~filename ~prefixname ~size (fun () -> Ident.Set.iter Compilenv.require_global required_globals; let translated_program = - (middle_end : middle_end2) ~backend ~size ~filename ~prefixname - ~ppf_dump ~module_ident ~module_initializer + (middle_end : middle_end2) ~backend ~module_block_size_in_words + ~filename ~prefixname ~ppf_dump ~module_ident ~module_initializer in end_gen_implementation ?toplevel ~ppf_dump Un_cps.program translated_program) diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 9d030eef2e05..be27e4389cce 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -40,11 +40,11 @@ type middle_end2 = ppf_dump:Format.formatter -> prefixname:string -> backend:(module Flambda2_backend_intf.S) - -> size:int -> filename:string -> module_ident:Ident.t + -> module_block_size_in_words:int -> module_initializer:Lambda.lambda - -> Flambda_static.Program.t + -> Flambda_unit.t (** Compile an implementation from Lambda using the given middle end. *) val compile_implementation2 @@ -66,7 +66,7 @@ val compile_implementation_flambda -> prefixname:string -> ppf_dump:Format.formatter -> required_globals:Ident.Set.t - -> Flambda_static.Program.t + -> Flambda_unit.t -> unit val compile_phrase : diff --git a/middle_end/flambda2.0/flambda2_middle_end.ml b/middle_end/flambda2.0/flambda2_middle_end.ml index 852bbe2c1a3b..66523993614b 100644 --- a/middle_end/flambda2.0/flambda2_middle_end.ml +++ b/middle_end/flambda2.0/flambda2_middle_end.ml @@ -16,11 +16,11 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -let check_invariants program = - try Flambda_static.Program.invariant program +let check_invariants unit = + try Flambda_unit.invariant unit with exn -> begin - Format.eprintf "Program which failed invariant check:@ %a\n%!" - Flambda_static.Program.print program; + Format.eprintf "Unit which failed invariant check:@ %a\n%!" + Flambda_unit.print unit; raise exn end @@ -57,21 +57,21 @@ let print_ilambda_after_mutable_variable_elimination ppf Ilambda.print ilam.expr end -let print_rawflambda ppf program = +let print_rawflambda ppf unit = if !Clflags.dump_rawflambda2 then begin Format.fprintf ppf "\n%sAfter closure conversion:%s@ %a@." (Flambda_colours.each_file ()) (Flambda_colours.normal ()) - Flambda_static.Program.print program + Flambda_unit.print unit end -let print_flambda name ppf program = +let print_flambda name ppf unit = if !Clflags.dump_flambda then begin Format.fprintf ppf "\n%sAfter %s:%s@ %a@." (Flambda_colours.each_file ()) name (Flambda_colours.normal ()) - Flambda_static.Program.print program + Flambda_unit.print unit end let middle_end0 ppf ~prefixname:_ ~backend ~filename ~module_ident diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index fa4df7fa0015..f5d812e0395f 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -271,8 +271,8 @@ and simplify_non_recursive_let_cont_handler handler, user_data, uacc, is_single_inlinable_use with Misc.Fatal_error -> begin if !Clflags.flambda2_context_on_error then begin - Format.eprintf "\n%sContext is:%s simplifying - continuation \ handler (inlinable? %b)@ %a@ with \ + Format.eprintf "\n%sContext is:%s simplifying \ + continuation handler (inlinable? %b)@ %a@ with \ [extra_params_and_args]@ %a@ \ with downwards accumulator:@ %a\n" (Flambda_colours.error ()) diff --git a/middle_end/flambda2.0/simplify/simplify_import.ml b/middle_end/flambda2.0/simplify/simplify_import.ml index c2d3175974f5..e6c059bca771 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.ml +++ b/middle_end/flambda2.0/simplify/simplify_import.ml @@ -21,7 +21,6 @@ module Apply_cont = Flambda.Apply_cont module Continuation_handler = Flambda.Continuation_handler module Continuation_handlers = Flambda.Continuation_handlers module Continuation_params_and_handler = Flambda.Continuation_params_and_handler -module Definition = Flambda_static.Program_body.Definition module Expr = Flambda.Expr module Function_declaration = Flambda.Function_declaration module Function_declarations = Flambda.Function_declarations @@ -31,11 +30,12 @@ module Let = Flambda.Let module Lifted_constant = Simplify_env_and_result.Lifted_constant module Named = Flambda.Named module Non_recursive_let_cont_handler = Flambda.Non_recursive_let_cont_handler -module Program_body = Flambda_static.Program_body module Recursive_let_cont_handlers = Flambda.Recursive_let_cont_handlers module Set_of_closures = Flambda.Set_of_closures +module Static_const = Flambda.Static_const module Switch = Flambda.Switch +module CH = Continuation_handler module CUE = Continuation_uses_env module DA = Downwards_acc module DE = Simplify_env_and_result.Downwards_env @@ -49,6 +49,7 @@ module NM = Name_mode module P = Flambda_primitive module R = Simplify_env_and_result.Result module S = Simplify_simple +module SC = Static_const module T = Flambda_type module TE = Flambda_type.Typing_env module TEE = Flambda_type.Typing_env_extension diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index c9e519f7add2..e6c059bca771 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -21,7 +21,6 @@ module Apply_cont = Flambda.Apply_cont module Continuation_handler = Flambda.Continuation_handler module Continuation_handlers = Flambda.Continuation_handlers module Continuation_params_and_handler = Flambda.Continuation_params_and_handler -module Definition = Flambda_static.Program_body.Definition module Expr = Flambda.Expr module Function_declaration = Flambda.Function_declaration module Function_declarations = Flambda.Function_declarations @@ -31,9 +30,9 @@ module Let = Flambda.Let module Lifted_constant = Simplify_env_and_result.Lifted_constant module Named = Flambda.Named module Non_recursive_let_cont_handler = Flambda.Non_recursive_let_cont_handler -module Program_body = Flambda_static.Program_body module Recursive_let_cont_handlers = Flambda.Recursive_let_cont_handlers module Set_of_closures = Flambda.Set_of_closures +module Static_const = Flambda.Static_const module Switch = Flambda.Switch module CH = Continuation_handler diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index a75db1cddc0d..196992affe87 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -537,6 +537,8 @@ end and Static_const : sig val get_pieces_of_code : t -> (Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t + + val is_fully_static : t -> bool end module Function_declaration = Function_declaration diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index e244d182d8ca..1445e0462e77 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -482,3 +482,8 @@ let get_pieces_of_code t = | Immutable_float_array _ | Mutable_string _ | Immutable_string _ -> Code_id.Map.empty + +let is_fully_static t = + free_names t + |> Name_occurrences.variables + |> Variable.Set.is_empty diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index 7246779d4c88..4b9f4eb9c55c 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -79,3 +79,5 @@ include Contains_names.S with type t := t val get_pieces_of_code : t -> (Flambda.Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t + +val is_fully_static : t -> bool diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index bcbd889b5fb0..722c7302044a 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -1232,292 +1232,13 @@ let params_and_body env fun_name fun_dbg p = Expr.print body; raise e) -(* Static structures *) - -module SP = Flambda_static.Static_part - -let static_value _env v = - match (v : Flambda_static.Of_kind_value.t) with - | Symbol s -> C.symbol_address (symbol s) - | Dynamically_computed _ -> C.cint 1n - | Tagged_immediate i -> - C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i))) - -let or_variable f default v cont = - match (v : _ SP.or_variable) with - | Const c -> f c cont - | Var _ -> f default cont - -let map_or_variable f default v = - match (v : _ SP.or_variable) with - | Const c -> f c - | Var _ -> default - -let make_update env kind symb var i = - let e = Env.get_variable env var in - let address = C.field_address symb i Debuginfo.none in - C.store kind Lambda.Root_initialization address e - -let rec static_block_updates symb env acc i = function - | [] -> List.fold_left C.sequence C.void acc - | sv :: r -> - begin match (sv : Flambda_static.Of_kind_value.t) with - | Symbol _ - | Tagged_immediate _ -> - static_block_updates symb env acc (i + 1) r - | Dynamically_computed var -> - let update = make_update env Cmm.Word_val symb var i in - static_block_updates symb env (update :: acc) (i + 1) r - end - -let rec static_float_array_updates symb env acc i = function - | [] -> List.fold_left C.sequence C.void acc - | sv :: r -> - begin match (sv : _ SP.or_variable) with - | Const _ -> - static_float_array_updates symb env acc (i + 1) r - | Var var -> - let update = make_update env Cmm.Double_u symb var i in - static_float_array_updates symb env (update :: acc) (i + 1) r - end - -let static_boxed_number kind env s default emit transl v r = - let name = symbol s in - let aux x cont = emit (name, Cmmgen_state.Global) (transl x) cont in - let wrapper = - match (v : _ SP.or_variable) with - | Const _ -> Fun.id - | Var v -> - let update = make_update env kind (C.symbol name) v 0 in - C.sequence update - in - R.wrap_init wrapper (R.update_data (or_variable aux default v) r) - -let get_whole_closure_symbol = - let whole_closure_symb_count = ref 0 in - (fun r -> - match !r with - | Some s -> s - | None -> - incr whole_closure_symb_count; - let comp_unit = Compilation_unit.get_current_exn () in - let linkage_name = - Linkage_name.create @@ - Printf.sprintf ".clos_%d" !whole_closure_symb_count - in - let s = Symbol.create comp_unit linkage_name in - r := Some s; - s - ) - -let rec static_set_of_closures env symbs set = - let clos_symb = ref None in - let fun_decls = Set_of_closures.function_decls set in - let decls = Function_declarations.funs fun_decls in - let elts = filter_closure_vars env (Set_of_closures.closure_elements set) in - let layout = Env.layout env - (List.map fst (Closure_id.Map.bindings decls)) - (List.map fst (Var_within_closure.Map.bindings elts)) - in - let l, updates, length = - fill_static_layout clos_symb symbs decls elts env [] C.void 0 layout - in - let header = C.cint (C.black_closure_header length) in - let sdef = match !clos_symb with - | None -> [] - | Some s -> C.define_symbol ~global:false (symbol s) - in - header :: sdef @ l, updates - -and fill_static_layout s symbs decls elts env acc updates i = function - | [] -> List.rev acc, updates, i - | (j, slot) :: r -> - let acc = fill_static_up_to j acc i in - let acc, offset, updates = - fill_static_slot s symbs decls elts env acc j updates slot - in - fill_static_layout s symbs decls elts env acc updates offset r - -and fill_static_slot s symbs decls elts env acc offset updates slot = - match (slot : Un_cps_closure.layout_slot) with - | Infix_header -> - let field = C.cint (C.infix_header (offset + 1)) in - field :: acc, offset + 1, updates - | Env_var v -> - let fields, updates = - match simple_static env (Var_within_closure.Map.find v elts) with - | `Data fields -> fields, updates - | `Var v -> - let s = get_whole_closure_symbol s in - let update = - make_update env Cmm.Word_val (C.symbol (symbol s)) v offset - in - [C.cint 1n], C.sequence update updates - in - List.rev fields @ acc, offset + 1, updates - | Closure c -> - let decl = Closure_id.Map.find c decls in - let symb = Closure_id.Map.find c symbs in - let external_name = symbol symb in - let code_name = - Un_cps_closure.closure_code (Un_cps_closure.closure_name c) - in - let acc = List.rev (C.define_symbol ~global:true external_name) @ acc in - let arity = List.length (Function_declaration.params_arity decl) in - let tagged_arity = arity * 2 + 1 in - (* We build here the **reverse** list of fields for the closure *) - if arity = 1 || arity = 0 then begin - let acc = - C.cint (Nativeint.of_int tagged_arity) :: - C.symbol_address code_name :: - acc - in - acc, offset + 2, updates - end else begin - let acc = - C.symbol_address code_name :: - C.cint (Nativeint.of_int tagged_arity) :: - C.symbol_address (C.curry_function_sym arity) :: - acc - in - acc, offset + 3, updates - end - -and fill_static_up_to j acc i = - if i = j then acc - else fill_static_up_to j (C.cint 1n :: acc) (i + 1) - -let static_structure_item env r - ((S (symb, st)) : Flambda_static.Program_body.Static_structure.t0) = - match symb, st with - | Singleton s, Block (tag, _mut, fields) -> - let name = symbol s in - let tag = Tag.Scannable.to_int tag in - let block_name = name, Cmmgen_state.Global in - let header = C.block_header tag (List.length fields) in - let static_fields = List.map (static_value env) fields in - let block = C.emit_block block_name header static_fields in - let e = static_block_updates (C.symbol name) env [] 0 fields in - env, R.wrap_init (C.sequence e) (R.add_data block r) - | Singleton _, Fabricated_block _ -> - (* CR Gbury: What are those ? *) - todo() - | Code_and_set_of_closures { code_ids = _; closure_symbols; }, - Code_and_set_of_closures { code; set_of_closures; } -> - (* We cannot both build the environment and compile the functions in - one traversal, as the bodies may contain direct calls to the code ids - being defined *) - let updated_env = - Code_id.Map.fold - (fun code_id SP.({ params_and_body = p; newer_version_of = _; }) env -> - match (p : _ SP.or_deleted) with - | Deleted -> env - | Present p -> - Function_params_and_body.pattern_match p - ~f:(fun ~return_continuation:_ _exn_k _ps ~body ~my_closure -> - let free_vars = - Name_occurrences.variables (Expr.free_names body) - in - (* Format.eprintf "Free vars: %a@." Variable.Set.print free_vars; *) - let needs_closure_arg = - Variable.Set.mem my_closure free_vars - in - let info : Env.function_info = { needs_closure_arg; } in - Env.add_function_info env code_id info)) - code - env - in - let r = - Code_id.Map.fold - (fun code_id SP.({ params_and_body = p; newer_version_of = _; }) r -> - match (p : _ SP.or_deleted) with - | Deleted -> r - | Present p -> - let fun_symbol = Code_id.code_symbol code_id in - let fun_name = - Linkage_name.to_string (Symbol.linkage_name fun_symbol) - in - (* CR vlaviron: fix debug info *) - let fundecl = - C.cfunction (params_and_body updated_env fun_name Debuginfo.none p) - in - R.add_function fundecl r) - code - r - in - begin match set_of_closures with - | None -> updated_env, r - | Some set -> - let data, updates = - static_set_of_closures env closure_symbols set - in - updated_env, R.wrap_init (C.sequence updates) (R.add_data data r) - end - | Singleton s, Boxed_float v -> - let default = Numbers.Float_by_bit_pattern.zero in - let transl = Numbers.Float_by_bit_pattern.to_float in - env, static_boxed_number - Cmm.Double_u env s default C.emit_float_constant transl v r - | Singleton s, Boxed_int32 v -> - env, static_boxed_number - Cmm.Word_int env s 0l C.emit_int32_constant Fun.id v r - | Singleton s, Boxed_int64 v -> - env, static_boxed_number - Cmm.Word_int env s 0L C.emit_int64_constant Fun.id v r - | Singleton s, Boxed_nativeint v -> - let default = Targetint.zero in - let transl = nativeint_of_targetint in - env, static_boxed_number - Cmm.Word_int env s default C.emit_nativeint_constant transl v r - | Singleton s, Immutable_float_array fields -> - let name = symbol s in - let aux = map_or_variable Numbers.Float_by_bit_pattern.to_float 0. in - let static_fields = List.map aux fields in - let float_array = - C.emit_float_array_constant (name, Cmmgen_state.Global) static_fields - in - let e = static_float_array_updates (C.symbol name) env [] 0 fields in - env, R.wrap_init (C.sequence e) (R.update_data float_array r) - | Singleton s, Mutable_string { initial_value; } - | Singleton s, Immutable_string initial_value -> - let name = symbol s in - begin match initial_value with - | Var _ -> - (* CR vlaviron: this doesn't make sense, strings - can't be initialized without knowing their length *) - Misc.fatal_errorf "Trying to initialize a string of unknown length" - | Const str -> - let data = C.emit_string_constant (name, Cmmgen_state.Global) str in - env, R.update_data data r - end - -let static_structure env is_fully_static s = - (* Gc roots: statically allocated blocks themselves do not need to be scanned, - however if statically allocated blocks contain dynamically allocated contents, - then that block has to be registered as Gc roots for the Gc to correctly patch - it if/when it moves some of the dynamically allocated blocks. As a safe - over-approximation, we thus register as gc_roots all symbols who have an - associated computation (and thus are not fully_static). *) - let roots = - if is_fully_static then [] - else Symbol.Set.elements - (Flambda_static.Program_body.Static_structure.being_defined s) - in - let r = R.add_gc_roots roots R.empty in - List.fold_left (fun (env_acc, r_acc) item -> - let env, r = static_structure_item env_acc r_acc item in - (* Archive_data helps keep definitions of separate symbols in different - data_item lists and this increases readability of the generated cmm. *) - env, R.archive_data r - ) (env, r) s - (* Definition *) let computation_wrapper env c = match c with | None -> env, (fun x -> x), true - | Some (c : Flambda_static.Program_body.Computation.t) -> + | Some (c : Flambda_unit_body.Computation.t) -> (* The env for the computation is given a dummy continuation, since the return continuation will be explicitly bound to a jump before translating the computation. *) @@ -1545,13 +1266,14 @@ let computation_wrapper env c = ~rec_flag:false ~body ~handlers:[C.handler id vars e] in - (* CR gbury: for the future, try and rearrange the generated cmm - code to move assignments closer to the variable definitions - Or better: add traps to the env to insert assignemnts after - the variable definitions. *) s_env, wrap, false -let definition env (d : Flambda_static.Program_body.Definition.t) = +(* CR gbury: for the future, try and rearrange the generated cmm + code to move assignments closer to the variable definitions + Or better: add traps to the env to insert assignemnts after + the variable definitions. *) + +let definition env (d : Flambda_unit_body.Definition.t) = let env, wrapper, is_fully_static = computation_wrapper env d.computation in @@ -1562,14 +1284,14 @@ let definition env (d : Flambda_static.Program_body.Definition.t) = (* Programs *) let rec program_body env acc body = - match Flambda_static.Program_body.descr body with - | Flambda_static.Program_body.Root _sym -> + match Flambda_unit_body.descr body with + | Flambda_unit_body.Root _sym -> (* The root symbol does not really deserve any particular treatment. Concerning gc_roots, it's like any other statically allocated symbol: if if has an associated computation, then it will already be included in the list of gc_roots, else it does not *have* to be a root. *) List.fold_left (fun acc r -> R.combine r acc) R.empty acc - | Flambda_static.Program_body.Definition (def, rest) -> + | Flambda_unit_body.Definition (def, rest) -> let env, r = definition env def in program_body env (r :: acc) rest @@ -1584,16 +1306,16 @@ let rec program_body env acc body = * in * List.map (fun decl -> C.cfunction decl) sorted *) -let program (p : Flambda_static.Program.t) = +let program (unit : Flambda_unit.t) = Profile.record_call "flambda2_to_cmm" (fun () -> - let offsets = Un_cps_closure.compute_offsets p in - let used_closure_vars = - Name_occurrences.closure_vars (Flambda_static.Program.free_names p) + let offsets = Un_cps_closure.compute_offsets unit in + let used_closure_vars = Flambda_unit.used_closure_vars unit in + Name_occurrences.closure_vars (Flambda_unit.free_names unit) in let dummy_k = Continuation.create () in let env = Env.mk offsets dummy_k dummy_k used_closure_vars in - (* let functions = program_functions offsets used_closure_vars p in *) - let res = program_body env [] p.body in + (* let functions = program_functions offsets used_closure_vars unit in *) + let res = program_body env [] unit.body in let data, entry, gc_roots, functions = R.to_cmm res in let cmm_data = C.flush_cmmgen_state () in let roots = List.map symbol gc_roots in diff --git a/middle_end/flambda2.0/to_cmm/un_cps.mli b/middle_end/flambda2.0/to_cmm/un_cps.mli index aaae3e735062..ce9186015cb1 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps.mli @@ -12,8 +12,8 @@ (* *) (**************************************************************************) -(* Translate flambda2 expressions and programs into Cmm *) +(* Translate Flambda compilation units into Cmm *) -val program : Flambda_static.Program.t -> Cmm.phrase list -(** Translate a program. *) +val program : Flambda_unit.t -> Cmm.phrase list +(** Translate a compilation unit. *) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml index 6f03276b2a80..742104f271f0 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml @@ -637,10 +637,10 @@ module Iter_on_sets_of_closures = struct *) let computation f c = - Flambda_static.Program_body.Computation.iter_expr c ~f:(expr f) + Flambda_unit_body.Computation.iter_expr c ~f:(expr f) let static_structure_aux f - ((S (symbs, st)) : Flambda_static.Program_body.Static_structure.t0) = + ((S (symbs, st)) : Flambda_unit_body.Static_structure.t0) = match symbs, st with | Code_and_set_of_closures { code_ids = _; closure_symbols; }, Code_and_set_of_closures { code; set_of_closures = s; } -> @@ -659,23 +659,21 @@ module Iter_on_sets_of_closures = struct let static_structure f s = List.iter (static_structure_aux f) s - let definition f (d : Flambda_static.Program_body.Definition.t) = - Flambda_static.Program_body.Definition.iter_computation d ~f:(computation f); + let definition f (d : Flambda_unit_body.Definition.t) = + Flambda_unit_body.Definition.iter_computation d ~f:(computation f); static_structure f d.static_structure let body f b = - Flambda_static.Program_body.iter_definitions b ~f:(definition f) + Flambda_unit_body.iter_definitions b ~f:(definition f) let program f t = - Flambda_static.Program.iter_body t ~f:(body f) + Flambda_unit.iter_body t ~f:(body f) end let compute_offsets program = let state = ref Greedy.empty_state in - let used_closure_vars = - Name_occurrences.closure_vars (Flambda_static.Program.free_names program) - in + let used_closure_vars = Flambda_unit.used_closure_vars unit in let aux _ s = state := Greedy.create_slots_for_set !state used_closure_vars s in diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.mli b/middle_end/flambda2.0/to_cmm/un_cps_closure.mli index 0e0381f58147..a857bdbaef8f 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.mli @@ -24,8 +24,8 @@ val print_env : Format.formatter -> env -> unit val empty_env : env (** Empty environment. *) -val compute_offsets : Flambda_static.Program.t -> env -(** Compute offsets for a whole program. *) +val compute_offsets : Flambda_unit.t -> env +(** Compute offsets for a whole compilation unit. *) val env_var_offset : env -> Var_within_closure.t -> int (** Returns the offset computed for an environment variable, in @@ -47,7 +47,7 @@ val closure_code : string -> string (* val map_on_function_decl : * (string -> Closure_id.t -> Flambda.Function_declaration.t -> 'a) -> - * Flambda_static.Program.t -> 'a Closure_id.Map.t + * Flambda_unit.t -> 'a Closure_id.Map.t * (\** Map a function on each function body exactly once, and return the * resulting mapping. *\) *) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.ml b/middle_end/flambda2.0/to_cmm/un_cps_static.ml new file mode 100644 index 000000000000..989196494737 --- /dev/null +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.ml @@ -0,0 +1,297 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2019--2019 OCamlPro SAS *) +(* *) +(* 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-30-40-41-42"] + +open! Flambda.Import + +module Bound_symbols = Let_symbol.Bound_symbols +module Env = Un_cps_env +module Ece = Effects_and_coeffects +module SC = Flambda.Static_const + +let static_value _env v = + match (v : SC.Field_of_block.t) with + | Symbol s -> C.symbol_address (symbol s) + | Dynamically_computed _ -> C.cint 1n + | Tagged_immediate i -> + C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i))) + +let or_variable f default v cont = + match (v : _ SC.or_variable) with + | Const c -> f c cont + | Var _ -> f default cont + +let map_or_variable f default v = + match (v : _ SC.or_variable) with + | Const c -> f c + | Var _ -> default + +let make_update env kind symb var i = + let e = Env.get_variable env var in + let address = C.field_address symb i Debuginfo.none in + C.store kind Lambda.Root_initialization address e + +let rec static_block_updates symb env acc i = function + | [] -> List.fold_left C.sequence C.void acc + | sv :: r -> + begin match (sv : Flambda_static.Of_kind_value.t) with + | Symbol _ + | Tagged_immediate _ -> + static_block_updates symb env acc (i + 1) r + | Dynamically_computed var -> + let update = make_update env Cmm.Word_val symb var i in + static_block_updates symb env (update :: acc) (i + 1) r + end + +let rec static_float_array_updates symb env acc i = function + | [] -> List.fold_left C.sequence C.void acc + | sv :: r -> + begin match (sv : _ SC.or_variable) with + | Const _ -> + static_float_array_updates symb env acc (i + 1) r + | Var var -> + let update = make_update env Cmm.Double_u symb var i in + static_float_array_updates symb env (update :: acc) (i + 1) r + end + +let static_boxed_number kind env s default emit transl v r = + let name = symbol s in + let aux x cont = emit (name, Cmmgen_state.Global) (transl x) cont in + let wrapper = + match (v : _ SC.or_variable) with + | Const _ -> Fun.id + | Var v -> + let update = make_update env kind (C.symbol name) v 0 in + C.sequence update + in + R.wrap_init wrapper (R.update_data (or_variable aux default v) r) + +let get_whole_closure_symbol = + let whole_closure_symb_count = ref 0 in + (fun r -> + match !r with + | Some s -> s + | None -> + incr whole_closure_symb_count; + let comp_unit = Compilation_unit.get_current_exn () in + let linkage_name = + Linkage_name.create @@ + Printf.sprintf ".clos_%d" !whole_closure_symb_count + in + let s = Symbol.create comp_unit linkage_name in + r := Some s; + s + ) + +let rec static_set_of_closures env symbs set = + let clos_symb = ref None in + let fun_decls = Set_of_closures.function_decls set in + let decls = Function_declarations.funs fun_decls in + let elts = filter_closure_vars env (Set_of_closures.closure_elements set) in + let layout = Env.layout env + (List.map fst (Closure_id.Map.bindings decls)) + (List.map fst (Var_within_closure.Map.bindings elts)) + in + let l, updates, length = + fill_static_layout clos_symb symbs decls elts env [] C.void 0 layout + in + let header = C.cint (C.black_closure_header length) in + let sdef = match !clos_symb with + | None -> [] + | Some s -> C.define_symbol ~global:false (symbol s) + in + header :: sdef @ l, updates + +and fill_static_layout s symbs decls elts env acc updates i = function + | [] -> List.rev acc, updates, i + | (j, slot) :: r -> + let acc = fill_static_up_to j acc i in + let acc, offset, updates = + fill_static_slot s symbs decls elts env acc j updates slot + in + fill_static_layout s symbs decls elts env acc updates offset r + +and fill_static_slot s symbs decls elts env acc offset updates slot = + match (slot : Un_cps_closure.layout_slot) with + | Infix_header -> + let field = C.cint (C.infix_header (offset + 1)) in + field :: acc, offset + 1, updates + | Env_var v -> + let fields, updates = + match simple_static env (Var_within_closure.Map.find v elts) with + | `Data fields -> fields, updates + | `Var v -> + let s = get_whole_closure_symbol s in + let update = + make_update env Cmm.Word_val (C.symbol (symbol s)) v offset + in + [C.cint 1n], C.sequence update updates + in + List.rev fields @ acc, offset + 1, updates + | Closure c -> + let decl = Closure_id.Map.find c decls in + let symb = Closure_id.Map.find c symbs in + let external_name = symbol symb in + let code_name = + Un_cps_closure.closure_code (Un_cps_closure.closure_name c) + in + let acc = List.rev (C.define_symbol ~global:true external_name) @ acc in + let arity = List.length (Function_declaration.params_arity decl) in + let tagged_arity = arity * 2 + 1 in + (* We build here the **reverse** list of fields for the closure *) + if arity = 1 || arity = 0 then begin + let acc = + C.cint (Nativeint.of_int tagged_arity) :: + C.symbol_address code_name :: + acc + in + acc, offset + 2, updates + end else begin + let acc = + C.symbol_address code_name :: + C.cint (Nativeint.of_int tagged_arity) :: + C.symbol_address (C.curry_function_sym arity) :: + acc + in + acc, offset + 3, updates + end + +and fill_static_up_to j acc i = + if i = j then acc + else fill_static_up_to j (C.cint 1n :: acc) (i + 1) + +let static_const0 env (bound_symbols : Bound_symbols.t) + (static_const : Static_const.t) = + match bound_symbols, static_const with + | Singleton s, Block (tag, _mut, fields) -> + let name = symbol s in + let tag = Tag.Scannable.to_int tag in + let block_name = name, Cmmgen_state.Global in + let header = C.block_header tag (List.length fields) in + let static_fields = List.map (static_value env) fields in + let block = C.emit_block block_name header static_fields in + let e = static_block_updates (C.symbol name) env [] 0 fields in + env, R.wrap_init (C.sequence e) (R.add_data block r) + | Code_and_set_of_closures { code_ids = _; closure_symbols; }, + Code_and_set_of_closures { code; set_of_closures; } -> + (* We cannot both build the environment and compile the functions in + one traversal, as the bodies may contain direct calls to the code ids + being defined *) + let updated_env = + Code_id.Map.fold + (fun code_id SC.({ params_and_body = p; newer_version_of = _; }) env -> + match (p : _ SC.or_deleted) with + | Deleted -> env + | Present p -> + Function_params_and_body.pattern_match p + ~f:(fun ~return_continuation:_ _exn_k _ps ~body ~my_closure -> + let free_vars = + Name_occurrences.variables (Expr.free_names body) + in + (* Format.eprintf "Free vars: %a@." Variable.Set.print free_vars; *) + let needs_closure_arg = + Variable.Set.mem my_closure free_vars + in + let info : Env.function_info = { needs_closure_arg; } in + Env.add_function_info env code_id info)) + code + env + in + let r = + Code_id.Map.fold + (fun code_id SC.({ params_and_body = p; newer_version_of = _; }) r -> + match (p : _ SC.or_deleted) with + | Deleted -> r + | Present p -> + let fun_symbol = Code_id.code_symbol code_id in + let fun_name = + Linkage_name.to_string (Symbol.linkage_name fun_symbol) + in + (* CR vlaviron: fix debug info *) + let fundecl = + C.cfunction (params_and_body updated_env fun_name Debuginfo.none p) + in + R.add_function fundecl r) + code + r + in + begin match set_of_closures with + | None -> updated_env, r + | Some set -> + let data, updates = + static_set_of_closures env closure_symbols set + in + updated_env, R.wrap_init (C.sequence updates) (R.add_data data r) + end + | Singleton s, Boxed_float v -> + let default = Numbers.Float_by_bit_pattern.zero in + let transl = Numbers.Float_by_bit_pattern.to_float in + env, static_boxed_number + Cmm.Double_u env s default C.emit_float_constant transl v r + | Singleton s, Boxed_int32 v -> + env, static_boxed_number + Cmm.Word_int env s 0l C.emit_int32_constant Fun.id v r + | Singleton s, Boxed_int64 v -> + env, static_boxed_number + Cmm.Word_int env s 0L C.emit_int64_constant Fun.id v r + | Singleton s, Boxed_nativeint v -> + let default = Targetint.zero in + let transl = nativeint_of_targetint in + env, static_boxed_number + Cmm.Word_int env s default C.emit_nativeint_constant transl v r + | Singleton s, Immutable_float_array fields -> + let name = symbol s in + let aux = map_or_variable Numbers.Float_by_bit_pattern.to_float 0. in + let static_fields = List.map aux fields in + let float_array = + C.emit_float_array_constant (name, Cmmgen_state.Global) static_fields + in + let e = static_float_array_updates (C.symbol name) env [] 0 fields in + env, R.wrap_init (C.sequence e) (R.update_data float_array r) + | Singleton s, Mutable_string { initial_value = str; } + | Singleton s, Immutable_string str -> + let name = symbol s in + let data = C.emit_string_constant (name, Cmmgen_state.Global) str in + env, R.update_data data r + | Singleton _, Code_and_set_of_closures _ -> + Misc.fatal_errorf "[Code_and_set_of_closures] cannot be bound by a \ + [Singleton] binding:@ %a" + SC.print static_const + | Code_and_set_of_closures _, + (Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ + | Immutable_string _) -> + Misc.fatal_errorf "Only [Code_and_set_of_closures] can be bound by a \ + [Code_and_set_of_closures] binding:@ %a" + SC.print static_const + +let static_const env (bound_symbols : Bound_symbols.t) + (static_const : Static_const.t) = + (* Gc roots: statically allocated blocks themselves do not need to be scanned, + however if statically allocated blocks contain dynamically allocated + contents, then that block has to be registered as Gc roots for the Gc to + correctly patch it if/when it moves some of the dynamically allocated + blocks. As a safe over-approximation, we thus register as gc_roots all + symbols who have an associated computation (and thus are not + fully_static). *) + let roots = + if Static_const.is_fully_static static_const then [] + else Symbol.Set.elements (Bound_symbols.being_defined s) + in + let r = R.add_gc_roots roots R.empty in + let env, r = static_const0 env bound_symbols static_const in + (* [R.archive_data] helps keep definitions of separate symbols in different + [data_item] lists and this increases readability of the generated Cmm. *) + env, R.archive_data r diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.mli b/middle_end/flambda2.0/to_cmm/un_cps_static.mli new file mode 100644 index 000000000000..9a37d1ad2627 --- /dev/null +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2019--2019 OCamlPro SAS *) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Translation of statically-allocated constants to Cmm. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +open! Flambda.Import From 4852ac1a822a283e7d36db4279f78ab5728920e8 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 16:19:57 +0000 Subject: [PATCH 15/80] terms --- middle_end/flambda2.0/terms/flambda.mli | 1 - middle_end/flambda2.0/terms/flambda_unit.ml | 108 ++++++++ .../flambda2.0/terms/static_const.rec.ml | 13 - .../flambda2.0/terms/static_const.rec.mli | 1 - middle_end/flambda2.0/to_cmm/un_cps.ml | 248 +++++------------- middle_end/flambda2.0/to_cmm/un_cps.mli | 2 +- .../flambda2.0/to_cmm/un_cps_closure.ml | 108 -------- middle_end/flambda2.0/to_cmm/un_cps_result.ml | 89 +++++++ .../flambda2.0/to_cmm/un_cps_result.mli | 42 +++ middle_end/flambda2.0/to_cmm/un_cps_static.ml | 72 ++++- .../flambda2.0/to_cmm/un_cps_static.mli | 12 + 11 files changed, 376 insertions(+), 320 deletions(-) create mode 100644 middle_end/flambda2.0/to_cmm/un_cps_result.ml create mode 100644 middle_end/flambda2.0/to_cmm/un_cps_result.mli diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index 196992affe87..0a38d5906bda 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -519,7 +519,6 @@ end and Static_const : sig with values computed at runtime. *) type t = | Block of Tag.Scannable.t * mutable_or_immutable * (Field_of_block.t list) - | Fabricated_block of Variable.t | Code_and_set_of_closures of code_and_set_of_closures | Boxed_float of Numbers.Float_by_bit_pattern.t or_variable | Boxed_int32 of Int32.t or_variable diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index ce84b781279c..92fe1f1271f7 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -60,3 +60,111 @@ let invariant _t = () let used_closure_vars t = Name_occurrences.closure_vars (Flambda.Expr.free_names t.body) + +(* Iter on all sets of closures of a given program. *) + +module Iter_on_sets_of_closures = struct + + let rec expr f e = + match (Expr.descr e : Expr.descr) with + | Let e' -> let_expr f e' + | Let_cont e' -> let_cont f e' + | Apply e' -> apply_expr f e' + | Apply_cont e' -> apply_cont f e' + | Switch e' -> switch f e' + | Invalid e' -> invalid f e' + + and named f n = + match (n : Named.t) with + | Simple _ | Prim _ -> () + | Set_of_closures s -> + f None s + + and let_expr f t = + Let.pattern_match t ~f:(fun ~bound_vars:_ ~body -> + let e = Let.defining_expr t in + named f e; + expr f body + ) + + and let_cont f = function + | Let_cont.Non_recursive { handler; _ } -> + Non_recursive_let_cont_handler.pattern_match handler ~f:(fun k ~body -> + let h = Non_recursive_let_cont_handler.handler handler in + let_cont_aux f k h body + ) + | Let_cont.Recursive handlers -> + Recursive_let_cont_handlers.pattern_match handlers ~f:(fun ~body conts -> + assert (not (Continuation_handlers.contains_exn_handler conts)); + let_cont_rec f conts body + ) + + and let_cont_aux f k h body = + continuation_handler f k h; + expr f body + + and let_cont_rec f conts body = + let map = Continuation_handlers.to_map conts in + Continuation.Map.iter (continuation_handler f) map; + expr f body + + and continuation_handler f _ h = + let h = Continuation_handler.params_and_handler h in + Continuation_params_and_handler.pattern_match h ~f:(fun _ ~handler -> + expr f handler + ) + + (* Expression application, continuation application and Switches + only use single expressions and continuations, so no sets_of_closures + can syntatically appear inside. *) + and apply_expr _ _ = () + + and apply_cont _ _ = () + + and switch _ _ = () + + and invalid _ _ = () + + (* and fun_decl _f _ _decl = assert false (\* FIXME Let code *\) *) +(* + let t = Function_declaration.params_and_body decl in + Function_params_and_body.pattern_match t + ~f:(fun ~return_continuation:_ _exn_k _args ~body ~my_closure:_ -> + expr f body + ) +*) + + let computation f c = + Flambda_unit_body.Computation.iter_expr c ~f:(expr f) + + let static_structure_aux f + ((S (symbs, st)) : Flambda_unit_body.Static_structure.t0) = + match symbs, st with + | Code_and_set_of_closures { code_ids = _; closure_symbols; }, + Code_and_set_of_closures { code; set_of_closures = s; } -> + Option.iter (fun s -> f (Some closure_symbols) s) s; + Code_id.Map.iter (fun _ { Flambda_static.Static_part.params_and_body; + newer_version_of = _; } -> + match params_and_body with + | Deleted -> () + | Present params_and_body -> + Function_params_and_body.pattern_match params_and_body + ~f:(fun ~return_continuation:_ _ _ ~body ~my_closure:_ -> + expr f body)) + code + | _ -> () + + let static_structure f s = + List.iter (static_structure_aux f) s + + let definition f (d : Flambda_unit_body.Definition.t) = + Flambda_unit_body.Definition.iter_computation d ~f:(computation f); + static_structure f d.static_structure + + let body f b = + Flambda_unit_body.iter_definitions b ~f:(definition f) + + let program f t = + Flambda_unit.iter_body t ~f:(body f) + +end diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index 1445e0462e77..53a7fbf23712 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -112,7 +112,6 @@ type code_and_set_of_closures = { type t = | Block of Tag.Scannable.t * mutable_or_immutable * (Field_of_block.t list) - | Fabricated_block of Variable.t | Code_and_set_of_closures of code_and_set_of_closures | Boxed_float of Numbers.Float_by_bit_pattern.t or_variable | Boxed_int32 of Int32.t or_variable @@ -131,7 +130,6 @@ let get_pieces_of_code t = | Present params_and_body -> Some (params_and_body, newer_version_of) | Deleted -> None) | Block _ - | Fabricated_block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ @@ -147,8 +145,6 @@ let free_names t = Name_occurrences.union fvs (Field_of_block.free_names field)) (Name_occurrences.empty) fields - | Fabricated_block v -> - Name_occurrences.singleton_variable v Name_mode.normal | Code_and_set_of_closures { code; set_of_closures; } -> let from_set_of_closures = match set_of_closures with @@ -231,11 +227,6 @@ let print_with_cache ~cache ppf t = Tag.Scannable.print tag (Format.pp_print_list ~pp_sep:Format.pp_print_space Field_of_block.print) fields - | Fabricated_block field -> - fprintf ppf "@[@<0>%sFabricated_block@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print field | Code_and_set_of_closures { code; set_of_closures; } -> fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ @[(code@ (%a))@]@ \ @@ -326,8 +317,6 @@ let _invariant env t = match t with | Block (_tag, _mut, fields) -> List.iter (fun field -> Field_of_block.invariant env field) fields - | Fabricated_block field -> - E.check_variable_is_bound_and_of_kind env field K.fabricated | Set_of_closures set -> Flambda.Set_of_closures.invariant env set | Boxed_float (Var v) -> @@ -376,7 +365,6 @@ let apply_name_permutation t perm = in if not !changed then t else Block (tag, mut, fields) - | Fabricated_block _ -> Misc.fatal_error "To be removed" | Code_and_set_of_closures { code; set_of_closures; } -> let code' = Code_id.Map.map_sharing @@ -474,7 +462,6 @@ let get_pieces_of_code t = | Present params_and_body -> Some (params_and_body, newer_version_of) | Deleted -> None) | Block _ - | Fabricated_block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index 4b9f4eb9c55c..8dfd8f225202 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -61,7 +61,6 @@ type code_and_set_of_closures = { with values computed at runtime. *) type t = | Block of Tag.Scannable.t * mutable_or_immutable * (Field_of_block.t list) - | Fabricated_block of Variable.t | Code_and_set_of_closures of code_and_set_of_closures | Boxed_float of Numbers.Float_by_bit_pattern.t or_variable | Boxed_int32 of Int32.t or_variable diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 722c7302044a..020a9692a03d 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -20,6 +20,7 @@ open! Flambda.Import module Env = Un_cps_env module Ece = Effects_and_coeffects +module R = Un_cps_result (* Notes: - an int64 on a 32-bit host is represented across two registers, @@ -47,81 +48,6 @@ let typ_val = Cmm.typ_val let typ_float = Cmm.typ_float let typ_int64 = C.typ_int64 -(* Result for translating a program, - named R instead of Result to avoid shadowing *) -module R = struct - - type t = { - init : Cmm.expression; - current_data : Cmm.data_item list; - other_data : Cmm.data_item list list; - gc_roots : Symbol.t list; - functions : Cmm.phrase list; - } - - let empty = { - init = C.void; - current_data = []; - other_data = []; - gc_roots = []; - functions = []; - } - - let add_if_not_empty x l = - match x with - | [] -> l - | _ :: _ -> x :: l - - let combine r t = { - init = C.sequence r.init t.init; - current_data = []; - other_data = - add_if_not_empty r.current_data ( - add_if_not_empty t.current_data ( - (r.other_data @ t.other_data))); - gc_roots = r.gc_roots @ t.gc_roots; - functions = r.functions @ t.functions; - } - - let archive_data r = - { r with current_data = []; - other_data = add_if_not_empty r.current_data r.other_data; } - - let wrap_init f r = - { r with init = f r.init; } - - let add_data d r = - { r with current_data = d @ r.current_data; } - - let update_data f r = - { r with current_data = f r.current_data; } - - let add_gc_roots l r = - { r with gc_roots = l @ r.gc_roots; } - - let add_function f r = - { r with functions = f :: r.functions; } - - let to_cmm r = - let entry = - let dbg = Debuginfo.none in - let fun_name = Compilenv.make_symbol (Some "entry") in - let fun_codegen = - if Config.flambda then - [ Cmm.Reduce_code_size; - Cmm.No_CSE ] - else - [ Cmm.Reduce_code_size ] - in - let init = C.sequence r.init (C.unit ~dbg) in - C.cfunction (C.fundecl fun_name [] init fun_codegen dbg) - in - let data_list = add_if_not_empty r.current_data r.other_data in - let data = List.map C.cdata data_list in - data, entry, r.gc_roots, r.functions - -end - (* CR gbury: this conversion is potentially unsafe when cross-compiling for a 64-bit machine on a 32-bit host *) let nativeint_of_targetint t = @@ -138,10 +64,6 @@ let name env = function | Name.Var v -> Env.inline_variable env v | Name.Symbol s -> C.symbol (symbol s), env, Ece.pure -let name_static _env = function - | Name.Var v -> `Var v - | Name.Symbol s -> `Data [C.symbol_address (symbol s)] - (* Constants *) let tag_targetint t = Targetint.(add (shift_left t 1) one) @@ -159,22 +81,6 @@ let const _env c = | Naked_int64 i -> C.int64 i | Naked_nativeint t -> C.targetint t -let const_static _env c = - match (c : Simple.Const.t) with - | Naked_immediate i -> - [C.cint (nativeint_of_targetint (targetint_of_imm i))] - | Tagged_immediate i -> - [C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i)))] - | Naked_float f -> - [C.cfloat (Numbers.Float_by_bit_pattern.to_float f)] - | Naked_int32 i -> - [C.cint (Nativeint.of_int32 i)] - | Naked_int64 i -> - if C.arch32 then todo() (* split int64 on 32-bit archs *) - else [C.cint (Int64.to_nativeint i)] - | Naked_nativeint t -> - [C.cint (nativeint_of_targetint t)] - let default_of_kind (k : Flambda_kind.t) = match k with | Value -> C.int 1 @@ -202,11 +108,6 @@ let simple env s = | Name n -> name env n | Const c -> const env c, env, Ece.pure -let simple_static env s = - match (Simple.descr s : Simple.descr) with - | Name n -> name_static env n - | Const c -> `Data (const_static env c) - (* Arithmetic primitives *) let primitive_boxed_int_of_standard_int x = @@ -644,6 +545,35 @@ let decide_inline_let effs v body = | One -> Inline | More_than_one -> Regular +(* Helpers for translating functions *) + +let is_var_used v e = + let free_names = Expr.free_names e in + let occurrence = Name_occurrences.greatest_name_mode_var free_names v in + match (occurrence : Name_mode.Or_absent.t) with + | Absent -> false + | Present _k -> + (* CR mshinwell: I think this should always be [true]. Even if the + variable is only used by phantom bindings, it still needs to be + there. This may only arise in unusual cases (e.g. [my_closure] + that is used only by phantom bindings). *) + true + (* Name_mode.is_normal k *) + +let function_args vars my_closure body = + if is_var_used my_closure body then begin + let param = Parameter.wrap my_closure in + let last_arg = Kinded_parameter.create param Flambda_kind.value in + vars @ [last_arg] + end else + vars + +let function_flags () = + if !Clflags.optimize_for_speed then + [] + else + [ Cmm.Reduce_code_size ] + (* Expressions *) let rec expr env e = @@ -1105,6 +1035,7 @@ and switch env s = the move from the condition register to a regular register). *) wrap (C.ite e ~then_ ~else_) | _ -> + (* CR mshinwell: Don't use polymorphic comparison! *) if Misc.Stdlib.Array.for_alli (=) ints then wrap (C.transl_switch_clambda Location.none e ints exprs) else begin @@ -1182,34 +1113,7 @@ and fill_up_to j acc i = (* Translate a function declaration. *) -let is_var_used v e = - let free_names = Expr.free_names e in - let occurrence = Name_occurrences.greatest_name_mode_var free_names v in - match (occurrence : Name_mode.Or_absent.t) with - | Absent -> false - | Present _k -> - (* CR mshinwell: I think this should always be [true]. Even if the - variable is only used by phantom bindings, it still needs to be - there. This may only arise in unusual cases (e.g. [my_closure] - that is used only by phantom bindings). *) - true - (* Name_mode.is_normal k *) - -let function_args vars my_closure body = - if is_var_used my_closure body then begin - let param = Parameter.wrap my_closure in - let last_arg = Kinded_parameter.create param Flambda_kind.value in - vars @ [last_arg] - end else - vars - -let function_flags () = - if !Clflags.optimize_for_speed then - [] - else - [ Cmm.Reduce_code_size ] - -let params_and_body env fun_name fun_dbg p = +and params_and_body env fun_name fun_dbg p = Function_params_and_body.pattern_match p ~f:(fun ~return_continuation:k k_exn vars ~body ~my_closure -> try @@ -1232,68 +1136,17 @@ let params_and_body env fun_name fun_dbg p = Expr.print body; raise e) -(* Definition *) - -let computation_wrapper env c = - match c with - | None -> - env, (fun x -> x), true - | Some (c : Flambda_unit_body.Computation.t) -> - (* The env for the computation is given a dummy continuation, - since the return continuation will be explicitly bound to a - jump before translating the computation. *) - let dummy_k = Continuation.create () in - let k_exn = Exn_continuation.exn_handler c.exn_continuation in - let c_env = Env.enter_function_def env dummy_k k_exn in - (* The environment for the static structure update must contain the - variables produced by the computation. It is given dummy - continuations, given that the return continuation will not - be used. *) - let s_env = Env.enter_function_def env dummy_k dummy_k in - let s_env, vars = var_list s_env c.computed_values in - (* Wrap the static structure update expression [e] by manually - translating the computation return continuation by a jump to - [e]. In the case of a single-use continuation, using a jump - instead of inlining [e] at the continuation call site does not - change much, since - assuming the continuation is called at the - end of the body - the jump will be erased in linearize. *) - let wrap (e : Cmm.expression) = - let k = c.return_continuation in - let tys = List.map snd vars in - let id, env = Env.add_jump_cont c_env tys k in - let body = expr env c.expr in - C.ccatch - ~rec_flag:false ~body - ~handlers:[C.handler id vars e] - in - s_env, wrap, false - (* CR gbury: for the future, try and rearrange the generated cmm code to move assignments closer to the variable definitions Or better: add traps to the env to insert assignemnts after the variable definitions. *) -let definition env (d : Flambda_unit_body.Definition.t) = - let env, wrapper, is_fully_static = - computation_wrapper env d.computation - in - let env, r = static_structure env is_fully_static d.static_structure in - env, R.wrap_init wrapper r - - -(* Programs *) +(* Note about the root symbol: it does not need any particular treatment. + Concerning gc_roots, it's like any other statically allocated symbol: if it + has an associated computation, then it will already be included in the list + of gc_roots; otherwise it does not *have* to be a root. *) -let rec program_body env acc body = - match Flambda_unit_body.descr body with - | Flambda_unit_body.Root _sym -> - (* The root symbol does not really deserve any particular treatment. - Concerning gc_roots, it's like any other statically allocated symbol: - if if has an associated computation, then it will already be included - in the list of gc_roots, else it does not *have* to be a root. *) - List.fold_left (fun acc r -> R.combine r acc) R.empty acc - | Flambda_unit_body.Definition (def, rest) -> - let env, r = definition env def in - program_body env (r :: acc) rest +(* Compilation units *) (* let program_functions offsets used_closure_vars p = * let aux = function_decl offsets used_closure_vars in @@ -1306,19 +1159,36 @@ let rec program_body env acc body = * in * List.map (fun decl -> C.cfunction decl) sorted *) -let program (unit : Flambda_unit.t) = +let unit (unit : Flambda_unit.t) = Profile.record_call "flambda2_to_cmm" (fun () -> let offsets = Un_cps_closure.compute_offsets unit in let used_closure_vars = Flambda_unit.used_closure_vars unit in - Name_occurrences.closure_vars (Flambda_unit.free_names unit) - in let dummy_k = Continuation.create () in - let env = Env.mk offsets dummy_k dummy_k used_closure_vars in + (* The dummy continuation is passed here since we're going to manually + arrange that the return continuation turns into "return unit". + (Module initialisers return the unit value). *) + let env = + Env.mk offsets dummy_k + (Flambda_unit.exn_continuation unit) + used_closure_vars + in + let return_cont, env = Env.add_jump_cont c_env tys k in (* let functions = program_functions offsets used_closure_vars unit in *) let res = program_body env [] unit.body in + let return_cont_params = + var_list env [ + Kinded_parameter.create (Parameter.wrap (Variable.create "*ret*")) + Flambda_kind.value; + ] + in + let res = + let unit_value = C.targetint Targetint.zero in + C.ccatch + ~rec_flag:false ~body + ~handlers:[C.handler return_cont return_cont_params unit_value] + in let data, entry, gc_roots, functions = R.to_cmm res in let cmm_data = C.flush_cmmgen_state () in let roots = List.map symbol gc_roots in (C.gc_root_table roots) :: data @ cmm_data @ functions @ [entry] ) - diff --git a/middle_end/flambda2.0/to_cmm/un_cps.mli b/middle_end/flambda2.0/to_cmm/un_cps.mli index ce9186015cb1..698f9bf0842c 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps.mli @@ -14,6 +14,6 @@ (* Translate Flambda compilation units into Cmm *) -val program : Flambda_unit.t -> Cmm.phrase list +val unit : Flambda_unit.t -> Cmm.phrase list (** Translate a compilation unit. *) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml index 742104f271f0..0e2d8cc13d84 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml @@ -563,114 +563,6 @@ module Greedy = struct end -(* Iter on all sets of closures of a given program. *) - -module Iter_on_sets_of_closures = struct - - let rec expr f e = - match (Expr.descr e : Expr.descr) with - | Let e' -> let_expr f e' - | Let_cont e' -> let_cont f e' - | Apply e' -> apply_expr f e' - | Apply_cont e' -> apply_cont f e' - | Switch e' -> switch f e' - | Invalid e' -> invalid f e' - - and named f n = - match (n : Named.t) with - | Simple _ | Prim _ -> () - | Set_of_closures s -> - f None s - - and let_expr f t = - Let.pattern_match t ~f:(fun ~bound_vars:_ ~body -> - let e = Let.defining_expr t in - named f e; - expr f body - ) - - and let_cont f = function - | Let_cont.Non_recursive { handler; _ } -> - Non_recursive_let_cont_handler.pattern_match handler ~f:(fun k ~body -> - let h = Non_recursive_let_cont_handler.handler handler in - let_cont_aux f k h body - ) - | Let_cont.Recursive handlers -> - Recursive_let_cont_handlers.pattern_match handlers ~f:(fun ~body conts -> - assert (not (Continuation_handlers.contains_exn_handler conts)); - let_cont_rec f conts body - ) - - and let_cont_aux f k h body = - continuation_handler f k h; - expr f body - - and let_cont_rec f conts body = - let map = Continuation_handlers.to_map conts in - Continuation.Map.iter (continuation_handler f) map; - expr f body - - and continuation_handler f _ h = - let h = Continuation_handler.params_and_handler h in - Continuation_params_and_handler.pattern_match h ~f:(fun _ ~handler -> - expr f handler - ) - - (* Expression application, continuation application and Switches - only use single expressions and continuations, so no sets_of_closures - can syntatically appear inside. *) - and apply_expr _ _ = () - - and apply_cont _ _ = () - - and switch _ _ = () - - and invalid _ _ = () - - (* and fun_decl _f _ _decl = assert false (\* FIXME Let code *\) *) -(* - let t = Function_declaration.params_and_body decl in - Function_params_and_body.pattern_match t - ~f:(fun ~return_continuation:_ _exn_k _args ~body ~my_closure:_ -> - expr f body - ) -*) - - let computation f c = - Flambda_unit_body.Computation.iter_expr c ~f:(expr f) - - let static_structure_aux f - ((S (symbs, st)) : Flambda_unit_body.Static_structure.t0) = - match symbs, st with - | Code_and_set_of_closures { code_ids = _; closure_symbols; }, - Code_and_set_of_closures { code; set_of_closures = s; } -> - Option.iter (fun s -> f (Some closure_symbols) s) s; - Code_id.Map.iter (fun _ { Flambda_static.Static_part.params_and_body; - newer_version_of = _; } -> - match params_and_body with - | Deleted -> () - | Present params_and_body -> - Function_params_and_body.pattern_match params_and_body - ~f:(fun ~return_continuation:_ _ _ ~body ~my_closure:_ -> - expr f body)) - code - | _ -> () - - let static_structure f s = - List.iter (static_structure_aux f) s - - let definition f (d : Flambda_unit_body.Definition.t) = - Flambda_unit_body.Definition.iter_computation d ~f:(computation f); - static_structure f d.static_structure - - let body f b = - Flambda_unit_body.iter_definitions b ~f:(definition f) - - let program f t = - Flambda_unit.iter_body t ~f:(body f) - -end - let compute_offsets program = let state = ref Greedy.empty_state in let used_closure_vars = Flambda_unit.used_closure_vars unit in diff --git a/middle_end/flambda2.0/to_cmm/un_cps_result.ml b/middle_end/flambda2.0/to_cmm/un_cps_result.ml new file mode 100644 index 000000000000..ae020b50e62d --- /dev/null +++ b/middle_end/flambda2.0/to_cmm/un_cps_result.ml @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2019--2019 OCamlPro SAS *) +(* *) +(* 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-30-40-41-42"] + +module C = struct + include Cmm_helpers + include Un_cps_helper +end + +type t = { + init : Cmm.expression; + current_data : Cmm.data_item list; + other_data : Cmm.data_item list list; + gc_roots : Symbol.t list; + functions : Cmm.phrase list; +} + +let empty = { + init = C.void; + current_data = []; + other_data = []; + gc_roots = []; + functions = []; +} + +let add_if_not_empty x l = + match x with + | [] -> l + | _ :: _ -> x :: l + +let combine r t = { + init = C.sequence r.init t.init; + current_data = []; + other_data = + add_if_not_empty r.current_data ( + add_if_not_empty t.current_data ( + (r.other_data @ t.other_data))); + gc_roots = r.gc_roots @ t.gc_roots; + functions = r.functions @ t.functions; +} + +let archive_data r = + { r with current_data = []; + other_data = add_if_not_empty r.current_data r.other_data; } + +let wrap_init f r = + { r with init = f r.init; } + +let add_data d r = + { r with current_data = d @ r.current_data; } + +let update_data f r = + { r with current_data = f r.current_data; } + +let add_gc_roots l r = + { r with gc_roots = l @ r.gc_roots; } + +let add_function f r = + { r with functions = f :: r.functions; } + +let to_cmm r = + let entry = + let dbg = Debuginfo.none in + let fun_name = Compilenv.make_symbol (Some "entry") in + let fun_codegen = + if Config.flambda then + [ Cmm.Reduce_code_size; + Cmm.No_CSE ] + else + [ Cmm.Reduce_code_size ] + in + let init = C.sequence r.init (C.unit ~dbg) in + C.cfunction (C.fundecl fun_name [] init fun_codegen dbg) + in + let data_list = add_if_not_empty r.current_data r.other_data in + let data = List.map C.cdata data_list in + data, entry, r.gc_roots, r.functions diff --git a/middle_end/flambda2.0/to_cmm/un_cps_result.mli b/middle_end/flambda2.0/to_cmm/un_cps_result.mli new file mode 100644 index 000000000000..f8dccc32993d --- /dev/null +++ b/middle_end/flambda2.0/to_cmm/un_cps_result.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2019--2019 OCamlPro SAS *) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Result accumulator structure used during Flambda to Cmm translation. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +type t + +(* CR mshinwell: Put [t] arguments first. *) + +val empty : t + +val combine : t -> t -> t + +val archive_data : t -> t + +val wrap_init : (Cmm.expression -> Cmm.expression) -> t -> t + +val add_data : Cmm.data_item list -> t -> t + +val update_data : (Cmm.data_item list -> Cmm.data_item list) -> t -> t + +val add_gc_roots : Symbol.t list -> t -> t + +val add_function : Cmm.phrase -> t -> t + +(* CR mshinwell: Use a "private" record for the return type of this. *) +val to_cmm + : t + -> Cmm.phrase list * Cmm.phrase * (Symbol.t list) * (Cmm.phrase list) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.ml b/middle_end/flambda2.0/to_cmm/un_cps_static.ml index 989196494737..b30498d95e16 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_static.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.ml @@ -16,10 +16,65 @@ open! Flambda.Import +module C = struct + include Cmm_helpers + include Un_cps_helper +end + module Bound_symbols = Let_symbol.Bound_symbols module Env = Un_cps_env -module Ece = Effects_and_coeffects module SC = Flambda.Static_const +module R = Un_cps_result + +(* CR mshinwell: Share these next functions with Un_cps. Unfortunately + there's a name clash with at least one of them ("symbol") with functions + already in Un_cps_helper. *) +let symbol s = + Linkage_name.to_string (Symbol.linkage_name s) + +let tag_targetint t = Targetint.(add (shift_left t 1) one) + +let targetint_of_imm i = Targetint.OCaml.to_targetint i.Immediate.value + +let nativeint_of_targetint t = + match Targetint.repr t with + | Int32 i -> Nativeint.of_int32 i + | Int64 i -> Int64.to_nativeint i + +let filter_closure_vars env s = + let used_closure_vars = Env.used_closure_vars env in + let aux clos_var _bound_to = + Var_within_closure.Set.mem clos_var used_closure_vars + in + Var_within_closure.Map.filter aux s + +let todo () = failwith "Not yet implemented" +(* ----- End of functions to share ----- *) + +let name_static _env = function + | Name.Var v -> `Var v + | Name.Symbol s -> `Data [C.symbol_address (symbol s)] + +let const_static _env c = + match (c : Simple.Const.t) with + | Naked_immediate i -> + [C.cint (nativeint_of_targetint (targetint_of_imm i))] + | Tagged_immediate i -> + [C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i)))] + | Naked_float f -> + [C.cfloat (Numbers.Float_by_bit_pattern.to_float f)] + | Naked_int32 i -> + [C.cint (Nativeint.of_int32 i)] + | Naked_int64 i -> + if C.arch32 then todo() (* split int64 on 32-bit archs *) + else [C.cint (Int64.to_nativeint i)] + | Naked_nativeint t -> + [C.cint (nativeint_of_targetint t)] + +let simple_static env s = + match (Simple.descr s : Simple.descr) with + | Name n -> name_static env n + | Const c -> `Data (const_static env c) let static_value _env v = match (v : SC.Field_of_block.t) with @@ -46,7 +101,7 @@ let make_update env kind symb var i = let rec static_block_updates symb env acc i = function | [] -> List.fold_left C.sequence C.void acc | sv :: r -> - begin match (sv : Flambda_static.Of_kind_value.t) with + begin match (sv : SC.Field_of_block.t) with | Symbol _ | Tagged_immediate _ -> static_block_updates symb env acc (i + 1) r @@ -172,7 +227,7 @@ and fill_static_up_to j acc i = if i = j then acc else fill_static_up_to j (C.cint 1n :: acc) (i + 1) -let static_const0 env (bound_symbols : Bound_symbols.t) +let static_const0 env r ~params_and_body (bound_symbols : Bound_symbols.t) (static_const : Static_const.t) = match bound_symbols, static_const with | Singleton s, Block (tag, _mut, fields) -> @@ -221,7 +276,8 @@ let static_const0 env (bound_symbols : Bound_symbols.t) in (* CR vlaviron: fix debug info *) let fundecl = - C.cfunction (params_and_body updated_env fun_name Debuginfo.none p) + C.cfunction (params_and_body updated_env fun_name + Debuginfo.none p) in R.add_function fundecl r) code @@ -277,7 +333,7 @@ let static_const0 env (bound_symbols : Bound_symbols.t) [Code_and_set_of_closures] binding:@ %a" SC.print static_const -let static_const env (bound_symbols : Bound_symbols.t) +let static_const env ~params_and_body (bound_symbols : Bound_symbols.t) (static_const : Static_const.t) = (* Gc roots: statically allocated blocks themselves do not need to be scanned, however if statically allocated blocks contain dynamically allocated @@ -288,10 +344,12 @@ let static_const env (bound_symbols : Bound_symbols.t) fully_static). *) let roots = if Static_const.is_fully_static static_const then [] - else Symbol.Set.elements (Bound_symbols.being_defined s) + else Symbol.Set.elements (Bound_symbols.being_defined bound_symbols) in let r = R.add_gc_roots roots R.empty in - let env, r = static_const0 env bound_symbols static_const in + let env, r = + static_const0 env r ~params_and_body bound_symbols static_const + in (* [R.archive_data] helps keep definitions of separate symbols in different [data_item] lists and this increases readability of the generated Cmm. *) env, R.archive_data r diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.mli b/middle_end/flambda2.0/to_cmm/un_cps_static.mli index 9a37d1ad2627..0b8669a307e5 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_static.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.mli @@ -17,3 +17,15 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] open! Flambda.Import + +val static_const + : Un_cps_env.t + -> params_and_body:( + Un_cps_env.t + -> string + -> Debuginfo.t + -> Flambda.Function_params_and_body.t + -> Cmm.fundecl) + -> Let_symbol.Bound_symbols.t + -> Static_const.t + -> Un_cps_env.t * Un_cps_result.t From 4364f71edd006a62f9eff3012d01b9bdf0174659 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 16:47:33 +0000 Subject: [PATCH 16/80] terms --- asmcomp/asmgen.ml | 4 ++-- middle_end/flambda2.0/terms/flambda.mli | 11 ++++++++++- middle_end/flambda2.0/terms/flambda_unit.ml | 2 +- middle_end/flambda2.0/terms/flambda_unit.mli | 4 ++++ middle_end/flambda2.0/to_cmm/un_cps.ml | 20 ++++++++++++++++---- 5 files changed, 33 insertions(+), 8 deletions(-) diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 4c03ed59d834..840633d7ccac 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -203,7 +203,7 @@ let compile_implementation2 ?toplevel ~backend ~filename ~prefixname (middle_end : middle_end2) ~backend ~module_block_size_in_words ~filename ~prefixname ~ppf_dump ~module_ident ~module_initializer in - end_gen_implementation ?toplevel ~ppf_dump Un_cps.program + end_gen_implementation ?toplevel ~ppf_dump Un_cps.unit translated_program) let compile_implementation_flambda ?toplevel ~prefixname @@ -217,7 +217,7 @@ let compile_implementation_flambda ?toplevel ~prefixname (fun () -> Ident.Set.iter Compilenv.require_global required_globals; end_gen_implementation ?toplevel ~ppf_dump - Un_cps.program program) + Un_cps.unit program) (* Error report *) diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index 0a38d5906bda..ff3d1f9162a6 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -50,7 +50,8 @@ module rec Expr : sig | Let_symbol of Let_symbol_expr.t (** Bind code and/or data symbol(s). This form of expression is only allowed in certain "toplevel" contexts. The bound symbols are not - treated up to alpha conversion. *) + treated up to alpha conversion; each such bound symbol must be + unique. *) | Let_cont of Let_cont_expr.t (** Define one or more continuations. *) | Apply of Apply.t @@ -67,6 +68,7 @@ module rec Expr : sig (** Extract the description of an expression. *) val descr : t -> descr + (** What happened when a [Let]-expression was created. *) type let_creation_result = private | Have_deleted of Named.t | Nothing_deleted @@ -88,6 +90,8 @@ module rec Expr : sig (such as is required to bind a [Set_of_closures]). *) val create_pattern_let : Bindable_let_bound.t -> Named.t -> t -> t + (** Create a [Let_symbol] expression that binds a statically-allocated + value to a symbol. *) val create_let_symbol : Let_symbol_expr.t -> t (** Create an application expression. *) @@ -96,6 +100,7 @@ module rec Expr : sig (** Create a continuation application (in the zero-arity case, "goto"). *) val create_apply_cont : Apply_cont.t -> t + (** What happened when a [Switch]-expression was created. *) type switch_creation_result = private | Have_deleted_comparison_but_not_branch | Have_deleted_comparison_and_branch @@ -533,10 +538,14 @@ end and Static_const : sig include Contains_names.S with type t := t + (** Return all pieces of code defined by the given term. *) val get_pieces_of_code : t -> (Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t + (** Returns [true] iff the given term does not contain any variables, + which means that the corresponding value can be statically allocated, + without any need to patch it afterwards. *) val is_fully_static : t -> bool end diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index 92fe1f1271f7..b4c8ca7203c9 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -54,7 +54,7 @@ let print ppf Symbol.print root_symbol Continuation.print return_continuation Continuation.print exn_continuation - Flambda.Expr.print t.body + Flambda.Expr.print body let invariant _t = () diff --git a/middle_end/flambda2.0/terms/flambda_unit.mli b/middle_end/flambda2.0/terms/flambda_unit.mli index af2c7cc43cab..e9a4e7047902 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.mli +++ b/middle_end/flambda2.0/terms/flambda_unit.mli @@ -35,6 +35,10 @@ val create -> body:Flambda.Expr.t -> t +val return_continuation : t -> Continuation.t + +val exn_continuation : t -> Continuation.t + (** All closure variables used in the given unit. *) val used_closure_vars : t -> Var_within_closure.Set.t diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 020a9692a03d..9438a6834200 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -579,6 +579,7 @@ let function_flags () = let rec expr env e = match (Expr.descr e : Expr.descr) with | Let e' -> let_expr env e' + | Let_symbol e' -> let_symbol env e' | Let_cont e' -> let_cont env e' | Apply e' -> apply_expr env e' | Apply_cont e' -> apply_cont env e' @@ -609,6 +610,15 @@ and let_expr env t = Let.print t ) +and let_symbol env let_sym = + let body = Let_symbol.body let_sym in + let env, r = + Un_cps_static.static_const env ~params_and_body + (Let_symbol.bound_symbols let_sym) + (Let_symbol.defining_expr let_sym) + in + expr env body + and let_set_of_closures env body closure_vars soc = (* First translate the set of closures, and bind it in the env *) let csoc, env, effs = set_of_closures env soc in @@ -1172,15 +1182,17 @@ let unit (unit : Flambda_unit.t) = (Flambda_unit.exn_continuation unit) used_closure_vars in - let return_cont, env = Env.add_jump_cont c_env tys k in - (* let functions = program_functions offsets used_closure_vars unit in *) - let res = program_body env [] unit.body in - let return_cont_params = + let _env, return_cont_params = var_list env [ Kinded_parameter.create (Parameter.wrap (Variable.create "*ret*")) Flambda_kind.value; ] in + let return_cont, env = + Env.add_jump_cont env (List.map snd return_cont_params) k + in + (* let functions = program_functions offsets used_closure_vars unit in *) + let res = program_body env [] unit.body in let res = let unit_value = C.targetint Targetint.zero in C.ccatch From a1a8ea2d8c31f5a505f2e7d59560a9bab9b4ae67 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 31 Dec 2019 16:57:34 +0000 Subject: [PATCH 17/80] terms --- .../simplify/simplify_static_const.rec.mli | 9 ++-- .../simplify/typing_helpers/reification.ml | 17 ++++--- middle_end/flambda2.0/terms/flambda_unit.ml | 44 +++++++++---------- middle_end/flambda2.0/terms/flambda_unit.mli | 7 +++ middle_end/flambda2.0/to_cmm/un_cps.ml | 7 +-- .../flambda2.0/to_cmm/un_cps_closure.ml | 6 +-- 6 files changed, 47 insertions(+), 43 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli index cd1cb21e7328..5d54108c6094 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli @@ -27,10 +27,11 @@ val simplify_set_of_closures0 -> Flambda.Set_of_closures.t * Downwards_acc.t * Flambda_type.t Symbol.Map.t - * Flambda_static.Program_body.Static_structure.t + * Flambda.Let_symbol_expr.Bound_symbols.t + * Static_const.t val simplify_static_const - : Simplify_env_and_result.Downwards_acc.t - -> Let_symbol_expr.Bound_symbols.t + : Downwards_acc.t + -> Flambda.Let_symbol_expr.Bound_symbols.t -> Static_const.t - -> Static_const.t * Simplify_env_and_result.Downwards_acc.t + -> Static_const.t * Downwards_acc.t diff --git a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml b/middle_end/flambda2.0/simplify/typing_helpers/reification.ml index 4d602d91feb5..2a268fe8bb7c 100644 --- a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml +++ b/middle_end/flambda2.0/simplify/typing_helpers/reification.ml @@ -18,13 +18,12 @@ open! Simplify_import -let create_static_part (to_lift : T.to_lift) - : K.value Flambda_static.Static_part.t = +let create_static_const (to_lift : T.to_lift) : Static_const.t = match to_lift with | Immutable_block (tag, fields) -> let of_kind_values = List.map (fun (field : T.var_or_symbol_or_tagged_immediate) - : Flambda_static.Of_kind_value.t -> + : Static_const.Field_of_block.t -> match field with | Var var -> Dynamically_computed var | Symbol sym -> Symbol sym @@ -37,7 +36,7 @@ let create_static_part (to_lift : T.to_lift) | Boxed_int64 i -> Boxed_int64 (Const i) | Boxed_nativeint i -> Boxed_nativeint (Const i) -let lift dacc ty ~bound_to static_part = +let lift dacc ty ~bound_to static_const = let symbol = Symbol.create (Compilation_unit.get_current_exn ()) (Linkage_name.create (Variable.unique_name bound_to)) @@ -50,9 +49,9 @@ let lift dacc ty ~bound_to static_part = end; let dacc = DA.map_r dacc ~f:(fun r -> - Definition.singleton_symbol symbol static_part - |> Lifted_constant.create (DA.denv dacc) - ~types_of_symbols:(Symbol.Map.singleton symbol ty) + Lifted_constant.create (DA.denv dacc) + (Singleton symbol) static_const + ~types_of_symbols:(Symbol.Map.singleton symbol ty) |> R.new_lifted_constant r) in let symbol' = Simple.symbol symbol in @@ -79,8 +78,8 @@ let try_to_reify dacc (term : Reachable.t) ~bound_to = match T.reify (DE.typing_env denv) ~min_name_mode:occ_kind ty with | Lift to_lift -> if Name_mode.is_normal occ_kind then - let static_part = create_static_part to_lift in - lift dacc ty ~bound_to static_part + let static_const = create_static_const to_lift in + lift dacc ty ~bound_to static_const else term, dacc, ty | Simple simple -> diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index b4c8ca7203c9..6c6bbe7c8592 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -16,6 +16,8 @@ [@@@ocaml.warning "+a-30-40-41-42"] +open! Flambda.Import + type t = { imported_symbols : Flambda_kind.t Symbol.Map.t; root_symbol : Symbol.t; @@ -62,12 +64,12 @@ let used_closure_vars t = Name_occurrences.closure_vars (Flambda.Expr.free_names t.body) (* Iter on all sets of closures of a given program. *) - -module Iter_on_sets_of_closures = struct - +(* CR mshinwell: These functions should be pushed directly into [Flambda] *) +module Iter_sets_of_closures = struct let rec expr f e = match (Expr.descr e : Expr.descr) with | Let e' -> let_expr f e' + | Let_symbol e' -> let_symbol f e' | Let_cont e' -> let_cont f e' | Apply e' -> apply_expr f e' | Apply_cont e' -> apply_cont f e' @@ -87,6 +89,11 @@ module Iter_on_sets_of_closures = struct expr f body ) + and let_symbol_expr f let_sym = + static_const f (Let_symbol.bound_symbols let_sym) + (Let_symbol.defining_expr let_sym); + expr f (Let_symbol.body) + and let_cont f = function | Let_cont.Non_recursive { handler; _ } -> Non_recursive_let_cont_handler.pattern_match handler ~f:(fun k ~body -> @@ -134,12 +141,10 @@ module Iter_on_sets_of_closures = struct ) *) - let computation f c = - Flambda_unit_body.Computation.iter_expr c ~f:(expr f) - - let static_structure_aux f - ((S (symbs, st)) : Flambda_unit_body.Static_structure.t0) = - match symbs, st with + and static_const f + (bound_symbols : Let_symbol.Bound_symbols.t) + (static_const : Static_const.t) = + match bound_symbols, st with | Code_and_set_of_closures { code_ids = _; closure_symbols; }, Code_and_set_of_closures { code; set_of_closures = s; } -> Option.iter (fun s -> f (Some closure_symbols) s) s; @@ -152,19 +157,10 @@ module Iter_on_sets_of_closures = struct ~f:(fun ~return_continuation:_ _ _ ~body ~my_closure:_ -> expr f body)) code - | _ -> () - - let static_structure f s = - List.iter (static_structure_aux f) s - - let definition f (d : Flambda_unit_body.Definition.t) = - Flambda_unit_body.Definition.iter_computation d ~f:(computation f); - static_structure f d.static_structure - - let body f b = - Flambda_unit_body.iter_definitions b ~f:(definition f) - - let program f t = - Flambda_unit.iter_body t ~f:(body f) - + | _ -> + (* CR mshinwell: Make exhaustive and cause errors on wrong cases *) + () end + +let iter_sets_of_closures t ~f = + Iter_sets_of_closures.expr f t.body diff --git a/middle_end/flambda2.0/terms/flambda_unit.mli b/middle_end/flambda2.0/terms/flambda_unit.mli index e9a4e7047902..9c2e74bb7bf3 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.mli +++ b/middle_end/flambda2.0/terms/flambda_unit.mli @@ -50,3 +50,10 @@ val imported_symbols : t -> Flambda_kind.t Symbol.Map.t val root_symbol : t -> Symbol.t val body : t -> Flambda.Expr.t + +val iter_sets_of_closures + : t + -> f:(closure_symbols:Symbol.t Closure_id.Map.t option + -> Flambda.Set_of_closures.t + -> unit) + -> unit diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 9438a6834200..5d6bca094c27 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -1189,11 +1189,12 @@ let unit (unit : Flambda_unit.t) = ] in let return_cont, env = - Env.add_jump_cont env (List.map snd return_cont_params) k + Env.add_jump_cont env (List.map snd return_cont_params) + (Flambda_unit.return_continuation unit) in (* let functions = program_functions offsets used_closure_vars unit in *) - let res = program_body env [] unit.body in - let res = + let body = expr env unit.body in + let body = let unit_value = C.targetint Targetint.zero in C.ccatch ~rec_flag:false ~body diff --git a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml index 0e2d8cc13d84..06b56adf8f2e 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_closure.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_closure.ml @@ -563,13 +563,13 @@ module Greedy = struct end -let compute_offsets program = +let compute_offsets unit = let state = ref Greedy.empty_state in let used_closure_vars = Flambda_unit.used_closure_vars unit in - let aux _ s = + let aux ~closure_symbols:_ s = state := Greedy.create_slots_for_set !state used_closure_vars s in - Iter_on_sets_of_closures.program aux program; + Flambda_unit.iter_sets_of_closures unit ~f:aux; Greedy.finalize !state From b99557157f4f5093bc8e5ec69d6af81134ba15b7 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 10:26:38 +0000 Subject: [PATCH 18/80] terms --- middle_end/flambda2.0/simplify/dune | 2 + .../env/simplify_env_and_result_intf.ml | 2 + middle_end/flambda2.0/simplify/rec_modules | 1 + .../flambda2.0/simplify/simplify_expr.rec.ml | 70 ++++++------- .../flambda2.0/simplify/simplify_import.ml | 2 + .../flambda2.0/simplify/simplify_import.mli | 2 + .../flambda2.0/simplify/simplify_named.rec.ml | 14 +-- .../simplify/simplify_static_const.rec.ml | 97 ++++++++++--------- .../simplify/simplify_static_const.rec.mli | 2 +- .../simplify/template/simplify.templ.ml | 9 +- middle_end/flambda2.0/terms/flambda_unit.ml | 17 ++-- middle_end/flambda2.0/to_cmm/un_cps.ml | 14 ++- middle_end/flambda2.0/to_cmm/un_cps_result.ml | 1 + 13 files changed, 123 insertions(+), 110 deletions(-) diff --git a/middle_end/flambda2.0/simplify/dune b/middle_end/flambda2.0/simplify/dune index 8fd019344ba2..ede5ea17a29c 100644 --- a/middle_end/flambda2.0/simplify/dune +++ b/middle_end/flambda2.0/simplify/dune @@ -6,8 +6,10 @@ simplify_expr.rec.ml simplify_named.rec.ml simplify_static_const.rec.ml + simplify_toplevel.rec.ml simplify_expr.rec.mli simplify_named.rec.mli + simplify_toplevel.rec.mli simplify_static_const.rec.mli ) (action (run ../scripts/assemble_rec_modules.sh diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index 2d140ac60b4c..7ff930664991 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -138,6 +138,8 @@ module type Downwards_env = sig -> params_and_body:Function_params_and_body.t -> t + val mem_code : t -> Code_id.t -> bool + val find_code : t -> Code_id.t -> Function_params_and_body.t (** Appends the locations of inlined call-sites to the given debuginfo diff --git a/middle_end/flambda2.0/simplify/rec_modules b/middle_end/flambda2.0/simplify/rec_modules index e376aeedbf78..39fd46e3af36 100644 --- a/middle_end/flambda2.0/simplify/rec_modules +++ b/middle_end/flambda2.0/simplify/rec_modules @@ -1,3 +1,4 @@ simplify_expr.rec.ml simplify_named.rec.ml simplify_static_const.rec.ml +simplify_toplevel.rec.ml diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index f5d812e0395f..71b99ba07436 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -42,7 +42,7 @@ let rec simplify_let and simplify_let_symbol : 'a. DA.t -> Let_symbol.t -> 'a k -> Expr.t * 'a * UA.t = fun dacc let_symbol_expr k -> - let module LS = Flambda.Let_symbol in + let module LS = Let_symbol in if not (DE.at_unit_toplevel (DA.denv dacc)) then begin Misc.fatal_errorf "[Let_symbol] is only allowed at the toplevel of \ compilation units (not even at the toplevel of function bodies):@ %a" @@ -57,19 +57,20 @@ and simplify_let_symbol end) (LS.Bound_symbols.being_defined bound_symbols); Code_id.Set.iter (fun code_id -> - if DE.mem_code_id (DA.denv dacc) code_id then begin + if DE.mem_code (DA.denv dacc) code_id then begin Misc.fatal_errorf "Code ID %a is already defined:@ %a" - Code_id.print sym + Code_id.print code_id LS.print let_symbol_expr end) (LS.Bound_symbols.code_being_defined bound_symbols); let defining_expr = LS.defining_expr let_symbol_expr in let body = LS.body let_symbol_expr in - let static_const, dacc = + let bound_symbols, defining_expr, dacc = Simplify_static_const.simplify_static_const dacc bound_symbols defining_expr in (* XXX Retrieve and add lifted constants here (some of which may need to go in [defining_expr]. *) + let bindings_outermost_first = [bound_symbols, defining_expr] in let body, user_data, uacc = simplify_expr dacc body k in (* XXX This should do the deletion of the [Let_symbol], since we need the code age relation to do that. *) @@ -81,30 +82,29 @@ and simplify_let_symbol in expr, user_data, uacc -and simplify_one_continuation_handler - : 'a. bool -> DA.t - -> extra_params_and_args:Continuation_extra_params_and_args.t - -> Continuation.t - -> Continuation_handler.Opened.t - -> user_data:unit - -> 'a k - -> Continuation_handler.t * 'a * UA.t -= fun is_recursive dacc ~(extra_params_and_args : EPA.t) - cont (cont_handler : Continuation_handler.Opened.t) ~user_data:() k -> - let module CH = Continuation_handler in - let module CPH = Continuation_params_and_handler in +and simplify_one_continuation_handler : + 'a. DA.t + -> Continuation.t + -> Recursive.t + -> CH.t + -> params:KP.t list + -> handler:Expr.t + -> extra_params_and_args:Continuation_extra_params_and_args.t + -> 'a k + -> Continuation_handler.t * 'a * UA.t += fun dacc cont (recursive : Recursive.t) (cont_handler : CH.t) ~params + ~(handler : Expr.t) ~(extra_params_and_args : EPA.t) k -> (* Format.eprintf "handler:@.%a@." Expr.print cont_handler.handler; *) - let params = cont_handler.params in (* Format.eprintf "About to simplify handler %a, params %a, EPA %a\n%!" Continuation.print cont KP.List.print params EPA.print extra_params_and_args; *) - let handler, user_data, uacc = simplify_expr dacc cont_handler.handler k in + let handler, user_data, uacc = simplify_expr dacc handler k in let handler, uacc = (* let () = @@ -116,8 +116,9 @@ Format.eprintf "About to simplify handler %a, params %a, EPA %a\n%!" let used_params = (* Removal of unused parameters of recursive continuations is not currently supported. *) - if is_recursive then params - else + match recursive with + | Recursive -> params + | Non_recursive -> let first = ref true in List.filter (fun param -> (* CR mshinwell: We should have a robust means of propagating which @@ -150,8 +151,7 @@ Format.eprintf "About to simplify handler %a, params %a, EPA %a\n%!" *) let handler = let params = used_params @ used_extra_params in - CH.with_params_and_handler (CH.Opened.original cont_handler) - (CPH.create params ~handler) + CH.with_params_and_handler cont_handler (CPH.create params ~handler) in let rewrite = Apply_cont_rewrite.create ~original_params:params @@ -203,9 +203,9 @@ and simplify_non_recursive_let_cont_handler let body, handler, user_data, uacc = let body, (result, uenv', user_data), uacc = let scope = DE.get_continuation_scope_level (DA.denv dacc) in + let params_and_handler = CH.params_and_handler cont_handler in let is_exn_handler = CH.is_exn_handler cont_handler in - CH.pattern_match cont_handler ~f:(fun handler -> - let params = CH.Opened.params handler in + CPH.pattern_match params_and_handler ~f:(fun params ~handler -> let denv = DE.define_parameters (DA.denv dacc) ~params in let dacc = DA.with_denv dacc (DE.increment_continuation_scope_level denv) @@ -265,8 +265,8 @@ and simplify_non_recursive_let_cont_handler in try let handler, user_data, uacc = - simplify_one_continuation_handler dacc - ~extra_params_and_args cont handler ~user_data k + simplify_one_continuation_handler dacc cont Non_recursive + cont_handler ~params ~handler ~extra_params_and_args k in handler, user_data, uacc, is_single_inlinable_use with Misc.Fatal_error -> begin @@ -305,7 +305,7 @@ and simplify_non_recursive_let_cont_handler | Unknown { arity; } -> let can_inline = if is_single_inlinable_use && (not is_exn_handler) then - CH.real_handler handler + Some handler else None in @@ -342,12 +342,13 @@ and simplify_recursive_let_cont_handlers let handlers = Continuation_handlers.to_map rec_handlers in let cont, cont_handler = match Continuation.Map.bindings handlers with - | [] | _ :: _ :: _ -> failwith "TODO" (* CR mshinwell: fix this *) + | [] | _ :: _ :: _ -> + Misc.fatal_errorf "Support for simplification of multiply-recursive \ + continuations is not yet implemented" | [c] -> c - (* Only single continuation handler is supported right now *) in - CH.pattern_match cont_handler ~f:(fun cont_handler -> - let params = CH.Opened.params cont_handler in + let params_and_handler = CH.params_and_handler cont_handler in + CPH.pattern_match params_and_handler ~f:(fun params ~handler -> let arity = KP.List.arity params in let dacc = DA.map_denv dacc ~f:DE.increment_continuation_scope_level @@ -379,12 +380,10 @@ and simplify_recursive_let_cont_handlers in let dacc = DA.create denv cont_uses_env r in let handler, user_data, uacc = - simplify_one_continuation_handler true dacc + simplify_one_continuation_handler dacc cont Recursive + cont_handler ~params ~handler ~extra_params_and_args: Continuation_extra_params_and_args.empty - cont - cont_handler - ~user_data:() (fun cont_uses_env r -> let user_data, uacc = k cont_uses_env r in let uacc = @@ -1408,6 +1407,7 @@ and simplify_expr = fun dacc expr k -> match Expr.descr expr with | Let let_expr -> simplify_let dacc let_expr k + | Let_symbol let_symbol -> simplify_let_symbol dacc let_symbol k | Let_cont let_cont -> simplify_let_cont dacc let_cont k | Apply apply -> simplify_apply dacc apply k | Apply_cont apply_cont -> simplify_apply_cont dacc apply_cont k diff --git a/middle_end/flambda2.0/simplify/simplify_import.ml b/middle_end/flambda2.0/simplify/simplify_import.ml index e6c059bca771..1e2b766bc3cb 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.ml +++ b/middle_end/flambda2.0/simplify/simplify_import.ml @@ -27,6 +27,7 @@ module Function_declarations = Flambda.Function_declarations module Function_params_and_body = Flambda.Function_params_and_body module Let_cont = Flambda.Let_cont module Let = Flambda.Let +module Let_symbol = Flambda.Let_symbol_expr module Lifted_constant = Simplify_env_and_result.Lifted_constant module Named = Flambda.Named module Non_recursive_let_cont_handler = Flambda.Non_recursive_let_cont_handler @@ -36,6 +37,7 @@ module Static_const = Flambda.Static_const module Switch = Flambda.Switch module CH = Continuation_handler +module CPH = Continuation_params_and_handler module CUE = Continuation_uses_env module DA = Downwards_acc module DE = Simplify_env_and_result.Downwards_env diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index e6c059bca771..1e2b766bc3cb 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -27,6 +27,7 @@ module Function_declarations = Flambda.Function_declarations module Function_params_and_body = Flambda.Function_params_and_body module Let_cont = Flambda.Let_cont module Let = Flambda.Let +module Let_symbol = Flambda.Let_symbol_expr module Lifted_constant = Simplify_env_and_result.Lifted_constant module Named = Flambda.Named module Non_recursive_let_cont_handler = Flambda.Non_recursive_let_cont_handler @@ -36,6 +37,7 @@ module Static_const = Flambda.Static_const module Switch = Flambda.Switch module CH = Continuation_handler +module CPH = Continuation_params_and_handler module CUE = Continuation_uses_env module DA = Downwards_acc module DE = Simplify_env_and_result.Downwards_env diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index 9535b069219c..722665475beb 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -376,20 +376,14 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars Symbol.create (Compilation_unit.get_current_exn ()) name) (Function_declarations.funs function_decls) in - let _set_of_closures, dacc, static_structure_types, - static_structure = - Simplify_static.simplify_set_of_closures0 dacc + let _set_of_closures, dacc, types_of_symbols, bound_symbols, static_const = + Simplify_static_const.simplify_set_of_closures0 dacc set_of_closures ~closure_symbols ~closure_elements ~closure_element_types in let r = - let definition : Definition.t = - { computation = None; - static_structure; - } - in let lifted_constant = - Lifted_constant.create (DA.denv dacc) definition - ~types_of_symbols:static_structure_types + Lifted_constant.create (DA.denv dacc) bound_symbols static_const + ~types_of_symbols in R.new_lifted_constant (DA.r dacc) lifted_constant in diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index f6d736614d2e..a36d12b1adde 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -72,27 +72,24 @@ let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols Simplify_named.simplify_set_of_closures0 dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types in - let static_structure : Program_body.Static_structure.t = - let code = - Code_id.Map.mapi (fun code_id params_and_body : Static_const.code -> - { params_and_body = Present params_and_body; - newer_version_of = Code_id.Map.find_opt code_id newer_versions_of; - }) - code - in - let static_const : Static_const.t = - Code_and_set_of_closures { - code; - set_of_closures = Some set_of_closures; - } - in - let bound_symbols : Program_body.Bound_symbols.t = - Code_and_set_of_closures { - code_ids = Code_id.Map.keys code; - closure_symbols; - } - in - [S (bound_symbols, static_const)] + let code = + Code_id.Map.mapi (fun code_id params_and_body : Static_const.code -> + { params_and_body = Present params_and_body; + newer_version_of = Code_id.Map.find_opt code_id newer_versions_of; + }) + code + in + let static_const : Static_const.t = + Code_and_set_of_closures { + code; + set_of_closures = Some set_of_closures; + } + in + let bound_symbols : Let_symbol.Bound_symbols.t = + Code_and_set_of_closures { + code_ids = Code_id.Map.keys code; + closure_symbols; + } in let static_structure_types = Name_in_binding_pos.Map.fold @@ -102,7 +99,7 @@ let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols closure_types_by_bound_name Symbol.Map.empty in - set_of_closures, dacc, static_structure_types, static_structure + set_of_closures, dacc, static_structure_types, bound_symbols, static_const let simplify_set_of_closures dacc set_of_closures ~closure_symbols = @@ -125,7 +122,7 @@ let simplify_static_const_of_kind_value dacc let denv = (* [result_sym] will already be defined when we are lifting reified computed values (see below). *) - DE.typing_env (DE.define_symbol_if_undefined denv result_sym K.value) + DE.define_symbol_if_undefined denv result_sym K.value in DE.add_equation_on_symbol denv result_sym typ) in @@ -191,11 +188,11 @@ let simplify_static_const_of_kind_value dacc | Code_and_set_of_closures _ -> Misc.fatal_errorf "[Code_and_set_of_closures] cannot be bound by a \ [Singleton] binding:@ %a" - SC.print t + SC.print static_const -let simplify_static_const_of_kind_fabricated dacc - (static_const : Static_const.t) ~result_sym - : Static_const.t * DA.t = +let simplify_static_const_of_kind_fabricated dacc code_ids bound_symbols + (static_const : Static_const.t) ~closure_symbols + : Bound_symbols.t * SC.t * DA.t = match static_const with | Code_and_set_of_closures { code; set_of_closures; } -> let code_ids' = Code_id.Map.keys code in @@ -203,14 +200,14 @@ let simplify_static_const_of_kind_fabricated dacc Misc.fatal_errorf "Mismatch on declared code IDs (%a and %a):@ %a" Code_id.Set.print code_ids Code_id.Set.print code_ids' - static_const.print static_const - end; + Static_const.print static_const + end; let dacc = Code_id.Map.fold (fun code_id ({ params_and_body; newer_version_of; } : Static_const.code) dacc -> - (* CR mshinwell: Add invariant check to ensure there are no + (* CR mshinwell: Add check to ensure there are no unbound names in the code, since we're not simplifying on the way down. *) let define_code denv = @@ -224,28 +221,32 @@ let simplify_static_const_of_kind_fabricated dacc code dacc in - let set_of_closures, dacc = - match set_of_closures with - | None -> None, dacc - | Some set_of_closures -> - let set_of_closures, dacc, _static_structure_types, _static_structure = - simplify_set_of_closures dacc set_of_closures - ~closure_symbols - in - Some set_of_closures, dacc - in - Code_and_set_of_closures { code; set_of_closures; }, dacc + begin match set_of_closures with + | None -> + bound_symbols, + Code_and_set_of_closures { code; set_of_closures = None; }, + dacc + | Some set_of_closures -> + let _set_of_closures, dacc, _static_structure_types, + bound_symbols, static_const = + simplify_set_of_closures dacc set_of_closures ~closure_symbols + in + bound_symbols, static_const, dacc + end | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ | Immutable_string _ -> Misc.fatal_errorf "Only [Code_and_set_of_closures] can be bound by a \ [Code_and_set_of_closures] binding:@ %a" - SC.print t + SC.print static_const -let simplify_static_const (type k) dacc (bound_syms : Bound_symbols.t) - (static_const : SC.t) : SC.t * DA.t = - match bound_syms with +let simplify_static_const dacc (bound_symbols : Bound_symbols.t) + (static_const : SC.t) : Bound_symbols.t * SC.t * DA.t = + match bound_symbols with | Singleton result_sym -> - simplify_static_const_of_kind_value dacc static_const ~result_sym + let static_const, dacc = + simplify_static_const_of_kind_value dacc static_const ~result_sym + in + bound_symbols, static_const, dacc | Code_and_set_of_closures { code_ids; closure_symbols; } -> - simplify_static_const_of_kind_fabricated dacc static_const ~code_ids - ~closure_symbols + simplify_static_const_of_kind_fabricated dacc code_ids bound_symbols + static_const ~closure_symbols diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli index 5d54108c6094..d042c8cdb9d0 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.mli @@ -34,4 +34,4 @@ val simplify_static_const : Downwards_acc.t -> Flambda.Let_symbol_expr.Bound_symbols.t -> Static_const.t - -> Static_const.t * Downwards_acc.t + -> Flambda.Let_symbol_expr.Bound_symbols.t * Static_const.t * Downwards_acc.t diff --git a/middle_end/flambda2.0/simplify/template/simplify.templ.ml b/middle_end/flambda2.0/simplify/template/simplify.templ.ml index eebb0d12e5e7..1c15397a6886 100644 --- a/middle_end/flambda2.0/simplify/template/simplify.templ.ml +++ b/middle_end/flambda2.0/simplify/template/simplify.templ.ml @@ -35,7 +35,6 @@ let check_imported_symbols_don't_overlap_predef_exns end let run ~backend ~round unit = - let backend = DE.backend denv in let module Backend = (val backend : Flambda2_backend_intf.S) in let predef_exn_symbols = Symbol.Set.fold (fun symbol predef_exn_symbols -> @@ -61,9 +60,9 @@ let run ~backend ~round unit = (Symbol.Map.disjoint_union imported_symbols predef_exn_symbols) denv in - let return_cont_scope = DE.continuation_scope_level denv in + let return_cont_scope = DE.get_continuation_scope_level denv in let denv = DE.increment_continuation_scope_level denv in - let exn_cont_scope = DE.continuation_scope_level denv in + let exn_cont_scope = DE.get_continuation_scope_level denv in let denv = DE.increment_continuation_scope_level denv in let r = R.create ~resolver:(DE.resolver denv) in let dacc = DA.create denv Continuation_uses_env.empty r in @@ -71,7 +70,7 @@ let run ~backend ~round unit = let exn_continuation = Exn_continuation.create ~exn_handler:exn_continuation ~extra_args:[] in - Simplify_toplevel.simplify_toplevel dacc body ~return_continuation + Simplify_toplevel.simplify_toplevel dacc (FU.body unit) ~return_continuation ~return_arity:[K.value] exn_continuation ~return_cont_scope ~exn_cont_scope in @@ -83,4 +82,4 @@ let run ~backend ~round unit = ~root_symbol:(FU.root_symbol unit) ~return_continuation ~exn_continuation - body + ~body diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index 6c6bbe7c8592..de0d4f481be3 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -14,7 +14,7 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-30-40-41-42"] +[@@@ocaml.warning "+a-4-30-40-41-42"] open! Flambda.Import @@ -80,7 +80,7 @@ module Iter_sets_of_closures = struct match (n : Named.t) with | Simple _ | Prim _ -> () | Set_of_closures s -> - f None s + f ~closure_symbols:None s and let_expr f t = Let.pattern_match t ~f:(fun ~bound_vars:_ ~body -> @@ -89,10 +89,10 @@ module Iter_sets_of_closures = struct expr f body ) - and let_symbol_expr f let_sym = + and let_symbol f let_sym = static_const f (Let_symbol.bound_symbols let_sym) (Let_symbol.defining_expr let_sym); - expr f (Let_symbol.body) + expr f (Let_symbol.body let_sym) and let_cont f = function | Let_cont.Non_recursive { handler; _ } -> @@ -144,11 +144,11 @@ module Iter_sets_of_closures = struct and static_const f (bound_symbols : Let_symbol.Bound_symbols.t) (static_const : Static_const.t) = - match bound_symbols, st with + match bound_symbols, static_const with | Code_and_set_of_closures { code_ids = _; closure_symbols; }, Code_and_set_of_closures { code; set_of_closures = s; } -> - Option.iter (fun s -> f (Some closure_symbols) s) s; - Code_id.Map.iter (fun _ { Flambda_static.Static_part.params_and_body; + Option.iter (fun s -> f ~closure_symbols:(Some closure_symbols) s) s; + Code_id.Map.iter (fun _ { Static_const.params_and_body; newer_version_of = _; } -> match params_and_body with | Deleted -> () @@ -158,7 +158,8 @@ module Iter_sets_of_closures = struct expr f body)) code | _ -> - (* CR mshinwell: Make exhaustive and cause errors on wrong cases *) + (* CR mshinwell: Make exhaustive and cause errors on wrong cases. + Then enable warning 4 *) () end diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 5d6bca094c27..4ce118d3d299 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -36,6 +36,9 @@ module R = Un_cps_result (* TODO: remove all uses of this, ^^ *) let todo () = failwith "Not yet implemented" +(* CR mshinwell: Remove global ref and thread [r] through *) +let result = ref R.empty + (* Cmm helpers *) module C = struct include Cmm_helpers @@ -617,6 +620,7 @@ and let_symbol env let_sym = (Let_symbol.bound_symbols let_sym) (Let_symbol.defining_expr let_sym) in + result := R.combine !result r; expr env body and let_set_of_closures env body closure_vars soc = @@ -1170,6 +1174,7 @@ and params_and_body env fun_name fun_dbg p = * List.map (fun decl -> C.cfunction decl) sorted *) let unit (unit : Flambda_unit.t) = + result := R.empty; Profile.record_call "flambda2_to_cmm" (fun () -> let offsets = Un_cps_closure.compute_offsets unit in let used_closure_vars = Flambda_unit.used_closure_vars unit in @@ -1188,20 +1193,23 @@ let unit (unit : Flambda_unit.t) = Flambda_kind.value; ] in - let return_cont, env = + let _return_cont, env = Env.add_jump_cont env (List.map snd return_cont_params) (Flambda_unit.return_continuation unit) in (* let functions = program_functions offsets used_closure_vars unit in *) - let body = expr env unit.body in + let _body = expr env (Flambda_unit.body unit) in + Misc.fatal_error "To be continued" +(* let body = let unit_value = C.targetint Targetint.zero in C.ccatch ~rec_flag:false ~body ~handlers:[C.handler return_cont return_cont_params unit_value] in - let data, entry, gc_roots, functions = R.to_cmm res in + let data, entry, gc_roots, functions = R.to_cmm !result in let cmm_data = C.flush_cmmgen_state () in let roots = List.map symbol gc_roots in (C.gc_root_table roots) :: data @ cmm_data @ functions @ [entry] +*) ) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_result.ml b/middle_end/flambda2.0/to_cmm/un_cps_result.ml index ae020b50e62d..7584a4ce06da 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_result.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_result.ml @@ -40,6 +40,7 @@ let add_if_not_empty x l = | [] -> l | _ :: _ -> x :: l +(* CR mshinwell: Label the arguments so the evaluation order is clear *) let combine r t = { init = C.sequence r.init t.init; current_data = []; From 46e42baee825704feea0be96aacd050b805ebf2d Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 10:35:31 +0000 Subject: [PATCH 19/80] terms - compiles --- .../flambda2.0/naming/name_occurrences.mli | 2 + middle_end/flambda2.0/terms/expr.rec.ml | 6 +-- middle_end/flambda2.0/terms/expr.rec.mli | 2 +- .../flambda2.0/terms/let_symbol_expr.rec.ml | 34 +++++++----- .../flambda2.0/terms/let_symbol_expr.rec.mli | 2 + .../flambda2.0/terms/static_const.rec.ml | 53 ++++++------------- .../flambda2.0/terms/static_const.rec.mli | 8 +-- 7 files changed, 49 insertions(+), 58 deletions(-) diff --git a/middle_end/flambda2.0/naming/name_occurrences.mli b/middle_end/flambda2.0/naming/name_occurrences.mli index 8f81f849bc3a..ce95d3d20f5d 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.mli +++ b/middle_end/flambda2.0/naming/name_occurrences.mli @@ -58,6 +58,8 @@ val singleton_variable : Variable.t -> Name_mode.t -> t val add_variable : t -> Variable.t -> Name_mode.t -> t +val add_symbol : t -> Symbol.t -> Name_mode.t -> t + val add_name : t -> Name.t -> Name_mode.t -> t val add_closure_var : t -> Var_within_closure.t -> Name_mode.t -> t diff --git a/middle_end/flambda2.0/terms/expr.rec.ml b/middle_end/flambda2.0/terms/expr.rec.ml index 405f29c5986b..62f2e205827b 100644 --- a/middle_end/flambda2.0/terms/expr.rec.ml +++ b/middle_end/flambda2.0/terms/expr.rec.ml @@ -18,7 +18,7 @@ type descr = | Let of Let_expr.t - | Let_symbol of Let_symbol.t + | Let_symbol of Let_symbol_expr.t | Let_cont of Let_cont_expr.t | Apply of Apply.t | Apply_cont of Apply_cont.t @@ -96,7 +96,7 @@ let invariant env t = let print_with_cache ~cache ppf (t : t) = match descr t with | Let let_expr -> Let_expr.print_with_cache ~cache ppf let_expr - | Let let_symbol_expr -> + | Let_symbol let_symbol_expr -> Let_symbol_expr.print_with_cache ~cache ppf let_symbol_expr | Let_cont let_cont -> Let_cont_expr.print_with_cache ~cache ppf let_cont | Apply apply -> @@ -122,7 +122,7 @@ let free_names t = | Not_computed -> match descr t with | Let let_expr -> Let_expr.free_names let_expr - | Let let_symbol_expr -> Let_symbol_expr.free_names let_symbol_expr + | Let_symbol let_symbol_expr -> Let_symbol_expr.free_names let_symbol_expr | Let_cont let_cont -> Let_cont_expr.free_names let_cont | Apply apply -> Apply.free_names apply | Apply_cont apply_cont -> Apply_cont.free_names apply_cont diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index 949eca85c2dd..a62aa97668e0 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -27,7 +27,7 @@ type descr = private (** Bind variable(s). There can be no effect on control flow (save for asynchronous operations such as the invocation of finalisers or signal handlers as a result of reaching a safe point). *) - | Let_symbol of Let_symbol.t + | Let_symbol of Let_symbol_expr.t (** Bind code and/or data symbol(s). This form of expression is only allowed in certain "toplevel" contexts. The bound symbols are not treated up to alpha conversion. *) diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 985f316ed67d..965a77efc87f 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-30-40-41-42"] + module Bound_symbols = struct type t = | Singleton : Symbol.t -> t @@ -44,9 +46,13 @@ module Bound_symbols = struct print_closure_binding) (Closure_id.Map.bindings closure_symbols) + let print_with_cache ~cache:_ ppf t = print ppf t + (* CR mshinwell: This should have an [invariant] function. One thing to check is that the [closure_symbols] are all distinct. *) + let invariant _ _ = () + let being_defined t = match t with | Singleton sym -> Symbol.Set.singleton sym @@ -68,7 +74,7 @@ module Bound_symbols = struct let free_names t = match t with - | Singleton sym -> Name_occurrences.singleton_symbol sym + | Singleton sym -> Name_occurrences.singleton_symbol sym Name_mode.normal | Code_and_set_of_closures { code_ids; closure_symbols; } -> let from_code_ids = Code_id.Set.fold (fun code_id from_code_ids -> @@ -98,18 +104,18 @@ let bound_symbols t = t.bound_symbols let defining_expr t = t.defining_expr let body t = t.body -let print_with_cache ~cache ppf ({ bound_symbols; defining_expr; body; } as t) = - let rec let_body (expr : Expr.t) = +let print_with_cache ~cache ppf { bound_symbols; defining_expr; body; } = + let rec let_symbol_body (expr : Expr.t) = match Expr.descr expr with - | Let ({ bound_symbols; defining_expr; body; } as t) -> + | Let_symbol { bound_symbols; defining_expr; body; } -> fprintf ppf "@ @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" (Flambda_colours.let_bound_symbol ()) Bound_symbols.print bound_symbols (Flambda_colours.elide ()) (Flambda_colours.normal ()) - (Named.print_with_cache ~cache) defining_expr; - let_body body + Static_const.print defining_expr; (* CR mshinwell: print_with_cache? *) + let_symbol_body body | _ -> expr in fprintf ppf "@[(@<0>%slet_symbol@<0>%s@ (@[\ @@ -120,27 +126,27 @@ let print_with_cache ~cache ppf ({ bound_symbols; defining_expr; body; } as t) = Bound_symbols.print bound_symbols (Flambda_colours.elide ()) (Flambda_colours.normal ()) - (Static_const.print_with_cache ~cache) defining_expr; - let expr = let_body body in + Static_const.print defining_expr; + let body = let_symbol_body body in fprintf ppf "@])@ %a)@]" (Expr.print_with_cache ~cache) body let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t -let invariant env { bound_symbols = _; defining_expr; body; } = - Named.invariant env defining_expr; +let invariant env { bound_symbols = _; defining_expr = _; body; } = + (* Static_const.invariant env defining_expr; *) (* CR mshinwell: FIXME *) Expr.invariant env body let free_names { bound_symbols; defining_expr; body; } = let from_bound_symbols = Bound_symbols.free_names bound_symbols in let from_defining_expr = - match defining_expr with - | Singleton sym -> Name_occurrences.singleton_symbol sym + match bound_symbols with + | Singleton _ -> Static_const.free_names defining_expr | Code_and_set_of_closures _ -> Name_occurrences.diff (Static_const.free_names defining_expr) from_bound_symbols in Name_occurrences.union from_defining_expr - (Name_occurrences.diff (Expr.free_names body) from_bound_symbols + (Name_occurrences.diff (Expr.free_names body) from_bound_symbols) let apply_name_permutation ({ bound_symbols; defining_expr; body; } as t) perm = let defining_expr' = Static_const.apply_name_permutation defining_expr perm in @@ -168,7 +174,7 @@ let pieces_of_code ?newer_versions_of ?set_of_closures code = }) code in - let static_part : Static_const.t = + let static_const : Static_const.t = let set_of_closures = Option.map snd set_of_closures in Code_and_set_of_closures { code; diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli index f3f010662c57..5ec092b39d88 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-4-30-40-41-42"] + (** The form of expression that binds symbols to statically-allocated constants. *) diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index 53a7fbf23712..04cceaecf766 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -90,7 +90,6 @@ module Field_of_block = struct *) end -module Static_part = struct type 'a or_variable = | Const of 'a | Var of Variable.t @@ -98,7 +97,7 @@ type 'a or_variable = type mutable_or_immutable = Mutable | Immutable type code = { - params_and_body : Flambda.Function_params_and_body.t or_deleted; + params_and_body : Function_params_and_body.t or_deleted; newer_version_of : Code_id.t option; } and 'a or_deleted = @@ -107,7 +106,7 @@ and 'a or_deleted = type code_and_set_of_closures = { code : code Code_id.Map.t; - set_of_closures : Flambda.Set_of_closures.t option; + set_of_closures : Set_of_closures.t option; } type t = @@ -149,7 +148,7 @@ let free_names t = let from_set_of_closures = match set_of_closures with | None -> Name_occurrences.empty - | Some set -> Flambda.Set_of_closures.free_names set + | Some set -> Set_of_closures.free_names set in Code_id.Map.fold (fun code_id { params_and_body; newer_version_of; } free_names -> @@ -164,7 +163,7 @@ let free_names t = match params_and_body with | Deleted -> Name_occurrences.empty | Present params_and_body -> - Flambda.Function_params_and_body.free_names params_and_body + Function_params_and_body.free_names params_and_body in Name_occurrences.union_list [ (Name_occurrences.add_code_id Name_occurrences.empty @@ -178,16 +177,14 @@ let free_names t = | Boxed_float (Var v) | Boxed_int32 (Var v) | Boxed_int64 (Var v) - | Boxed_nativeint (Var v) - | Mutable_string { initial_value = Var v; } - | Immutable_string (Var v) -> + | Boxed_nativeint (Var v) -> Name_occurrences.singleton_variable v Name_mode.normal | Boxed_float (Const _) | Boxed_int32 (Const _) | Boxed_int64 (Const _) | Boxed_nativeint (Const _) - | Mutable_string { initial_value = Const _; } - | Immutable_string (Const _) -> Name_occurrences.empty + | Mutable_string { initial_value = _; } + | Immutable_string _ -> Name_occurrences.empty | Immutable_float_array fields -> List.fold_left (fun fns (field : _ or_variable) -> match field with @@ -201,7 +198,7 @@ let print_params_and_body_with_cache ~cache ppf params_and_body = match params_and_body with | Deleted -> Format.fprintf ppf "@[(params_and_body@ Deleted)@]" | Present params_and_body -> - Flambda.Function_params_and_body.print_with_cache ~cache ppf + Function_params_and_body.print_with_cache ~cache ppf params_and_body let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = @@ -236,7 +233,7 @@ let print_with_cache ~cache ppf t = (Flambda_colours.normal ()) (Code_id.Map.print (print_code_with_cache ~cache)) code (Misc.Stdlib.Option.print - (Flambda.Set_of_closures.print_with_cache ~cache)) + (Set_of_closures.print_with_cache ~cache)) set_of_closures | Boxed_float (Const f) -> fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" @@ -286,26 +283,16 @@ let print_with_cache ~cache ppf t = ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") print_float_array_field) fields - | Mutable_string { initial_value = Const s; } -> + | Mutable_string { initial_value = s; } -> fprintf ppf "@[@<0>%sMutable_string@<0>%s@ \"%s\")@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) s - | Mutable_string { initial_value = Var v; } -> - fprintf ppf "@[@<0>%sMutable_string@<0>%s@ %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Immutable_string (Const s) -> + | Immutable_string s -> fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ \"%s\")@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) s - | Immutable_string (Var v) -> - fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t @@ -318,7 +305,7 @@ let _invariant env t = | Block (_tag, _mut, fields) -> List.iter (fun field -> Field_of_block.invariant env field) fields | Set_of_closures set -> - Flambda.Set_of_closures.invariant env set + Set_of_closures.invariant env set | Boxed_float (Var v) -> E.check_variable_is_bound_and_of_kind env v K.naked_float | Boxed_int32 (Var v) -> @@ -374,7 +361,7 @@ let apply_name_permutation t perm = | Deleted -> Deleted | Present params_and_body_inner -> let params_and_body_inner' = - Flambda.Function_params_and_body.apply_name_permutation + Function_params_and_body.apply_name_permutation params_and_body_inner perm in if params_and_body_inner == params_and_body_inner' then @@ -394,7 +381,7 @@ let apply_name_permutation t perm = | None -> None | Some set -> let set' = - Flambda.Set_of_closures.apply_name_permutation set perm + Set_of_closures.apply_name_permutation set perm in if set == set' then set_of_closures else Some set' @@ -421,20 +408,12 @@ let apply_name_permutation t perm = let v' = Name_permutation.apply_variable perm v in if v == v' then t else Boxed_nativeint (Var v') - | Mutable_string { initial_value = Var v; } -> - let v' = Name_permutation.apply_variable perm v in - if v == v' then t - else Mutable_string { initial_value = Var v'; } - | Immutable_string (Var v) -> - let v' = Name_permutation.apply_variable perm v in - if v == v' then t - else Immutable_string (Var v') | Boxed_float (Const _) | Boxed_int32 (Const _) | Boxed_int64 (Const _) | Boxed_nativeint (Const _) - | Mutable_string { initial_value = Const _; } - | Immutable_string (Const _) -> t + | Mutable_string { initial_value = _; } + | Immutable_string _ -> t | Immutable_float_array fields -> let changed = ref false in let fields = diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index 8dfd8f225202..8379ba425fa3 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +[@@@ocaml.warning "+a-30-40-41-42"] + (** Language terms that represent statically-allocated values. *) module Field_of_block : sig @@ -42,7 +44,7 @@ type mutable_or_immutable = Mutable | Immutable version of one that existed previously (and may still exist), for example after a round of simplification. *) type code = { - params_and_body : Flambda.Function_params_and_body.t or_deleted; + params_and_body : Function_params_and_body.t or_deleted; newer_version_of : Code_id.t option; } and 'a or_deleted = @@ -54,7 +56,7 @@ and 'a or_deleted = type code_and_set_of_closures = { code : code Code_id.Map.t; (* CR mshinwell: Check the free names of the set of closures *) - set_of_closures : Flambda.Set_of_closures.t option; + set_of_closures : Set_of_closures.t option; } (** The static structure of a symbol, possibly with holes, ready to be filled @@ -77,6 +79,6 @@ include Contains_names.S with type t := t val get_pieces_of_code : t - -> (Flambda.Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t + -> (Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t val is_fully_static : t -> bool From 3d75d6f2e25b4e3737383e8d7d63dd1b420d35cd Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 11:09:18 +0000 Subject: [PATCH 20/80] terms - compiles --- .../compilenv_deps/flambda_colours.ml | 6 +-- .../compilenv_deps/flambda_colours.mli | 4 +- .../terms/function_params_and_body.rec.ml | 2 +- middle_end/flambda2.0/terms/let_expr.rec.ml | 2 +- .../flambda2.0/terms/let_symbol_expr.rec.ml | 42 ++++++++++----- .../flambda2.0/terms/static_const.rec.ml | 52 +++++++++++-------- 6 files changed, 65 insertions(+), 43 deletions(-) diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml index 9ce887a70d5b..e4d5dcc89db7 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml @@ -35,12 +35,10 @@ let debuginfo () = C.fg_256 243 let discriminant () = C.fg_256 111 let name () = C.fg_256 111 let parameter () = C.fg_256 198 -let symbol () = C.fg_256 97 +let symbol () = C.fg_256 98 let variable () = C.fg_256 111 let closure_element () = C.fg_256 31 - -let let_bound_var () = C.fg_256 37 -let let_bound_symbol () = (C.fg_256 37) ^ (C.bg_256 240) +let code_id () = C.fg_256 202 let expr_keyword () = C.fg_256 51 let static_keyword () = (C.fg_256 255) ^ (C.bg_256 240) diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli index b0b14dcb0575..77a68dd07e75 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli @@ -36,9 +36,7 @@ val parameter : unit -> string val symbol : unit -> string val variable : unit -> string val closure_element : unit -> string - -val let_bound_var : unit -> string -val let_bound_symbol : unit -> string +val code_id : unit -> string val expr_keyword : unit -> string val static_keyword : unit -> string diff --git a/middle_end/flambda2.0/terms/function_params_and_body.rec.ml b/middle_end/flambda2.0/terms/function_params_and_body.rec.ml index 5fb02c7e5de1..4ae68f90de0a 100644 --- a/middle_end/flambda2.0/terms/function_params_and_body.rec.ml +++ b/middle_end/flambda2.0/terms/function_params_and_body.rec.ml @@ -87,7 +87,7 @@ let print_with_cache ~cache ppf t = fprintf ppf "@[(@<0>%s@<1>\u{03bb}@<0>%s@[\ @<1>\u{3008}%a@<1>\u{3009}@<1>\u{300a}%a@<1>\u{300b}\ - %a %a @<0>%s.@<0>%s@]@ %a)@])@]" + %a %a @<0>%s.@<0>%s@]@ %a))@]" (Flambda_colours.lambda ()) (Flambda_colours.normal ()) Continuation.print return_continuation diff --git a/middle_end/flambda2.0/terms/let_expr.rec.ml b/middle_end/flambda2.0/terms/let_expr.rec.ml index fcd264f1b67c..0b9b2248c5d5 100644 --- a/middle_end/flambda2.0/terms/let_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_expr.rec.ml @@ -37,7 +37,7 @@ let print_with_cache ~cache ppf if Name_mode.is_phantom kind then Flambda_colours.elide () else - Flambda_colours.let_bound_var () + Flambda_colours.variable () in let rec let_body (expr : Expr.t) = match Expr.descr expr with diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 965a77efc87f..1c9ac78e47da 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -37,14 +37,32 @@ module Bound_symbols = struct Symbol.print sym K.print K.value | Code_and_set_of_closures { code_ids; closure_symbols; } -> - Format.fprintf ppf "@[\ - @[(code_ids@ %a)@]@ \ - @[(closure_symbols@ {%a})@]\ - @]" - Code_id.Set.print code_ids - (Format.pp_print_list ~pp_sep:Format.pp_print_space - print_closure_binding) - (Closure_id.Map.bindings closure_symbols) + match + Code_id.Set.elements code_ids, Closure_id.Map.bindings closure_symbols + with + | [code_id], [] -> + Format.fprintf ppf "@<0>%s%a@<0>%s" + (Flambda_colours.code_id ()) + Code_id.print code_id + (Flambda_colours.normal ()) + | [], [closure_binding] -> + Format.fprintf ppf "@<0>%s%a@<0>%s" + (Flambda_colours.symbol ()) + print_closure_binding closure_binding + (Flambda_colours.normal ()) + | _, _ -> + Format.fprintf ppf "@[\ + @[(code_ids@ (@<0>%s%a@<0>%s))@]@ \ + @[(closure_symbols@ {%a})@]\ + @]" + (Flambda_colours.code_id ()) + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Code_id.print) + (Code_id.Set.elements code_ids) + (Flambda_colours.normal ()) + (Format.pp_print_list ~pp_sep:Format.pp_print_space + print_closure_binding) + (Closure_id.Map.bindings closure_symbols) let print_with_cache ~cache:_ ppf t = print ppf t @@ -110,7 +128,7 @@ let print_with_cache ~cache ppf { bound_symbols; defining_expr; body; } = | Let_symbol { bound_symbols; defining_expr; body; } -> fprintf ppf "@ @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" - (Flambda_colours.let_bound_symbol ()) + (Flambda_colours.symbol ()) Bound_symbols.print bound_symbols (Flambda_colours.elide ()) (Flambda_colours.normal ()) @@ -122,7 +140,7 @@ let print_with_cache ~cache ppf { bound_symbols; defining_expr; body; } = @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" (Flambda_colours.expr_keyword ()) (Flambda_colours.normal ()) - (Flambda_colours.let_bound_symbol ()) + (Flambda_colours.symbol ()) Bound_symbols.print bound_symbols (Flambda_colours.elide ()) (Flambda_colours.normal ()) @@ -154,8 +172,8 @@ let apply_name_permutation ({ bound_symbols; defining_expr; body; } as t) perm = if defining_expr == defining_expr' && body == body' then t else { bound_symbols; - defining_expr; - body; + defining_expr = defining_expr'; + body = body'; } (* CR mshinwell: Add a type to just encapsulate bound_symbols and diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index 04cceaecf766..195c2f9a508e 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -204,7 +204,7 @@ let print_params_and_body_with_cache ~cache ppf params_and_body = let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = (* CR mshinwell: elide "newer_version_of" when None *) Format.fprintf ppf "@[(\ - @[(newer_version_of@ %a)@]@ \ + @[(newer_version_of@ %a)@]@ \ %a\ )@]" (Misc.Stdlib.Option.print Code_id.print) newer_version_of @@ -225,58 +225,66 @@ let print_with_cache ~cache ppf t = (Format.pp_print_list ~pp_sep:Format.pp_print_space Field_of_block.print) fields | Code_and_set_of_closures { code; set_of_closures; } -> - fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ - @[(code@ (%a))@]@ \ - @[(set_of_closures@ (%a))@]\ - ))@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Code_id.Map.print (print_code_with_cache ~cache)) code - (Misc.Stdlib.Option.print - (Set_of_closures.print_with_cache ~cache)) - set_of_closures + if Option.is_none set_of_closures then + fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ + @[%a@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Code_id.Map.print (print_code_with_cache ~cache)) code + else + fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ + @[(code@ (%a))@]@ \ + @[(set_of_closures@ (%a))@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Code_id.Map.print (print_code_with_cache ~cache)) code + (Misc.Stdlib.Option.print + (Set_of_closures.print_with_cache ~cache)) + set_of_closures | Boxed_float (Const f) -> - fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" + fprintf ppf "@[(@<0>%sBoxed_float@<0>%s %a)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Numbers.Float_by_bit_pattern.print f | Boxed_float (Var v) -> - fprintf ppf "@[@<0>%sBoxed_float@<0>%s %a)@]" + fprintf ppf "@[(@<0>%sBoxed_float@<0>%s %a)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Variable.print v | Boxed_int32 (Const n) -> - fprintf ppf "@[@<0>%sBoxed_int32@<0>%s %ld)@]" + fprintf ppf "@[(@<0>%sBoxed_int32@<0>%s %ld)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) n | Boxed_int32 (Var v) -> - fprintf ppf "@[@<0>%sBoxed_int32@<0>%s %a)@]" + fprintf ppf "@[(@<0>%sBoxed_int32@<0>%s %a)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Variable.print v | Boxed_int64 (Const n) -> - fprintf ppf "@[@<0>%sBoxed_int64@<0>%s %Ld)@]" + fprintf ppf "@[(@<0>%sBoxed_int64@<0>%s %Ld)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) n | Boxed_int64 (Var v) -> - fprintf ppf "@[@<0>%sBoxed_int64@<0>%s %a)@]" + fprintf ppf "@[(@<0>%sBoxed_int64@<0>%s %a)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Variable.print v | Boxed_nativeint (Const n) -> - fprintf ppf "@[@<0>%sBoxed_nativeint@<0>%s %a)@]" + fprintf ppf "@[(@<0>%sBoxed_nativeint@<0>%s %a)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Targetint.print n | Boxed_nativeint (Var v) -> - fprintf ppf "@[@<0>%sBoxed_nativeint@<0>%s %a)@]" + fprintf ppf "@[(@<0>%sBoxed_nativeint@<0>%s %a)@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) Variable.print v | Immutable_float_array fields -> - fprintf ppf "@[@<0>%sImmutable_float_array@<0>%s@ @[[| %a |]@])@]" + fprintf ppf "@[(@<0>%sImmutable_float_array@<0>%s@ @[[| %a |]@])@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) (Format.pp_print_list @@ -284,12 +292,12 @@ let print_with_cache ~cache ppf t = print_float_array_field) fields | Mutable_string { initial_value = s; } -> - fprintf ppf "@[@<0>%sMutable_string@<0>%s@ \"%s\")@]" + fprintf ppf "@[(@<0>%sMutable_string@<0>%s@ \"%s\")@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) s | Immutable_string s -> - fprintf ppf "@[@<0>%sImmutable_string@<0>%s@ \"%s\")@]" + fprintf ppf "@[(@<0>%sImmutable_string@<0>%s@ \"%s\")@]" (Flambda_colours.static_part ()) (Flambda_colours.normal ()) s From 1325228e5978ca8bff41b1bbd1bf1c3cab965877 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 11:28:15 +0000 Subject: [PATCH 21/80] terms - compiles --- middle_end/flambda2.0/basic/code_id.ml | 10 ++++++- .../compilenv_deps/flambda_colours.ml | 2 +- .../flambda2.0/terms/let_symbol_expr.rec.ml | 13 +++------ .../flambda2.0/terms/static_const.rec.ml | 27 +++++++++++++------ 4 files changed, 32 insertions(+), 20 deletions(-) diff --git a/middle_end/flambda2.0/basic/code_id.ml b/middle_end/flambda2.0/basic/code_id.ml index 05bfdcadacbf..97472c18cf5c 100644 --- a/middle_end/flambda2.0/basic/code_id.ml +++ b/middle_end/flambda2.0/basic/code_id.ml @@ -21,7 +21,15 @@ module Unit_id = Id_types.UnitId (Id) (Compilation_unit) type t = Unit_id.t -include Identifiable.Make (Unit_id) +include Identifiable.Make (struct + include Unit_id + + let print ppf t = + Format.fprintf ppf "@<0>%s%a@<0>%s" + (Flambda_colours.code_id ()) + print t + (Flambda_colours.normal ()) +end) let create ~name comp_unit = Unit_id.create ~name comp_unit let get_compilation_unit = Unit_id.unit diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml index e4d5dcc89db7..9db76e3050b1 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml @@ -38,7 +38,7 @@ let parameter () = C.fg_256 198 let symbol () = C.fg_256 98 let variable () = C.fg_256 111 let closure_element () = C.fg_256 31 -let code_id () = C.fg_256 202 +let code_id () = C.fg_256 172 let expr_keyword () = C.fg_256 51 let static_keyword () = (C.fg_256 255) ^ (C.bg_256 240) diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 1c9ac78e47da..da91caaa9a51 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -41,10 +41,7 @@ module Bound_symbols = struct Code_id.Set.elements code_ids, Closure_id.Map.bindings closure_symbols with | [code_id], [] -> - Format.fprintf ppf "@<0>%s%a@<0>%s" - (Flambda_colours.code_id ()) - Code_id.print code_id - (Flambda_colours.normal ()) + Format.fprintf ppf "%a" Code_id.print code_id | [], [closure_binding] -> Format.fprintf ppf "@<0>%s%a@<0>%s" (Flambda_colours.symbol ()) @@ -52,14 +49,10 @@ module Bound_symbols = struct (Flambda_colours.normal ()) | _, _ -> Format.fprintf ppf "@[\ - @[(code_ids@ (@<0>%s%a@<0>%s))@]@ \ + @[(code_ids@ (%a))@]@ \ @[(closure_symbols@ {%a})@]\ @]" - (Flambda_colours.code_id ()) - (Format.pp_print_list ~pp_sep:Format.pp_print_space - Code_id.print) - (Code_id.Set.elements code_ids) - (Flambda_colours.normal ()) + Code_id.Set.print code_ids (Format.pp_print_list ~pp_sep:Format.pp_print_space print_closure_binding) (Closure_id.Map.bindings closure_symbols) diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index 195c2f9a508e..d9deef678194 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -202,12 +202,14 @@ let print_params_and_body_with_cache ~cache ppf params_and_body = params_and_body let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = - (* CR mshinwell: elide "newer_version_of" when None *) Format.fprintf ppf "@[(\ - @[(newer_version_of@ %a)@]@ \ + @[@<0>%s(newer_version_of@ %a)@<0>%s@]@ \ %a\ )@]" + (if Option.is_none newer_version_of then Flambda_colours.elide () + else Flambda_colours.normal ()) (Misc.Stdlib.Option.print Code_id.print) newer_version_of + (Flambda_colours.normal ()) (print_params_and_body_with_cache ~cache) params_and_body let print_with_cache ~cache ppf t = @@ -226,12 +228,21 @@ let print_with_cache ~cache ppf t = Field_of_block.print) fields | Code_and_set_of_closures { code; set_of_closures; } -> if Option.is_none set_of_closures then - fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ - @[%a@]\ - ))@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Code_id.Map.print (print_code_with_cache ~cache)) code + match Code_id.Map.get_singleton code with + | None -> + fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ + @[%a@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Code_id.Map.print (print_code_with_cache ~cache)) code + | Some (_code_id, code) -> + fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ + @[%a@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (print_code_with_cache ~cache) code else fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ @[(code@ (%a))@]@ \ From 615ecd213bddf30b521d34071a241ddabacf5f18 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 13:38:09 +0000 Subject: [PATCH 22/80] terms - compiles --- .../compilenv_deps/flambda_colours.ml | 2 +- .../flambda2.0/naming/name_occurrences.ml | 13 ++++ .../flambda2.0/naming/name_occurrences.mli | 2 + .../simplify/env/simplify_env_and_result.ml | 28 ++++++- .../env/simplify_env_and_result_intf.ml | 6 ++ .../flambda2.0/simplify/simplify_expr.rec.ml | 76 +++++++++++++++++-- .../flambda2.0/simplify/simplify_import.ml | 1 + .../flambda2.0/simplify/simplify_import.mli | 1 + .../flambda2.0/simplify/simplify_named.rec.ml | 7 ++ .../simplify/typing_helpers/reification.ml | 16 +++- middle_end/flambda2.0/terms/flambda.mli | 4 + .../flambda2.0/terms/function_declarations.ml | 4 + .../terms/function_declarations.mli | 2 + .../flambda2.0/terms/let_symbol_expr.rec.ml | 28 +++++++ .../flambda2.0/terms/let_symbol_expr.rec.mli | 2 + .../flambda2.0/terms/set_of_closures.ml | 12 +++ .../flambda2.0/terms/set_of_closures.mli | 2 + .../flambda2.0/terms/static_const.rec.ml | 30 ++++++++ .../flambda2.0/terms/static_const.rec.mli | 2 + 19 files changed, 228 insertions(+), 10 deletions(-) diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml index 9db76e3050b1..48a7c0fdf033 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml @@ -38,7 +38,7 @@ let parameter () = C.fg_256 198 let symbol () = C.fg_256 98 let variable () = C.fg_256 111 let closure_element () = C.fg_256 31 -let code_id () = C.fg_256 172 +let code_id () = C.fg_256 169 let expr_keyword () = C.fg_256 51 let static_keyword () = (C.fg_256 255) ^ (C.bg_256 240) diff --git a/middle_end/flambda2.0/naming/name_occurrences.ml b/middle_end/flambda2.0/naming/name_occurrences.ml index c2985780e9fc..7c708e84e335 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.ml +++ b/middle_end/flambda2.0/naming/name_occurrences.ml @@ -68,6 +68,8 @@ end) : sig val subset_domain : t -> t -> bool + val overlap : t -> t -> bool + val mem : t -> N.t -> bool val remove : t -> N.t -> t @@ -232,6 +234,9 @@ end = struct let subset_domain t1 t2 = N.Set.subset (N.Map.keys t1) (N.Map.keys t2) + let overlap t1 t2 = + not (N.Set.is_empty (N.Set.inter (N.Map.keys t1) (N.Map.keys t2))) + let mem t name = N.Map.mem name t let remove t name = N.Map.remove name t @@ -533,6 +538,14 @@ let subset_domain t1 t2 = ~for_code_ids:For_code_ids.subset_domain t1 t2 +let overlap t1 t2 = + binary_predicate ~for_variables:For_variables.overlap + ~for_continuations:For_continuations.overlap + ~for_symbols:For_symbols.overlap + ~for_closure_vars:For_closure_vars.overlap + ~for_code_ids:For_code_ids.overlap + t1 t2 + let rec union_list ts = match ts with | [] -> empty diff --git a/middle_end/flambda2.0/naming/name_occurrences.mli b/middle_end/flambda2.0/naming/name_occurrences.mli index ce95d3d20f5d..6dd31213eb50 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.mli +++ b/middle_end/flambda2.0/naming/name_occurrences.mli @@ -96,6 +96,8 @@ val union_list : t list -> t those occurrences are ignored. *) val subset_domain : t -> t -> bool +val overlap : t -> t -> bool + val variables : t -> Variable.Set.t val symbols : t -> Symbol.Set.t diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 07ea75059591..b14ee0e46e1e 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -38,12 +38,14 @@ end = struct code : Function_params_and_body.t Code_id.Map.t; at_unit_toplevel : bool; unit_toplevel_exn_continuation : Continuation.t; + symbols_currently_being_defined : Symbol.Set.t; } let print ppf { backend = _; round; typing_env; inlined_debuginfo; can_inline; inlining_depth_increment; float_const_prop; code; at_unit_toplevel; unit_toplevel_exn_continuation; + symbols_currently_being_defined; } = Format.fprintf ppf "@[(\ @[(round@ %d)@]@ \ @@ -54,6 +56,7 @@ end = struct @[(float_const_prop@ %b)@] \ @[(at_unit_toplevel@ %b)@] \ @[(unit_toplevel_exn_continuation@ %a)@] \ + @[(symbols_currently_being_defined@ %a)@] \ @[(code@ %a)@]\ )@]" round @@ -64,6 +67,7 @@ end = struct float_const_prop at_unit_toplevel Continuation.print unit_toplevel_exn_continuation + Symbol.Set.print symbols_currently_being_defined (Code_id.Map.print Function_params_and_body.print) code let invariant _t = () @@ -81,6 +85,7 @@ end = struct code = Code_id.Map.empty; at_unit_toplevel = true; unit_toplevel_exn_continuation; + symbols_currently_being_defined = Symbol.Set.empty; } let resolver t = TE.resolver t.typing_env @@ -113,11 +118,28 @@ end = struct increment_continuation_scope_level (increment_continuation_scope_level t) + let now_defining_symbol t symbol = + if Symbol.Set.mem symbol t.symbols_currently_being_defined then begin + Misc.fatal_errorf "Already defining symbol %a:@ %a" + Symbol.print symbol + print t + end; + let symbols_currently_being_defined = + Symbol.Set.add symbol t.symbols_currently_being_defined + in + { t with + symbols_currently_being_defined; + } + + let symbol_is_currently_being_defined t symbol = + Symbol.Set.mem symbol t.symbols_currently_being_defined + let enter_closure { backend; round; typing_env; inlined_debuginfo = _; can_inline; inlining_depth_increment = _; float_const_prop; code; at_unit_toplevel = _; unit_toplevel_exn_continuation; + symbols_currently_being_defined; } = { backend; round; @@ -129,6 +151,7 @@ end = struct code; at_unit_toplevel = false; unit_toplevel_exn_continuation; + symbols_currently_being_defined; } let define_variable t var kind = @@ -623,6 +646,9 @@ end = struct let get_lifted_constants t = t.lifted_constants_innermost_last + let set_lifted_constants t consts = + { t with lifted_constants_innermost_last = consts; } + let clear_lifted_constants t = { t with lifted_constants_innermost_last = []; @@ -641,7 +667,7 @@ end = struct let print ppf { denv = _ ; bound_symbols; defining_expr; types_of_symbols = _; } = Format.fprintf ppf "@[(\ - @[(bound_symbols@ %a)@]\ + @[(bound_symbols@ %a)@]@ \ @[(static_const@ %a)@]\ )@]" Let_symbol.Bound_symbols.print bound_symbols diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index 7ff930664991..5a93c1f5a4b2 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -60,6 +60,10 @@ module type Downwards_env = sig val get_continuation_scope_level : t -> Scope.t + val now_defining_symbol : t -> Symbol.t -> t + + val symbol_is_currently_being_defined : t -> Symbol.t -> bool + val typing_env : t -> Flambda_type.Typing_env.t val define_variable : t -> Var_in_binding_pos.t -> Flambda_kind.t -> t @@ -265,6 +269,8 @@ module type Result = sig (* CR mshinwell: Update name to reflect this *) val get_lifted_constants : t -> lifted_constant list + val set_lifted_constants : t -> lifted_constant list -> t + val imported_symbols : t -> Flambda_kind.t Symbol.Map.t val clear_lifted_constants : t -> t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 71b99ba07436..ea06196faa65 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -48,6 +48,7 @@ and simplify_let_symbol compilation units (not even at the toplevel of function bodies):@ %a" LS.print let_symbol_expr end; + let module Bound_symbols = LS.Bound_symbols in let bound_symbols = LS.bound_symbols let_symbol_expr in Symbol.Set.iter (fun sym -> if DE.mem_symbol (DA.denv dacc) sym then begin @@ -62,17 +63,82 @@ and simplify_let_symbol Code_id.print code_id LS.print let_symbol_expr end) - (LS.Bound_symbols.code_being_defined bound_symbols); + (Bound_symbols.code_being_defined bound_symbols); let defining_expr = LS.defining_expr let_symbol_expr in let body = LS.body let_symbol_expr in + let prior_lifted_constants = R.get_lifted_constants (DA.r dacc) in + let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let bound_symbols, defining_expr, dacc = + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Symbol.Set.fold (fun symbol denv -> + DE.now_defining_symbol denv symbol) + (Name_occurrences.symbols (Bound_symbols.free_names bound_symbols)) + denv) + in Simplify_static_const.simplify_static_const dacc bound_symbols defining_expr in - (* XXX Retrieve and add lifted constants here (some of which may need to - go in [defining_expr]. *) - let bindings_outermost_first = [bound_symbols, defining_expr] in + let defining_expr_lifted_constants = R.get_lifted_constants (DA.r dacc) in + let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let body, user_data, uacc = simplify_expr dacc body k in - (* XXX This should do the deletion of the [Let_symbol], since we need the + let subsequent_lifted_constants = R.get_lifted_constants (UA.r uacc) in + let uacc = + UA.map_r uacc ~f:(fun r -> R.set_lifted_constants r prior_lifted_constants) + in + let defining_expr_lifted_constants_not_in_same_set, + bound_symbols, defining_expr = + let bound_names = Bound_symbols.free_names bound_symbols in + List.fold_left + (fun (defining_expr_lifted_constants_not_in_same_set, + bound_symbols, defining_expr) lifted_constant -> + let bound_symbols_lifted_constant = LC.bound_symbols lifted_constant in + let defining_expr_lifted_constant = LC.defining_expr lifted_constant in + let overlap = + Name_occurrences.overlap bound_names + (Static_const.free_names defining_expr) + in + match bound_symbols_lifted_constant with + | Singleton _ -> + let defining_expr_lifted_constants_not_in_same_set = + (bound_symbols, defining_expr_lifted_constant) + :: defining_expr_lifted_constants_not_in_same_set + in + if overlap then begin + Misc.fatal_errorf "Lifted constant that is not allowed to be \ + involved in a recursive binding uses name(s) from the \ + current [Let_symbol] recursively:@ %a@ Current [Let_symbol] \ + binds:@ %a" + LC.print lifted_constant + Bound_symbols.print bound_symbols + end; + defining_expr_lifted_constants_not_in_same_set, + bound_symbols, defining_expr + | Code_and_set_of_closures _ -> + if overlap then + let bound_symbols = + Bound_symbols.disjoint_union bound_symbols + bound_symbols_lifted_constant + in + let defining_expr = + Static_const.disjoint_union defining_expr + defining_expr_lifted_constant + in + defining_expr_lifted_constants_not_in_same_set, + bound_symbols, defining_expr + else + defining_expr_lifted_constants_not_in_same_set, + bound_symbols, defining_expr) + ([], bound_symbols, defining_expr) + defining_expr_lifted_constants + in + let bindings_outermost_first = + defining_expr_lifted_constants_not_in_same_set + @ (bound_symbols, defining_expr) + :: List.map (fun lifted_constant -> + LC.bound_symbols lifted_constant, LC.defining_expr lifted_constant) + subsequent_lifted_constants + in + (* XXX This should do the deletion of the [Let_symbol]s, since we need the code age relation to do that. *) let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> diff --git a/middle_end/flambda2.0/simplify/simplify_import.ml b/middle_end/flambda2.0/simplify/simplify_import.ml index 1e2b766bc3cb..fc0bad377b2e 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.ml +++ b/middle_end/flambda2.0/simplify/simplify_import.ml @@ -47,6 +47,7 @@ module FD = Function_declaration module FU = Flambda_unit module K = Flambda_kind module KP = Kinded_parameter +module LC = Simplify_env_and_result.Lifted_constant module NM = Name_mode module P = Flambda_primitive module R = Simplify_env_and_result.Result diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index 1e2b766bc3cb..fc0bad377b2e 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -47,6 +47,7 @@ module FD = Function_declaration module FU = Flambda_unit module K = Flambda_kind module KP = Kinded_parameter +module LC = Simplify_env_and_result.Lifted_constant module NM = Name_mode module P = Flambda_primitive module R = Simplify_env_and_result.Result diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index 722665475beb..a42670171f94 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -376,6 +376,13 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars Symbol.create (Compilation_unit.get_current_exn ()) name) (Function_declarations.funs function_decls) in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Closure_id.Map.fold (fun _closure_id closure_symbol denv -> + DE.now_defining_symbol denv closure_symbol) + closure_symbols + denv) + in let _set_of_closures, dacc, types_of_symbols, bound_symbols, static_const = Simplify_static_const.simplify_set_of_closures0 dacc set_of_closures ~closure_symbols ~closure_elements ~closure_element_types diff --git a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml b/middle_end/flambda2.0/simplify/typing_helpers/reification.ml index 2a268fe8bb7c..ae3b154cfe14 100644 --- a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml +++ b/middle_end/flambda2.0/simplify/typing_helpers/reification.ml @@ -42,8 +42,6 @@ let lift dacc ty ~bound_to static_const = (Linkage_name.create (Variable.unique_name bound_to)) in if not (K.equal (T.kind ty) K.value) then begin - (* Sets of closures may be lifted and are not of kind [Value], but they - are dealt with directly in [Simplify_named]. *) Misc.fatal_errorf "Cannot lift non-[Value] variable: %a" Variable.print bound_to end; @@ -79,7 +77,19 @@ let try_to_reify dacc (term : Reachable.t) ~bound_to = | Lift to_lift -> if Name_mode.is_normal occ_kind then let static_const = create_static_const to_lift in - lift dacc ty ~bound_to static_const + (* We cannot currently handle the lifting of constants that are + recursive with a symbol currently being defined, unless the + constant is a closure, which it never is in this case. + (An example of such a constant would be a pair, created in a + recursive function [f] that has no free variables, containing + the closure [f].) *) + let overlap_with_current_definitions = + Symbol.Set.exists (fun sym -> + DE.symbol_is_currently_being_defined denv sym) + (Name_occurrences.symbols (Static_const.free_names static_const)) + in + if overlap_with_current_definitions then term, dacc, ty + else lift dacc ty ~bound_to static_const else term, dacc, ty | Simple simple -> diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index ff3d1f9162a6..31f1f1956685 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -231,6 +231,8 @@ end and Let_symbol_expr : sig val closure_symbols_being_defined : t -> Symbol.Set.t + val disjoint_union : t -> t -> t + include Expr_std.S with type t := t end @@ -547,6 +549,8 @@ end and Static_const : sig which means that the corresponding value can be statically allocated, without any need to patch it afterwards. *) val is_fully_static : t -> bool + + val disjoint_union : t -> t -> t end module Function_declaration = Function_declaration diff --git a/middle_end/flambda2.0/terms/function_declarations.ml b/middle_end/flambda2.0/terms/function_declarations.ml index dd03fd7a0765..93ec6b658fa2 100644 --- a/middle_end/flambda2.0/terms/function_declarations.ml +++ b/middle_end/flambda2.0/terms/function_declarations.ml @@ -52,3 +52,7 @@ let apply_name_permutation ({ funs; } as t) perm = in if funs == funs' then t else { funs = funs'; } + +let disjoint_union t1 t2 = + let funs = Closure_id.Map.disjoint_union t1.funs t2.funs in + { funs; } diff --git a/middle_end/flambda2.0/terms/function_declarations.mli b/middle_end/flambda2.0/terms/function_declarations.mli index ae7085f92bdd..38135e7f4840 100644 --- a/middle_end/flambda2.0/terms/function_declarations.mli +++ b/middle_end/flambda2.0/terms/function_declarations.mli @@ -48,3 +48,5 @@ val funs : t -> Function_declaration.t Closure_id.Map.t (** [find f t] raises [Not_found] if [f] is not in [t]. *) val find : t -> Closure_id.t -> Function_declaration.t + +val disjoint_union : t -> t -> t diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index da91caaa9a51..298558eeac16 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -97,6 +97,34 @@ module Bound_symbols = struct Name_occurrences.add_symbol bound_names closure_sym Name_mode.normal) closure_symbols from_code_ids + + let disjoint_union t1 t2 = + match t1, t2 with + | Code_and_set_of_closures { + code_ids = code_ids1; + closure_symbols = closure_symbols1; + }, + Code_and_set_of_closures { + code_ids = code_ids2; + closure_symbols = closure_symbols2; + } -> + let code_ids = Code_id.Set.inter code_ids1 code_ids2 in + if not (Code_id.Set.is_empty code_ids) then begin + Misc.fatal_errorf "Code IDs not disjoint in@ %a@ and@ %a" + print t1 + print t2 + end; + Code_and_set_of_closures { + code_ids = Code_id.Set.union code_ids1 code_ids2; + closure_symbols = + Closure_id.Map.disjoint_union closure_symbols1 closure_symbols2; + } + | Code_and_set_of_closures _, Singleton _ + | Singleton _, Code_and_set_of_closures _ + | Singleton _, Singleton _ -> + Misc.fatal_errorf "Cannot [disjoint_union] the following:@ %a@ and@ %a" + print t1 + print t2 end type t = { diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli index 5ec092b39d88..443032f79766 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli @@ -37,6 +37,8 @@ module Bound_symbols : sig val closure_symbols_being_defined : t -> Symbol.Set.t + val disjoint_union : t -> t -> t + include Expr_std.S with type t := t end diff --git a/middle_end/flambda2.0/terms/set_of_closures.ml b/middle_end/flambda2.0/terms/set_of_closures.ml index 771aa0b5f05e..a9e564f5ed3e 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.ml +++ b/middle_end/flambda2.0/terms/set_of_closures.ml @@ -87,3 +87,15 @@ let apply_name_permutation { function_decls = function_decls'; closure_elements = closure_elements'; } + +let disjoint_union t1 t2 = + let function_decls = + Function_declarations.disjoint_union t1.function_decls t2.function_decls + in + let closure_elements = + Var_within_closure.Map.disjoint_union t1.closure_elements + t2.closure_elements + in + { function_decls; + closure_elements; + } diff --git a/middle_end/flambda2.0/terms/set_of_closures.mli b/middle_end/flambda2.0/terms/set_of_closures.mli index 05d7daad41d1..69644141d048 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.mli +++ b/middle_end/flambda2.0/terms/set_of_closures.mli @@ -41,3 +41,5 @@ val has_empty_environment : t -> bool in its environment. (If this condition is satisfied, a set of closures may be lifted.) *) val environment_doesn't_mention_variables : t -> bool + +val disjoint_union : t -> t -> t diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index d9deef678194..2d817bc4ea28 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -472,3 +472,33 @@ let is_fully_static t = free_names t |> Name_occurrences.variables |> Variable.Set.is_empty + +let disjoint_union t1 t2 = + match t1, t2 with + | Code_and_set_of_closures { code = code1; set_of_closures = set1; }, + Code_and_set_of_closures { code = code2; set_of_closures = set2; } -> + let code = Code_id.Map.disjoint_union code1 code2 in + let set_of_closures = + match set1, set2 with + | None, None -> None + | Some set, None | None, Some set -> Some set + | Some set1, Some set2 -> + Some (Set_of_closures.disjoint_union set1 set2) + in + Code_and_set_of_closures { + code; + set_of_closures; + } + | Code_and_set_of_closures _, + (Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _) + | (Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _), + Code_and_set_of_closures _ + | (Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _), + (Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _) -> + Misc.fatal_errorf "Cannot [disjoint_union] the following:@ %a@ and@ %a" + print t1 + print t2 diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index 8379ba425fa3..44220aea5572 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -82,3 +82,5 @@ val get_pieces_of_code -> (Function_params_and_body.t * (Code_id.t option)) Code_id.Map.t val is_fully_static : t -> bool + +val disjoint_union : t -> t -> t From 2deb57d38f541aac86f5093550847b13a06bb1ca Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 14:06:30 +0000 Subject: [PATCH 23/80] terms - compiles --- flambdatest/mlexamples/tests10.ml | 3 +++ middle_end/flambda2.0/terms/let_symbol_expr.rec.ml | 6 ++---- 2 files changed, 5 insertions(+), 4 deletions(-) create mode 100644 flambdatest/mlexamples/tests10.ml diff --git a/flambdatest/mlexamples/tests10.ml b/flambdatest/mlexamples/tests10.ml new file mode 100644 index 000000000000..62404c103016 --- /dev/null +++ b/flambdatest/mlexamples/tests10.ml @@ -0,0 +1,3 @@ +(* needs -rectypes *) + +let rec f () = f, f diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 298558eeac16..a0820d27ff52 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -148,8 +148,7 @@ let print_with_cache ~cache ppf { bound_symbols; defining_expr; body; } = match Expr.descr expr with | Let_symbol { bound_symbols; defining_expr; body; } -> fprintf ppf - "@ @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" - (Flambda_colours.symbol ()) + "@ @[%a@<0>%s =@<0>%s@ %a@]" Bound_symbols.print bound_symbols (Flambda_colours.elide ()) (Flambda_colours.normal ()) @@ -158,10 +157,9 @@ let print_with_cache ~cache ppf { bound_symbols; defining_expr; body; } = | _ -> expr in fprintf ppf "@[(@<0>%slet_symbol@<0>%s@ (@[\ - @[@<0>%s%a@<0>%s =@<0>%s@ %a@]" + @[%a@<0>%s =@<0>%s@ %a@]" (Flambda_colours.expr_keyword ()) (Flambda_colours.normal ()) - (Flambda_colours.symbol ()) Bound_symbols.print bound_symbols (Flambda_colours.elide ()) (Flambda_colours.normal ()) From 1f87b2d2dc48c43d0dfab67d1edf55e58795abd0 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 14:38:48 +0000 Subject: [PATCH 24/80] terms - compiles --- .../flambda2.0/simplify/simplify_expr.rec.ml | 281 +++++++++++++++++- 1 file changed, 279 insertions(+), 2 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index ea06196faa65..e3adc81b5b82 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -25,6 +25,263 @@ open! Simplify_import more transparent (e.g. through [find_continuation]). Tricky potentially in conjunction with the rewrites. *) +(* CR mshinwell: Move the following elsewhere. Maybe make a "lifting" + directory containing this and Reification. *) + +let lift_non_closure_discovered_via_reified_continuation_param_types dacc var + to_lift ~reified_definitions = + let static_const = Reification.create_static_const to_lift in + let symbol = + Symbol.create (Compilation_unit.get_current_exn ()) + (Linkage_name.create (Variable.unique_name var)) + in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + DE.add_equation_on_name (DE.define_symbol denv symbol K.value) + (Name.var var) + (T.alias_type_of K.value (Simple.symbol symbol))) + in + let reified_definitions = + (Let_symbol.Bound_symbols.Singleton symbol, static_const) + :: reified_definitions + in + let reified_continuation_params_to_symbols = + Variable.Map.add var symbol reified_continuation_params_to_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + +let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc + closure_id function_decls ~closure_vars = + let module I = T.Function_declaration_type.Inlinable in + let set_of_closures = + let function_decls = + Closure_id.Map.mapi (fun closure_id inlinable -> + Function_declaration.create ~code_id:(I.code_id inlinable) + ~params_arity:(I.param_arity inlinable) + ~result_arity:(I.result_arity inlinable) + ~stub:(I.stub inlinable) + ~dbg:(I.dbg inlinable) + ~inline:(I.inline inlinable) + ~is_a_functor:(I.is_a_functor inlinable) + ~recursive:(I.recursive inlinable)) + function_decls + |> Function_declarations.create + in + Set_of_closures.create function_decls ~closure_elements:closure_vars + in + let bind_continuation_param_to_symbol dacc ~closure_symbols = + let dacc, symbol = + DA.map_denv2 dacc ~f:(fun denv -> + match Closure_id.Map.find closure_id closure_symbols with + | exception Not_found -> + Misc.fatal_errorf "Variable %a claimed to hold closure with \ + closure ID %a, but no symbol was found for that closure ID" + Variable.print var + Closure_id.print closure_id + | symbol -> + let denv = + DE.add_equation_on_name denv (Name.var var) + (T.alias_type_of K.value (Simple.symbol symbol)) + in + denv, symbol) + in + dacc, Variable.Map.add var symbol reified_continuation_params_to_symbols + in + match Set_of_closures.Map.find set_of_closures closure_symbols_by_set with + | exception Not_found -> + let closure_symbols = + Closure_id.Map.mapi (fun closure_id _function_decl -> + (* CR mshinwell: share name computation with + [Simplify_named] *) + let name = + closure_id + |> Closure_id.rename + |> Closure_id.to_string + |> Linkage_name.create + in + Symbol.create (Compilation_unit.get_current_exn ()) name) + function_decls + in + let definition = + (* We don't need to assign new code IDs, since we're not changing the + code. The code will actually be re-simplified (during + [simplify_static_structure], see below)---at that point, new code IDs + may well be assigned. (That is also the point at which references + to the closures being lifted, via the computed values variables, + will be changed to go via symbols.) *) + Let_symbol_expr.pieces_of_code + ~newer_versions_of:Code_id.Map.empty + ~set_of_closures:(closure_symbols, set_of_closures) + Code_id.Map.empty + in + let reified_definitions = definition :: reified_definitions in + let closure_symbols_by_set = + Set_of_closures.Map.add set_of_closures closure_symbols + closure_symbols_by_set + in + let dacc, reified_continuation_params_to_symbols = + bind_continuation_param_to_symbol dacc ~closure_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + | closure_symbols -> + let dacc, reified_continuation_params_to_symbols = + bind_continuation_param_to_symbol dacc ~closure_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + +let reify_types_of_continuation_param_types dacc + reified_continuation_param_types = + let orig_typing_env = DE.typing_env (DA.denv dacc) in + Variable.Set.fold + (fun var (dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set) -> + let ty = TE.find orig_typing_env (Name.var var) in + let existing_symbol = + (* We must avoid attempting to create aliases between symbols or + (equivalently) defining static parts that already have symbols. + This could happen if [var] is actually equal to another of the + computed value variables. *) + TE.get_canonical_simple (DE.typing_env (DA.denv dacc)) + ~min_name_mode:NM.normal (Simple.var var) + |> Or_bottom.value_map ~bottom:None ~f:Simple.must_be_symbol + in + match existing_symbol with + | Some _ -> + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + | None -> + match + T.reify ~allowed_free_vars:reified_continuation_param_types typing_env + ~min_name_mode:NM.normal ty + with + | Lift to_lift -> + lift_non_closure_discovered_via_reified_continuation_param_types + dacc var to_lift + | Lift_set_of_closures { closure_id; function_decls; closure_vars; } -> + lift_set_of_closures_discovered_via_reified_continuation_param_types + dacc closure_id function_decls ~closure_vars + | Simple _ | Cannot_reify | Invalid -> + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set) + reified_continuation_param_types + (dacc, Variable.Map.empty, [], Set_of_closures.Map.empty) + +module Bindings_top_sort = + Top_closure.Make + (struct + type t = Symbol.Set.Set.t + type elt = Symbol.Set.t + let empty = Symbol.Set.Set.empty + let add t elt = Symbol.Set.Set.add elt t + let mem t elt = Symbol.Set.Set.mem elt t + end) + (struct + type 'a t = 'a + let return t = t + let (>>=) t f = f t + end) + +let lift_via_reification_of_continuation_param_types dacc cont ~params + ~(extra_params_and_args : Continuation_extra_params_and_args.t) + ~(handler : Expr.t) = + let allowed_free_vars = + Variable.Set.union (KP.List.var_set params) + (KP.List.var_set extra_params_and_args.extra_params) + in + let dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set = + reify_types_of_continuation_param_types dacc allowed_free_vars + in + (* CR mshinwell: If recursion extends beyond that which can be handled + by the set-of-closures cases, then we would need a strongly connected + components analysis, prior to the top sort. Any set arising from SCC + that has more than one element must be a complicated recursive case, + which can be dealt with using the "symbol placeholder" approach + (variables that are substituted for the computed values, which are + in turn substituted for symbols at the Cmm translation phase). + (Any case containing >1 set of closures is maybe a bug?) *) + let reified_definitions = + let sorted = + Bindings_top_sort.top_closure reified_definitions + ~key:(fun (bound_syms, _static_const) -> + Bound_symbols.being_defined bound_syms) + ~deps:(fun (bound_syms, static_const) -> + let var_deps = + static_const + |> Static_const.free_names + |> Name_occurrences.variables + |> Variable.Set.elements + in + let sym_deps = + List.fold_left (fun sym_deps var -> + match + Variable.Map.find var reified_continuation_params_to_symbols + with + | exception Not_found -> + Misc.fatal_errorf "No symbol for computed value var %a" + Variable.print var + | symbol -> Symbol.Set.add symbol sym_deps) + Symbol.Set.empty + var_deps + in + let sym_deps = + let closure_symbols_being_defined = + (* Closure symbols are bound recursively within the same set. We + need to remove them from the dependency sets to avoid the + topological sort seeing cycles. We don't unilaterally remove + all symbols in [Bound_symbols.being_defined syms] (as opposed + to [closure_symbols_being_defined]) as, in the case where + illegal recursion has been constructed, it could cause the + topological sort to succeed and the fatal error below to be + concealed. *) + Bound_symbols.closure_symbols_being_defined bound_syms + in + Symbol.Set.diff sym_deps closure_symbols_being_defined + in + Symbol.Set.fold (fun sym deps -> + let dep = + List.find_opt (fun (Static_structure.S (syms, static_const)) -> + Symbol.Set.mem sym + (Bound_symbols.being_defined bound_syms)) + reified_definitions + sym + in + match dep with + | Some dep -> dep :: deps + | None -> + Misc.fatal_errorf "Couldn't find definition for %a" + Symbol.print sym) + sym_deps + []) + in + match sorted with + | Ok sorted -> + List.rev sorted + | Error _ -> + Misc.fatal_errorf "Potential [Let_symbol] bindings arising from reified \ + types of continuation parameters contain recursion that cannot be \ + compiled:@ %a" + Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf (bound_symbols, defining_expr) -> + Format.fprintf ppf "@[%a@ %a@]" + Bound_symbols.print bound_symbols + Static_const.print defining_expr) + sorted + in + (* By effectively reversing the list during the fold, we rely on the + following property: + Let the list L be a topological sort of a directed graph G. + Then the reverse of L is a topological sort of the transpose of G. + *) + List.fold_left (fun handler (bound_symbols, defining_expr) -> + Let_symbol.create bound_symbols defining_expr handler + |> Expr.create_let_symbol) + handler + reified_definitions + type 'a k = CUE.t -> R.t -> ('a * UA.t) let rec simplify_let @@ -87,6 +344,12 @@ and simplify_let_symbol in let defining_expr_lifted_constants_not_in_same_set, bound_symbols, defining_expr = + (* Lifted constants arising from the simplification of the defining + expression are either not recursive with the current definition + (this is always the case for non-closures), or recursive with the + current definition of code and/or closures. In the latter case we + need to ensure that the lifted constants end up in the current + definition, rather than just above it. *) let bound_names = Bound_symbols.free_names bound_symbols in List.fold_left (fun (defining_expr_lifted_constants_not_in_same_set, @@ -306,7 +569,7 @@ and simplify_non_recursive_let_cont_handler | Normal when is_single_inlinable_use -> assert (not is_exn_handler); handler_typing_env, extra_params_and_args - | Normal | Toplevel_return -> + | Normal -> assert (not is_exn_handler); let param_types = TE.find_params handler_typing_env params @@ -314,7 +577,7 @@ and simplify_non_recursive_let_cont_handler Unbox_continuation_params.make_unboxing_decisions handler_typing_env ~arg_types_by_use_id ~params ~param_types extra_params_and_args - | Return -> + | Return | Toplevel_return -> assert (not is_exn_handler); handler_typing_env, extra_params_and_args | Exn -> @@ -325,6 +588,17 @@ and simplify_non_recursive_let_cont_handler DA.create (DE.with_typing_env denv typing_env) cont_uses_env r in + let handler = + match Continuation.sort cont with + | Normal + when is_single_inlinable_use + || not at_unit_toplevel -> handler + | Return | Toplevel_return | Exn -> handler + | Normal -> + assert at_unit_toplevel; + lift_via_reification_of_continuation_param_types dacc + cont ~params ~extra_params_and_args ~handler + in let dacc = if at_unit_toplevel then dacc else DA.map_denv dacc ~f:DE.set_not_at_unit_toplevel @@ -445,6 +719,9 @@ and simplify_recursive_let_cont_handlers DE.add_parameters definition_denv params ~param_types:arg_types in let dacc = DA.create denv cont_uses_env r in + let dacc = + DA.map_denv dacc ~f:DE.set_not_at_unit_toplevel + in let handler, user_data, uacc = simplify_one_continuation_handler dacc cont Recursive cont_handler ~params ~handler From 63ebe6a65b9e2bff180f9f7f4966849de276bd67 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 14:48:24 +0000 Subject: [PATCH 25/80] terms - compiles --- .../lifting/reify_continuation_param_types.ml | 279 ++++++++++++++++++ .../reify_continuation_param_types.mli | 29 ++ .../flambda2.0/simplify/env/downwards_acc.ml | 9 + .../flambda2.0/simplify/env/downwards_acc.mli | 6 + .../flambda2.0/simplify/simplify_expr.rec.ml | 262 +--------------- 5 files changed, 326 insertions(+), 259 deletions(-) create mode 100644 middle_end/flambda2.0/lifting/reify_continuation_param_types.ml create mode 100644 middle_end/flambda2.0/lifting/reify_continuation_param_types.mli diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml new file mode 100644 index 000000000000..8b7ff4f9af66 --- /dev/null +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -0,0 +1,279 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2020 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-30-40-41-42"] + +open! Simplify_import + +let lift_non_closure_discovered_via_reified_continuation_param_types dacc + var to_lift ~reified_continuation_params_to_symbols + ~reified_definitions ~closure_symbols_by_set = + let static_const = Reification.create_static_const to_lift in + let symbol = + Symbol.create (Compilation_unit.get_current_exn ()) + (Linkage_name.create (Variable.unique_name var)) + in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + DE.add_equation_on_name (DE.define_symbol denv symbol K.value) + (Name.var var) + (T.alias_type_of K.value (Simple.symbol symbol))) + in + let reified_definitions = + (Let_symbol.Bound_symbols.Singleton symbol, static_const) + :: reified_definitions + in + let reified_continuation_params_to_symbols = + Variable.Map.add var symbol reified_continuation_params_to_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + +let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc + var closure_id function_decls ~closure_vars + ~reified_continuation_params_to_symbols + ~reified_definitions ~closure_symbols_by_set = + let module I = T.Function_declaration_type.Inlinable in + let set_of_closures = + let function_decls = + Closure_id.Map.mapi (fun closure_id inlinable -> + Function_declaration.create ~code_id:(I.code_id inlinable) + ~params_arity:(I.param_arity inlinable) + ~result_arity:(I.result_arity inlinable) + ~stub:(I.stub inlinable) + ~dbg:(I.dbg inlinable) + ~inline:(I.inline inlinable) + ~is_a_functor:(I.is_a_functor inlinable) + ~recursive:(I.recursive inlinable)) + function_decls + |> Function_declarations.create + in + Set_of_closures.create function_decls ~closure_elements:closure_vars + in + let bind_continuation_param_to_symbol dacc ~closure_symbols = + let dacc, symbol = + DA.map_denv2 dacc ~f:(fun denv -> + match Closure_id.Map.find closure_id closure_symbols with + | exception Not_found -> + Misc.fatal_errorf "Variable %a claimed to hold closure with \ + closure ID %a, but no symbol was found for that closure ID" + Variable.print var + Closure_id.print closure_id + | symbol -> + let denv = + DE.add_equation_on_name denv (Name.var var) + (T.alias_type_of K.value (Simple.symbol symbol)) + in + denv, symbol) + in + dacc, Variable.Map.add var symbol reified_continuation_params_to_symbols + in + match Set_of_closures.Map.find set_of_closures closure_symbols_by_set with + | exception Not_found -> + let closure_symbols = + Closure_id.Map.mapi (fun closure_id _function_decl -> + (* CR mshinwell: share name computation with + [Simplify_named] *) + let name = + closure_id + |> Closure_id.rename + |> Closure_id.to_string + |> Linkage_name.create + in + Symbol.create (Compilation_unit.get_current_exn ()) name) + function_decls + in + let definition = + (* We don't need to assign new code IDs, since we're not changing the + code. The code will actually be re-simplified (when we reach the new + [Let_symbol] bindings)---at that point, new code IDs may well be + assigned. (That is also the point at which references to the closures + being lifted, via the continuation's parameters, will be changed to go + via symbols.) *) + Let_symbol_expr.pieces_of_code + ~newer_versions_of:Code_id.Map.empty + ~set_of_closures:(closure_symbols, set_of_closures) + Code_id.Map.empty + in + let reified_definitions = definition :: reified_definitions in + let closure_symbols_by_set = + Set_of_closures.Map.add set_of_closures closure_symbols + closure_symbols_by_set + in + let dacc, reified_continuation_params_to_symbols = + bind_continuation_param_to_symbol dacc ~closure_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + | closure_symbols -> + let dacc, reified_continuation_params_to_symbols = + bind_continuation_param_to_symbol dacc ~closure_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + +let reify_types_of_continuation_param_types dacc + reified_continuation_param_types = + let orig_typing_env = DE.typing_env (DA.denv dacc) in + Variable.Set.fold + (fun var (dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set) -> + let ty = TE.find orig_typing_env (Name.var var) in + let existing_symbol = + (* We must avoid attempting to create aliases between symbols or + (equivalently) defining static parts that already have symbols. + This could happen if [var] is actually equal to another of the + continuation's parameters. *) + TE.get_canonical_simple (DE.typing_env (DA.denv dacc)) + ~min_name_mode:NM.normal (Simple.var var) + |> Or_bottom.value_map ~bottom:None ~f:Simple.must_be_symbol + in + match existing_symbol with + | Some _ -> + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + | None -> + match + T.reify ~allowed_free_vars:reified_continuation_param_types typing_env + ~min_name_mode:NM.normal ty + with + | Lift to_lift -> + lift_non_closure_discovered_via_reified_continuation_param_types + dacc var to_lift ~reified_continuation_params_to_symbols + ~reified_definitions ~closure_symbols_by_set + | Lift_set_of_closures { closure_id; function_decls; closure_vars; } -> + lift_set_of_closures_discovered_via_reified_continuation_param_types + dacc var closure_id function_decls ~closure_vars + ~reified_continuation_params_to_symbols + ~reified_definitions ~closure_symbols_by_set + | Simple _ | Cannot_reify | Invalid -> + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set) + reified_continuation_param_types + (dacc, Variable.Map.empty, [], Set_of_closures.Map.empty) + +module Bindings_top_sort = + Top_closure.Make + (struct + type t = Symbol.Set.Set.t + type elt = Symbol.Set.t + let empty = Symbol.Set.Set.empty + let add t elt = Symbol.Set.Set.add elt t + let mem t elt = Symbol.Set.Set.mem elt t + end) + (struct + type 'a t = 'a + let return t = t + let (>>=) t f = f t + end) + +let lift_via_reification_of_continuation_param_types dacc cont ~params + ~(extra_params_and_args : Continuation_extra_params_and_args.t) + ~(handler : Expr.t) = + let allowed_free_vars = + Variable.Set.union (KP.List.var_set params) + (KP.List.var_set extra_params_and_args.extra_params) + in + let dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set = + reify_types_of_continuation_param_types dacc allowed_free_vars + in + (* CR mshinwell: If recursion extends beyond that which can be handled + by the set-of-closures cases, then we would need a strongly connected + components analysis, prior to the top sort. Any set arising from SCC + that has more than one element must be a complicated recursive case, + which could be dealt with using the "symbol placeholder" approach + (variables that are substituted for the continuation's parameters, which + are in turn substituted for symbols at the Cmm translation phase). + (Any case containing >1 set of closures is maybe a bug?) *) + let reified_definitions = + let sorted = + Bindings_top_sort.top_closure reified_definitions + ~key:(fun (bound_syms, _static_const) -> + Bound_symbols.being_defined bound_syms) + ~deps:(fun (bound_syms, static_const) -> + let var_deps = + static_const + |> Static_const.free_names + |> Name_occurrences.variables + |> Variable.Set.elements + in + let sym_deps = + List.fold_left (fun sym_deps var -> + match + Variable.Map.find var reified_continuation_params_to_symbols + with + | exception Not_found -> + Misc.fatal_errorf "No symbol for continuation parameter %a" + Variable.print var + | symbol -> Symbol.Set.add symbol sym_deps) + Symbol.Set.empty + var_deps + in + let sym_deps = + let closure_symbols_being_defined = + (* Closure symbols are bound recursively within the same set. We + need to remove them from the dependency sets to avoid the + topological sort seeing cycles. We don't unilaterally remove + all symbols in [Bound_symbols.being_defined syms] (as opposed + to [closure_symbols_being_defined]) as, in the case where + illegal recursion has been constructed, it could cause the + topological sort to succeed and the fatal error below to be + concealed. *) + Bound_symbols.closure_symbols_being_defined bound_syms + in + Symbol.Set.diff sym_deps closure_symbols_being_defined + in + Symbol.Set.fold (fun sym deps -> + let dep = + List.find_opt (fun (Static_structure.S (syms, static_const)) -> + Symbol.Set.mem sym + (Bound_symbols.being_defined bound_syms)) + reified_definitions + sym + in + match dep with + | Some dep -> dep :: deps + | None -> + Misc.fatal_errorf "Couldn't find definition for %a" + Symbol.print sym) + sym_deps + []) + in + match sorted with + | Ok sorted -> + List.rev sorted + | Error _ -> + Misc.fatal_errorf "Potential [Let_symbol] bindings arising from reified \ + types of continuation parameters contain recursion that cannot be \ + compiled:@ %a" + Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf (bound_symbols, defining_expr) -> + Format.fprintf ppf "@[%a@ %a@]" + Bound_symbols.print bound_symbols + Static_const.print defining_expr) + sorted + in + (* By effectively reversing the list during the fold, we rely on the + following property: + Let the list L be a topological sort of a directed graph G. + Then the reverse of L is a topological sort of the transpose of G. + *) + List.fold_left (fun handler (bound_symbols, defining_expr) -> + Let_symbol.create bound_symbols defining_expr handler + |> Expr.create_let_symbol) + handler + reified_definitions diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli b/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli new file mode 100644 index 000000000000..996aad03ea41 --- /dev/null +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2020 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. *) +(* *) +(**************************************************************************) + +(** Attempt to statically-allocate values whose structure can be deduced + by examining the types of the parameters of continuations occurring + at toplevel. *) + +[@@@ocaml.warning "+a-30-40-41-42"] + +val lift_via_reification_of_continuation_param_types + : Downwards_acc.t + -> Continuation.t + -> params:Kinded_parameter.List.t + -> extra_params_and_args:Continuation_extra_params_and_args.t + -> handler:Flambda.Expr.t + -> Flambda.Expr.t diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.ml b/middle_end/flambda2.0/simplify/env/downwards_acc.ml index 176be994bc06..d7c30e30ed25 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.ml +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.ml @@ -49,6 +49,15 @@ let map_denv t ~f = denv = f t.denv; } +let map_denv2 t ~f = + let denv, user_data = f t.denv in + let t = + { t with + denv; + } + in + t, user_data + let with_denv t denv = { t with denv; diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.mli b/middle_end/flambda2.0/simplify/env/downwards_acc.mli index 2fb4ccfb7461..9c99731d5286 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.mli +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.mli @@ -38,6 +38,12 @@ val map_denv -> Simplify_env_and_result.Downwards_env.t) -> t +val map_denv2 + : t + -> f:(Simplify_env_and_result.Downwards_env.t + -> Simplify_env_and_result.Downwards_env.t * 'a) + -> t * 'a + (** Replace the environment component of the given downwards accumulator. *) val with_denv : t -> Simplify_env_and_result.Downwards_env.t -> t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index e3adc81b5b82..0ba989950607 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -25,263 +25,6 @@ open! Simplify_import more transparent (e.g. through [find_continuation]). Tricky potentially in conjunction with the rewrites. *) -(* CR mshinwell: Move the following elsewhere. Maybe make a "lifting" - directory containing this and Reification. *) - -let lift_non_closure_discovered_via_reified_continuation_param_types dacc var - to_lift ~reified_definitions = - let static_const = Reification.create_static_const to_lift in - let symbol = - Symbol.create (Compilation_unit.get_current_exn ()) - (Linkage_name.create (Variable.unique_name var)) - in - let dacc = - DA.map_denv dacc ~f:(fun denv -> - DE.add_equation_on_name (DE.define_symbol denv symbol K.value) - (Name.var var) - (T.alias_type_of K.value (Simple.symbol symbol))) - in - let reified_definitions = - (Let_symbol.Bound_symbols.Singleton symbol, static_const) - :: reified_definitions - in - let reified_continuation_params_to_symbols = - Variable.Map.add var symbol reified_continuation_params_to_symbols - in - dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set - -let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc - closure_id function_decls ~closure_vars = - let module I = T.Function_declaration_type.Inlinable in - let set_of_closures = - let function_decls = - Closure_id.Map.mapi (fun closure_id inlinable -> - Function_declaration.create ~code_id:(I.code_id inlinable) - ~params_arity:(I.param_arity inlinable) - ~result_arity:(I.result_arity inlinable) - ~stub:(I.stub inlinable) - ~dbg:(I.dbg inlinable) - ~inline:(I.inline inlinable) - ~is_a_functor:(I.is_a_functor inlinable) - ~recursive:(I.recursive inlinable)) - function_decls - |> Function_declarations.create - in - Set_of_closures.create function_decls ~closure_elements:closure_vars - in - let bind_continuation_param_to_symbol dacc ~closure_symbols = - let dacc, symbol = - DA.map_denv2 dacc ~f:(fun denv -> - match Closure_id.Map.find closure_id closure_symbols with - | exception Not_found -> - Misc.fatal_errorf "Variable %a claimed to hold closure with \ - closure ID %a, but no symbol was found for that closure ID" - Variable.print var - Closure_id.print closure_id - | symbol -> - let denv = - DE.add_equation_on_name denv (Name.var var) - (T.alias_type_of K.value (Simple.symbol symbol)) - in - denv, symbol) - in - dacc, Variable.Map.add var symbol reified_continuation_params_to_symbols - in - match Set_of_closures.Map.find set_of_closures closure_symbols_by_set with - | exception Not_found -> - let closure_symbols = - Closure_id.Map.mapi (fun closure_id _function_decl -> - (* CR mshinwell: share name computation with - [Simplify_named] *) - let name = - closure_id - |> Closure_id.rename - |> Closure_id.to_string - |> Linkage_name.create - in - Symbol.create (Compilation_unit.get_current_exn ()) name) - function_decls - in - let definition = - (* We don't need to assign new code IDs, since we're not changing the - code. The code will actually be re-simplified (during - [simplify_static_structure], see below)---at that point, new code IDs - may well be assigned. (That is also the point at which references - to the closures being lifted, via the computed values variables, - will be changed to go via symbols.) *) - Let_symbol_expr.pieces_of_code - ~newer_versions_of:Code_id.Map.empty - ~set_of_closures:(closure_symbols, set_of_closures) - Code_id.Map.empty - in - let reified_definitions = definition :: reified_definitions in - let closure_symbols_by_set = - Set_of_closures.Map.add set_of_closures closure_symbols - closure_symbols_by_set - in - let dacc, reified_continuation_params_to_symbols = - bind_continuation_param_to_symbol dacc ~closure_symbols - in - dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set - | closure_symbols -> - let dacc, reified_continuation_params_to_symbols = - bind_continuation_param_to_symbol dacc ~closure_symbols - in - dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set - -let reify_types_of_continuation_param_types dacc - reified_continuation_param_types = - let orig_typing_env = DE.typing_env (DA.denv dacc) in - Variable.Set.fold - (fun var (dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set) -> - let ty = TE.find orig_typing_env (Name.var var) in - let existing_symbol = - (* We must avoid attempting to create aliases between symbols or - (equivalently) defining static parts that already have symbols. - This could happen if [var] is actually equal to another of the - computed value variables. *) - TE.get_canonical_simple (DE.typing_env (DA.denv dacc)) - ~min_name_mode:NM.normal (Simple.var var) - |> Or_bottom.value_map ~bottom:None ~f:Simple.must_be_symbol - in - match existing_symbol with - | Some _ -> - dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set - | None -> - match - T.reify ~allowed_free_vars:reified_continuation_param_types typing_env - ~min_name_mode:NM.normal ty - with - | Lift to_lift -> - lift_non_closure_discovered_via_reified_continuation_param_types - dacc var to_lift - | Lift_set_of_closures { closure_id; function_decls; closure_vars; } -> - lift_set_of_closures_discovered_via_reified_continuation_param_types - dacc closure_id function_decls ~closure_vars - | Simple _ | Cannot_reify | Invalid -> - dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set) - reified_continuation_param_types - (dacc, Variable.Map.empty, [], Set_of_closures.Map.empty) - -module Bindings_top_sort = - Top_closure.Make - (struct - type t = Symbol.Set.Set.t - type elt = Symbol.Set.t - let empty = Symbol.Set.Set.empty - let add t elt = Symbol.Set.Set.add elt t - let mem t elt = Symbol.Set.Set.mem elt t - end) - (struct - type 'a t = 'a - let return t = t - let (>>=) t f = f t - end) - -let lift_via_reification_of_continuation_param_types dacc cont ~params - ~(extra_params_and_args : Continuation_extra_params_and_args.t) - ~(handler : Expr.t) = - let allowed_free_vars = - Variable.Set.union (KP.List.var_set params) - (KP.List.var_set extra_params_and_args.extra_params) - in - let dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set = - reify_types_of_continuation_param_types dacc allowed_free_vars - in - (* CR mshinwell: If recursion extends beyond that which can be handled - by the set-of-closures cases, then we would need a strongly connected - components analysis, prior to the top sort. Any set arising from SCC - that has more than one element must be a complicated recursive case, - which can be dealt with using the "symbol placeholder" approach - (variables that are substituted for the computed values, which are - in turn substituted for symbols at the Cmm translation phase). - (Any case containing >1 set of closures is maybe a bug?) *) - let reified_definitions = - let sorted = - Bindings_top_sort.top_closure reified_definitions - ~key:(fun (bound_syms, _static_const) -> - Bound_symbols.being_defined bound_syms) - ~deps:(fun (bound_syms, static_const) -> - let var_deps = - static_const - |> Static_const.free_names - |> Name_occurrences.variables - |> Variable.Set.elements - in - let sym_deps = - List.fold_left (fun sym_deps var -> - match - Variable.Map.find var reified_continuation_params_to_symbols - with - | exception Not_found -> - Misc.fatal_errorf "No symbol for computed value var %a" - Variable.print var - | symbol -> Symbol.Set.add symbol sym_deps) - Symbol.Set.empty - var_deps - in - let sym_deps = - let closure_symbols_being_defined = - (* Closure symbols are bound recursively within the same set. We - need to remove them from the dependency sets to avoid the - topological sort seeing cycles. We don't unilaterally remove - all symbols in [Bound_symbols.being_defined syms] (as opposed - to [closure_symbols_being_defined]) as, in the case where - illegal recursion has been constructed, it could cause the - topological sort to succeed and the fatal error below to be - concealed. *) - Bound_symbols.closure_symbols_being_defined bound_syms - in - Symbol.Set.diff sym_deps closure_symbols_being_defined - in - Symbol.Set.fold (fun sym deps -> - let dep = - List.find_opt (fun (Static_structure.S (syms, static_const)) -> - Symbol.Set.mem sym - (Bound_symbols.being_defined bound_syms)) - reified_definitions - sym - in - match dep with - | Some dep -> dep :: deps - | None -> - Misc.fatal_errorf "Couldn't find definition for %a" - Symbol.print sym) - sym_deps - []) - in - match sorted with - | Ok sorted -> - List.rev sorted - | Error _ -> - Misc.fatal_errorf "Potential [Let_symbol] bindings arising from reified \ - types of continuation parameters contain recursion that cannot be \ - compiled:@ %a" - Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf (bound_symbols, defining_expr) -> - Format.fprintf ppf "@[%a@ %a@]" - Bound_symbols.print bound_symbols - Static_const.print defining_expr) - sorted - in - (* By effectively reversing the list during the fold, we rely on the - following property: - Let the list L be a topological sort of a directed graph G. - Then the reverse of L is a topological sort of the transpose of G. - *) - List.fold_left (fun handler (bound_symbols, defining_expr) -> - Let_symbol.create bound_symbols defining_expr handler - |> Expr.create_let_symbol) - handler - reified_definitions - type 'a k = CUE.t -> R.t -> ('a * UA.t) let rec simplify_let @@ -596,8 +339,9 @@ and simplify_non_recursive_let_cont_handler | Return | Toplevel_return | Exn -> handler | Normal -> assert at_unit_toplevel; - lift_via_reification_of_continuation_param_types dacc - cont ~params ~extra_params_and_args ~handler + Reify_continuation_param_types. + lift_via_reification_of_continuation_param_types dacc + cont ~params ~extra_params_and_args ~handler in let dacc = if at_unit_toplevel then dacc From 4d920fe58a2f54234555485d4751e530f9228ab1 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 14:53:59 +0000 Subject: [PATCH 26/80] terms - compiles --- middle_end/flambda2.0/basic/simple.ml | 5 +++ middle_end/flambda2.0/basic/simple.mli | 2 + .../lifting/reify_continuation_param_types.ml | 9 +++-- .../flambda2.0/terms/function_declaration.ml | 5 +++ .../flambda2.0/terms/function_declaration.mli | 2 + .../flambda2.0/terms/function_declarations.ml | 3 ++ .../terms/function_declarations.mli | 2 + .../flambda2.0/terms/set_of_closures.ml | 38 +++++++++++++++++++ .../flambda2.0/terms/set_of_closures.mli | 2 + .../flambda2.0/types/basic/or_bottom.ml | 5 +++ .../flambda2.0/types/basic/or_bottom.mli | 2 + 11 files changed, 71 insertions(+), 4 deletions(-) diff --git a/middle_end/flambda2.0/basic/simple.ml b/middle_end/flambda2.0/basic/simple.ml index 5d6e62ada2fd..079c8066e53d 100644 --- a/middle_end/flambda2.0/basic/simple.ml +++ b/middle_end/flambda2.0/basic/simple.ml @@ -196,6 +196,11 @@ let must_be_var t = | Name (Var var) | Rec_name (Var var, _) -> Some var | Name _ | Rec_name (_, _) | Const _ -> None +let must_be_symbol t = + match t with + | Name (Symbol sym) | Rec_name (Symbol sym, _) -> Some sym + | Name _ | Rec_name (_, _) | Const _ -> None + let allowed t ~allowed = match must_be_var t with | None -> true diff --git a/middle_end/flambda2.0/basic/simple.mli b/middle_end/flambda2.0/basic/simple.mli index eeb12cda9649..5aab962c27cd 100644 --- a/middle_end/flambda2.0/basic/simple.mli +++ b/middle_end/flambda2.0/basic/simple.mli @@ -65,6 +65,8 @@ val merge_rec_info : t -> newer_rec_info:Rec_info.t option -> t option val must_be_var : t -> Variable.t option +val must_be_symbol : t -> Symbol.t option + (** The constant representating the given number of type "int". *) val const_int : Targetint.OCaml.t -> t diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index 8b7ff4f9af66..f63cf72bfb85 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -103,7 +103,7 @@ let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc assigned. (That is also the point at which references to the closures being lifted, via the continuation's parameters, will be changed to go via symbols.) *) - Let_symbol_expr.pieces_of_code + Let_symbol.pieces_of_code ~newer_versions_of:Code_id.Map.empty ~set_of_closures:(closure_symbols, set_of_closures) Code_id.Map.empty @@ -139,7 +139,8 @@ let reify_types_of_continuation_param_types dacc continuation's parameters. *) TE.get_canonical_simple (DE.typing_env (DA.denv dacc)) ~min_name_mode:NM.normal (Simple.var var) - |> Or_bottom.value_map ~bottom:None ~f:Simple.must_be_symbol + |> Or_bottom.value_map ~bottom:None + ~f:(Option.map Simple.must_be_symbol) in match existing_symbol with | Some _ -> @@ -147,8 +148,8 @@ let reify_types_of_continuation_param_types dacc closure_symbols_by_set | None -> match - T.reify ~allowed_free_vars:reified_continuation_param_types typing_env - ~min_name_mode:NM.normal ty + T.reify ~allowed_free_vars:reified_continuation_param_types + (DE.typing_env (DA.denv dacc)) ~min_name_mode:NM.normal ty with | Lift to_lift -> lift_non_closure_discovered_via_reified_continuation_param_types diff --git a/middle_end/flambda2.0/terms/function_declaration.ml b/middle_end/flambda2.0/terms/function_declaration.ml index ac5e2b6f1974..9b1508e94c3f 100644 --- a/middle_end/flambda2.0/terms/function_declaration.ml +++ b/middle_end/flambda2.0/terms/function_declaration.ml @@ -133,3 +133,8 @@ let free_names let apply_name_permutation t _perm = t let update_code_id t code_id = { t with code_id; } + +(* CR mshinwell: In the "equal" case this should assert that all of the + other things in [t1] and [t2] are equal *) +let compare t1 t2 = + Code_id.compare t1.code_id t2.code_id diff --git a/middle_end/flambda2.0/terms/function_declaration.mli b/middle_end/flambda2.0/terms/function_declaration.mli index 566c5be5d1f9..f51c1cb37784 100644 --- a/middle_end/flambda2.0/terms/function_declaration.mli +++ b/middle_end/flambda2.0/terms/function_declaration.mli @@ -68,3 +68,5 @@ val update_code_id : t -> Code_id.t -> t (** Whether the function is recursive, in the sense of the syntactic analysis conducted during closure conversion. *) val recursive : t -> Recursive.t + +val compare : t -> t -> int diff --git a/middle_end/flambda2.0/terms/function_declarations.ml b/middle_end/flambda2.0/terms/function_declarations.ml index 93ec6b658fa2..c094c272ed5f 100644 --- a/middle_end/flambda2.0/terms/function_declarations.ml +++ b/middle_end/flambda2.0/terms/function_declarations.ml @@ -56,3 +56,6 @@ let apply_name_permutation ({ funs; } as t) perm = let disjoint_union t1 t2 = let funs = Closure_id.Map.disjoint_union t1.funs t2.funs in { funs; } + +let compare { funs = funs1; } { funs = funs2; } = + Closure_id.Map.compare Function_declaration.compare funs1 funs2 diff --git a/middle_end/flambda2.0/terms/function_declarations.mli b/middle_end/flambda2.0/terms/function_declarations.mli index 38135e7f4840..d1c7931959b0 100644 --- a/middle_end/flambda2.0/terms/function_declarations.mli +++ b/middle_end/flambda2.0/terms/function_declarations.mli @@ -50,3 +50,5 @@ val funs : t -> Function_declaration.t Closure_id.Map.t val find : t -> Closure_id.t -> Function_declaration.t val disjoint_union : t -> t -> t + +val compare : t -> t -> int diff --git a/middle_end/flambda2.0/terms/set_of_closures.ml b/middle_end/flambda2.0/terms/set_of_closures.ml index a9e564f5ed3e..8cd0faec5bfb 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.ml +++ b/middle_end/flambda2.0/terms/set_of_closures.ml @@ -21,6 +21,44 @@ type t = { closure_elements : Simple.t Var_within_closure.Map.t; } +let print_with_cache ~cache ppf + { function_decls; + closure_elements; + } = + Format.fprintf ppf "@[(%sset_of_closures%s@ \ + @[(function_decls@ %a)@]@ \ + @[(closure_elements@ %a)@]\ + )@]" + (Flambda_colours.prim_constructive ()) + (Flambda_colours.normal ()) + (Function_declarations.print_with_cache ~cache) function_decls + (Var_within_closure.Map.print Simple.print) closure_elements + +include Identifiable.Make (struct + type nonrec t = t + + let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t + + let output _ _ = Misc.fatal_error "Not yet implemented" + + let hash _ = Misc.fatal_error "Not yet implemented" + + let compare + { function_decls = function_decls1; + closure_elements = closure_elements1; + } + { function_decls = function_decls2; + closure_elements = closure_elements2; + } = + let c = Function_declarations.compare function_decls1 function_decls2 in + if c <> 0 then c + else + Var_within_closure.Map.compare Simple.compare + closure_elements1 closure_elements2 + + let equal t1 t2 = (compare t1 t2 = 0) +end) + (* CR mshinwell: A sketch of code for the invariant check is on cps_types. *) let invariant _env _t = () diff --git a/middle_end/flambda2.0/terms/set_of_closures.mli b/middle_end/flambda2.0/terms/set_of_closures.mli index 69644141d048..c21686be2186 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.mli +++ b/middle_end/flambda2.0/terms/set_of_closures.mli @@ -43,3 +43,5 @@ val has_empty_environment : t -> bool val environment_doesn't_mention_variables : t -> bool val disjoint_union : t -> t -> t + +include Identifiable.S with type t := t diff --git a/middle_end/flambda2.0/types/basic/or_bottom.ml b/middle_end/flambda2.0/types/basic/or_bottom.ml index be9f541825ae..c7f0ccdaa21f 100644 --- a/middle_end/flambda2.0/types/basic/or_bottom.ml +++ b/middle_end/flambda2.0/types/basic/or_bottom.ml @@ -35,6 +35,11 @@ let map t ~f = | Ok contents -> Ok (f contents) | Bottom -> Bottom +let value_map t ~bottom ~f = + match t with + | Ok contents -> f contents + | Bottom -> bottom + let all ts = let contents = List.filter_map (fun t -> diff --git a/middle_end/flambda2.0/types/basic/or_bottom.mli b/middle_end/flambda2.0/types/basic/or_bottom.mli index 6819fe863a83..89e054937ffe 100644 --- a/middle_end/flambda2.0/types/basic/or_bottom.mli +++ b/middle_end/flambda2.0/types/basic/or_bottom.mli @@ -30,4 +30,6 @@ val both : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val map : 'a t -> f:('a -> 'b) -> 'b t +val value_map : 'a t -> bottom:'b -> f:('a -> 'b) -> 'b + val all : 'a t list -> 'a list t From a1f5e45739a6ef22ac0721e484fdf40e6ca68ee3 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 15:03:24 +0000 Subject: [PATCH 27/80] terms - compiles - inc new unboxing --- .../lifting/reify_continuation_param_types.ml | 39 ++++++++++--------- .../reify_continuation_param_types.mli | 3 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 8 ++-- utils/identifiable.ml | 35 ++++++++++------- utils/identifiable.mli | 2 + 5 files changed, 48 insertions(+), 39 deletions(-) diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index f63cf72bfb85..93b38a362740 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -49,7 +49,7 @@ let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc let module I = T.Function_declaration_type.Inlinable in let set_of_closures = let function_decls = - Closure_id.Map.mapi (fun closure_id inlinable -> + Closure_id.Map.map (fun inlinable -> Function_declaration.create ~code_id:(I.code_id inlinable) ~params_arity:(I.param_arity inlinable) ~result_arity:(I.result_arity inlinable) @@ -181,7 +181,7 @@ module Bindings_top_sort = let (>>=) t f = f t end) -let lift_via_reification_of_continuation_param_types dacc cont ~params +let lift_via_reification_of_continuation_param_types dacc ~params ~(extra_params_and_args : Continuation_extra_params_and_args.t) ~(handler : Expr.t) = let allowed_free_vars = @@ -189,7 +189,7 @@ let lift_via_reification_of_continuation_param_types dacc cont ~params (KP.List.var_set extra_params_and_args.extra_params) in let dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set = + _closure_symbols_by_set = reify_types_of_continuation_param_types dacc allowed_free_vars in (* CR mshinwell: If recursion extends beyond that which can be handled @@ -204,7 +204,7 @@ let lift_via_reification_of_continuation_param_types dacc cont ~params let sorted = Bindings_top_sort.top_closure reified_definitions ~key:(fun (bound_syms, _static_const) -> - Bound_symbols.being_defined bound_syms) + Let_symbol.Bound_symbols.being_defined bound_syms) ~deps:(fun (bound_syms, static_const) -> let var_deps = static_const @@ -234,17 +234,16 @@ let lift_via_reification_of_continuation_param_types dacc cont ~params illegal recursion has been constructed, it could cause the topological sort to succeed and the fatal error below to be concealed. *) - Bound_symbols.closure_symbols_being_defined bound_syms + Let_symbol.Bound_symbols.closure_symbols_being_defined bound_syms in Symbol.Set.diff sym_deps closure_symbols_being_defined in Symbol.Set.fold (fun sym deps -> let dep = - List.find_opt (fun (Static_structure.S (syms, static_const)) -> + List.find_opt (fun (bound_symbols, _static_const) -> Symbol.Set.mem sym - (Bound_symbols.being_defined bound_syms)) + (Let_symbol.Bound_symbols.being_defined bound_symbols)) reified_definitions - sym in match dep with | Some dep -> dep :: deps @@ -255,26 +254,28 @@ let lift_via_reification_of_continuation_param_types dacc cont ~params []) in match sorted with - | Ok sorted -> - List.rev sorted + | Ok sorted -> sorted | Error _ -> Misc.fatal_errorf "Potential [Let_symbol] bindings arising from reified \ types of continuation parameters contain recursion that cannot be \ compiled:@ %a" - Format.pp_print_list ~pp_sep:Format.pp_print_space + (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (bound_symbols, defining_expr) -> Format.fprintf ppf "@[%a@ %a@]" - Bound_symbols.print bound_symbols - Static_const.print defining_expr) - sorted + Let_symbol.Bound_symbols.print bound_symbols + Static_const.print defining_expr)) + reified_definitions in (* By effectively reversing the list during the fold, we rely on the following property: Let the list L be a topological sort of a directed graph G. Then the reverse of L is a topological sort of the transpose of G. *) - List.fold_left (fun handler (bound_symbols, defining_expr) -> - Let_symbol.create bound_symbols defining_expr handler - |> Expr.create_let_symbol) - handler - reified_definitions + let handler = + List.fold_left (fun handler (bound_symbols, defining_expr) -> + Let_symbol.create bound_symbols defining_expr handler + |> Expr.create_let_symbol) + handler + reified_definitions + in + dacc, handler diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli b/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli index 996aad03ea41..030af7a246e6 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.mli @@ -22,8 +22,7 @@ val lift_via_reification_of_continuation_param_types : Downwards_acc.t - -> Continuation.t -> params:Kinded_parameter.List.t -> extra_params_and_args:Continuation_extra_params_and_args.t -> handler:Flambda.Expr.t - -> Flambda.Expr.t + -> Downwards_acc.t * Flambda.Expr.t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 0ba989950607..1210eacc0f36 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -331,17 +331,17 @@ and simplify_non_recursive_let_cont_handler DA.create (DE.with_typing_env denv typing_env) cont_uses_env r in - let handler = + let dacc, handler = match Continuation.sort cont with | Normal when is_single_inlinable_use - || not at_unit_toplevel -> handler - | Return | Toplevel_return | Exn -> handler + || not at_unit_toplevel -> dacc, handler + | Return | Toplevel_return | Exn -> dacc, handler | Normal -> assert at_unit_toplevel; Reify_continuation_param_types. lift_via_reification_of_continuation_param_types dacc - cont ~params ~extra_params_and_args ~handler + ~params ~extra_params_and_args ~handler in let dacc = if at_unit_toplevel then dacc diff --git a/utils/identifiable.ml b/utils/identifiable.ml index a930919a9962..9b419325b37a 100644 --- a/utils/identifiable.ml +++ b/utils/identifiable.ml @@ -33,6 +33,8 @@ module type Set = sig val to_string : t -> string val of_list : elt list -> t val map : (elt -> elt) -> t -> t + + module Set : Set.S with type elt = t end module type Map = sig @@ -220,25 +222,30 @@ module Make_map (T : Thing) (Set : Set with module T := T) = struct end module Make_set (T : Thing) = struct - include Set.Make (T) + module T0 = struct + include Set.Make (T) + + let output oc s = + Printf.fprintf oc " ( "; + iter (fun v -> Printf.fprintf oc "%a " T.output v) s; + Printf.fprintf oc ")" - let output oc s = - Printf.fprintf oc " ( "; - iter (fun v -> Printf.fprintf oc "%a " T.output v) s; - Printf.fprintf oc ")" + let print ppf s = + let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in + Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s - let print ppf s = - let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in - Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s + let to_string s = Format.asprintf "%a" print s - let to_string s = Format.asprintf "%a" print s + let of_list l = match l with + | [] -> empty + | [t] -> singleton t + | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q - let of_list l = match l with - | [] -> empty - | [t] -> singleton t - | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q + let map f s = of_list (List.map f (elements s)) + end - let map f s = of_list (List.map f (elements s)) + include T0 + module Set = Set.Make (T0) end module Make_tbl (T : Thing) (Map : Map with module T := T) = struct diff --git a/utils/identifiable.mli b/utils/identifiable.mli index 6c7dd2a1a2e9..9e4442910086 100644 --- a/utils/identifiable.mli +++ b/utils/identifiable.mli @@ -43,6 +43,8 @@ module type Set = sig val to_string : t -> string val of_list : elt list -> t val map : (elt -> elt) -> t -> t + + module Set : Set.S with type elt = t end module type Map = sig From ab9a8a90d7d1e873490ba45976c2d6248ceda73a Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 16:12:15 +0000 Subject: [PATCH 28/80] terms - compiles - inc new unboxing --- .../flambda2.0/from_lambda/cps_conversion.ml | 4 ++-- .../typing_helpers => lifting}/reification.ml | 0 .../typing_helpers => lifting}/reification.mli | 0 .../lifting/reify_continuation_param_types.ml | 16 ++++++++++++---- .../flambda2.0/simplify/simplify_expr.rec.ml | 15 ++++++++------- .../simplify/simplify_static_const.rec.ml | 4 +++- 6 files changed, 25 insertions(+), 14 deletions(-) rename middle_end/flambda2.0/{simplify/typing_helpers => lifting}/reification.ml (100%) rename middle_end/flambda2.0/{simplify/typing_helpers => lifting}/reification.mli (100%) diff --git a/middle_end/flambda2.0/from_lambda/cps_conversion.ml b/middle_end/flambda2.0/from_lambda/cps_conversion.ml index 9ddd55a0fed6..4abd47c46d07 100644 --- a/middle_end/flambda2.0/from_lambda/cps_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/cps_conversion.ml @@ -709,8 +709,8 @@ let lambda_to_ilambda lam ~recursive_static_catches:recursive_static_catches' recursive_static_catches := recursive_static_catches'; seen_let_mutable := false; (* [the_end] is not a [Toplevel_return] continuation---the toplevel return - continuation is introduced by [Closure_conversion]. *) - let the_end = Continuation.create () in + continuation is introduced by [Closure_conversion]. *) (* XXX *) + let the_end = Continuation.create ~sort:Toplevel_return () in let the_end_exn = Continuation.create ~sort:Exn () in let ilam = cps_tail lam the_end the_end_exn in let exn_continuation : I.exn_continuation = diff --git a/middle_end/flambda2.0/simplify/typing_helpers/reification.ml b/middle_end/flambda2.0/lifting/reification.ml similarity index 100% rename from middle_end/flambda2.0/simplify/typing_helpers/reification.ml rename to middle_end/flambda2.0/lifting/reification.ml diff --git a/middle_end/flambda2.0/simplify/typing_helpers/reification.mli b/middle_end/flambda2.0/lifting/reification.mli similarity index 100% rename from middle_end/flambda2.0/simplify/typing_helpers/reification.mli rename to middle_end/flambda2.0/lifting/reification.mli diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index 93b38a362740..4fffdc43a8f3 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -96,6 +96,13 @@ let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc Symbol.create (Compilation_unit.get_current_exn ()) name) function_decls in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Closure_id.Map.fold (fun _closure_id closure_symbol denv -> + DE.define_symbol denv closure_symbol K.value) + closure_symbols + denv) + in let definition = (* We don't need to assign new code IDs, since we're not changing the code. The code will actually be re-simplified (when we reach the new @@ -143,10 +150,10 @@ let reify_types_of_continuation_param_types dacc ~f:(Option.map Simple.must_be_symbol) in match existing_symbol with - | Some _ -> + | Some (Some _) -> dacc, reified_continuation_params_to_symbols, reified_definitions, closure_symbols_by_set - | None -> + | None | Some None -> match T.reify ~allowed_free_vars:reified_continuation_param_types (DE.typing_env (DA.denv dacc)) ~min_name_mode:NM.normal ty @@ -188,6 +195,7 @@ let lift_via_reification_of_continuation_param_types dacc ~params Variable.Set.union (KP.List.var_set params) (KP.List.var_set extra_params_and_args.extra_params) in +Format.eprintf "allowed free vars %a\n%!" Variable.Set.print allowed_free_vars; let dacc, reified_continuation_params_to_symbols, reified_definitions, _closure_symbols_by_set = reify_types_of_continuation_param_types dacc allowed_free_vars @@ -218,8 +226,8 @@ let lift_via_reification_of_continuation_param_types dacc ~params Variable.Map.find var reified_continuation_params_to_symbols with | exception Not_found -> - Misc.fatal_errorf "No symbol for continuation parameter %a" - Variable.print var + (* The variable's type couldn't be reified. *) + sym_deps | symbol -> Symbol.Set.add symbol sym_deps) Symbol.Set.empty var_deps diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 1210eacc0f36..6ed68ce7d692 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -50,6 +50,9 @@ and simplify_let_symbol end; let module Bound_symbols = LS.Bound_symbols in let bound_symbols = LS.bound_symbols let_symbol_expr in + (* CR mshinwell: We can't do this in conjunction with the current + reification scheme for continuation parameters; that has to put the + symbols in the environment. Symbol.Set.iter (fun sym -> if DE.mem_symbol (DA.denv dacc) sym then begin Misc.fatal_errorf "Symbol %a is already defined:@ %a" @@ -63,7 +66,7 @@ and simplify_let_symbol Code_id.print code_id LS.print let_symbol_expr end) - (Bound_symbols.code_being_defined bound_symbols); + (Bound_symbols.code_being_defined bound_symbols); *) let defining_expr = LS.defining_expr let_symbol_expr in let body = LS.body let_symbol_expr in let prior_lifted_constants = R.get_lifted_constants (DA.r dacc) in @@ -266,8 +269,6 @@ and simplify_non_recursive_let_cont_handler cannot. *) DE.at_unit_toplevel denv && (not (Continuation_handler.is_exn_handler cont_handler)) - && Variable.Set.is_empty - (Name_occurrences.variables free_names_of_body) && Continuation.Set.subset (Name_occurrences.continuations free_names_of_body) (Continuation.Set.of_list [cont; unit_toplevel_exn_cont]) @@ -312,7 +313,7 @@ and simplify_non_recursive_let_cont_handler | Normal when is_single_inlinable_use -> assert (not is_exn_handler); handler_typing_env, extra_params_and_args - | Normal -> + | Normal | Toplevel_return -> assert (not is_exn_handler); let param_types = TE.find_params handler_typing_env params @@ -320,7 +321,7 @@ and simplify_non_recursive_let_cont_handler Unbox_continuation_params.make_unboxing_decisions handler_typing_env ~arg_types_by_use_id ~params ~param_types extra_params_and_args - | Return | Toplevel_return -> + | Return -> assert (not is_exn_handler); handler_typing_env, extra_params_and_args | Exn -> @@ -336,8 +337,8 @@ and simplify_non_recursive_let_cont_handler | Normal when is_single_inlinable_use || not at_unit_toplevel -> dacc, handler - | Return | Toplevel_return | Exn -> dacc, handler - | Normal -> + | Return | Exn -> dacc, handler + | Normal | Toplevel_return -> assert at_unit_toplevel; Reify_continuation_param_types. lift_via_reification_of_continuation_param_types dacc diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index a36d12b1adde..e0b38b0ed9d7 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -121,7 +121,9 @@ let simplify_static_const_of_kind_value dacc DA.map_denv dacc ~f:(fun denv -> let denv = (* [result_sym] will already be defined when we are lifting - reified computed values (see below). *) + reified continuation parameters. *) + (* CR mshinwell: This is kind of nasty---try to rearrange things + so this doesn't happen. *) DE.define_symbol_if_undefined denv result_sym K.value in DE.add_equation_on_symbol denv result_sym typ) From 94c2c1e8cedb3cb01d69e65f35da8b92d68b3cd9 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 16:53:20 +0000 Subject: [PATCH 29/80] deletion --- .../flambda2.0/naming/name_occurrences.ml | 1 + .../flambda2.0/naming/name_occurrences.mli | 4 + .../flambda2.0/simplify/env/downwards_acc.ml | 10 +++ .../flambda2.0/simplify/env/downwards_acc.mli | 4 + .../flambda2.0/simplify/env/upwards_acc.ml | 12 ++- .../flambda2.0/simplify/env/upwards_acc.mli | 7 +- .../flambda2.0/simplify/simplify_common.ml | 86 +++++++++++++++++++ .../flambda2.0/simplify/simplify_common.mli | 7 ++ .../flambda2.0/simplify/simplify_expr.rec.ml | 75 +++++++++++----- .../flambda2.0/simplify/simplify_expr.rec.mli | 1 + .../flambda2.0/simplify/simplify_import.ml | 1 + .../flambda2.0/simplify/simplify_import.mli | 1 + .../simplify/simplify_toplevel.rec.ml | 21 ++--- .../flambda2.0/types/env/typing_env.rec.ml | 3 + .../flambda2.0/types/env/typing_env.rec.mli | 2 + middle_end/flambda2.0/types/flambda_type.mli | 2 + 16 files changed, 201 insertions(+), 36 deletions(-) diff --git a/middle_end/flambda2.0/naming/name_occurrences.ml b/middle_end/flambda2.0/naming/name_occurrences.ml index 7c708e84e335..f5ad02a01afa 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.ml +++ b/middle_end/flambda2.0/naming/name_occurrences.ml @@ -564,6 +564,7 @@ let names t = let mem_var t var = For_variables.mem t.variables var let mem_symbol t symbol = For_symbols.mem t.symbols symbol +let mem_code_id t code_id = For_code_ids.mem t.code_ids code_id let mem_name t (name : Name.t) = match name with diff --git a/middle_end/flambda2.0/naming/name_occurrences.mli b/middle_end/flambda2.0/naming/name_occurrences.mli index 6dd31213eb50..3b78847d2e80 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.mli +++ b/middle_end/flambda2.0/naming/name_occurrences.mli @@ -114,8 +114,12 @@ val newer_version_of_code_ids : t -> Code_id.Set.t val mem_var : t -> Variable.t -> bool +val mem_symbol : t -> Symbol.t -> bool + val mem_name : t -> Name.t -> bool +val mem_code_id : t -> Code_id.t -> bool + val remove_var : t -> Variable.t -> t val remove_vars : t -> Variable.Set.t -> t diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.ml b/middle_end/flambda2.0/simplify/env/downwards_acc.ml index d7c30e30ed25..45f78d48c3db 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.ml +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.ml @@ -19,6 +19,7 @@ module CUE = Continuation_uses_env module DE = Simplify_env_and_result.Downwards_env module R = Simplify_env_and_result.Result +module TE = Flambda_type.Typing_env type t = { denv : DE.t; @@ -96,3 +97,12 @@ let num_continuation_uses t cont = CUE.num_continuation_uses t.continuation_uses_env cont let continuation_uses_env t = t.continuation_uses_env + +let code_age_relation t = + TE.code_age_relation (DE.typing_env (denv t)) + +let with_code_age_relation t code_age_relation = + let typing_env = + TE.with_code_age_relation (DE.typing_env (denv t)) code_age_relation + in + with_denv t (DE.with_typing_env (denv t) typing_env) diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.mli b/middle_end/flambda2.0/simplify/env/downwards_acc.mli index 9c99731d5286..a9d4bc5e3034 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.mli +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.mli @@ -65,3 +65,7 @@ val with_r : t -> Simplify_env_and_result.Result.t -> t include Continuation_uses_env_intf.S with type t := t val continuation_uses_env : t -> Continuation_uses_env.t + +val code_age_relation : t -> Code_age_relation.t + +val with_code_age_relation : t -> Code_age_relation.t -> t diff --git a/middle_end/flambda2.0/simplify/env/upwards_acc.ml b/middle_end/flambda2.0/simplify/env/upwards_acc.ml index 0e755f3b3a93..dc6b3f3a9724 100644 --- a/middle_end/flambda2.0/simplify/env/upwards_acc.ml +++ b/middle_end/flambda2.0/simplify/env/upwards_acc.ml @@ -17,33 +17,41 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] module DA = Downwards_acc +module DE = Simplify_env_and_result.Downwards_env module R = Simplify_env_and_result.Result +module TE = Flambda_type.Typing_env module UE = Simplify_env_and_result.Upwards_env type t = { uenv : UE.t; + code_age_relation : Code_age_relation.t; r : R.t; } -let print ppf { uenv; r; } = +let print ppf { uenv; code_age_relation; r; } = Format.fprintf ppf "@[(\ @[(uenv@ %a)@]@ \ + @[(code_age_relation@ %a)@]@ \ @[(r@ %a)@]\ )@]" UE.print uenv + Code_age_relation.print code_age_relation R.print r -let create uenv r = +let create uenv code_age_relation r = { uenv; + code_age_relation; r; } let of_dacc dacc = { uenv = UE.empty; + code_age_relation = TE.code_age_relation (DE.typing_env (DA.denv dacc)); r = DA.r dacc; } let uenv t = t.uenv +let code_age_relation t = t.code_age_relation let map_uenv t ~f = { t with diff --git a/middle_end/flambda2.0/simplify/env/upwards_acc.mli b/middle_end/flambda2.0/simplify/env/upwards_acc.mli index 8497ba427f38..efe0ff52373f 100644 --- a/middle_end/flambda2.0/simplify/env/upwards_acc.mli +++ b/middle_end/flambda2.0/simplify/env/upwards_acc.mli @@ -23,16 +23,19 @@ val print : Format.formatter -> t -> unit val create : Simplify_env_and_result.Upwards_env.t + -> Code_age_relation.t -> Simplify_env_and_result.Result.t -> t -(** Create an upwards accumulator by copying the result structure out of - the given downwards accumulator. *) +(** Create an upwards accumulator by copying the result structure and + code age relation out of the given downwards accumulator. *) val of_dacc : Downwards_acc.t -> t (** Extract the environment component of the given upwards accumulator. *) val uenv : t -> Simplify_env_and_result.Upwards_env.t +val code_age_relation : t -> Code_age_relation.t + (** Map the environment component of the given upwards accumulator. *) val map_uenv : t diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 85e503ae6f25..56f77db65d4b 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -156,3 +156,89 @@ let bind_let_bound ~bindings ~body = | Set_of_closures _ -> Expr.create_pattern_let bound defining_expr expr) body (List.rev bindings) + +let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) + (static_const : Static_const.t) body = + let free_names_after = Expr.free_names body in + let symbols_after = Name_occurrences.symbols free_names_after in + match bound_symbols with + | Singleton sym -> + if Symbol.Set.mem sym symbols_after then + Let_symbol.create bound_symbols static_const body + |> Expr.create_let_symbol + else + body + | Code_and_set_of_closures { code_ids; closure_symbols; } -> + let code, set_of_closures = + (* CR mshinwell: Move to [Static_const.must_be_code] or something *) + match static_const with + | Code_and_set_of_closures { code; set_of_closures; } -> + code, set_of_closures + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ + | Immutable_string _ -> + Misc.fatal_errorf "Illegal [Let_symbol] binding of %a@ to@ %a" + Bound_symbols.print bound_symbols + Static_const.print static_const + in + let free_names_in_const = Static_const.free_names static_const in + let code = + Code_id.Map.mapi + (fun code_id + ({ params_and_body; newer_version_of; } : Static_const.code) + : Static_const.code -> + let params_and_body : _ Static_const.or_deleted = + match params_and_body with + | Deleted -> Deleted + | Present _ -> + let code_unused = + (not (Name_occurrences.mem_code_id free_names_after code_id)) + && (not (Name_occurrences.mem_code_id free_names_in_const + code_id)) + in + let can_delete_code = + (* We cannot delete code unless it is certain that a + non-trivial join operation between later versions of it + cannot happen. *) + code_unused + && Code_age_relation.newer_versions_form_linear_chain + code_age_relation code_id + in + if can_delete_code then Deleted + else params_and_body + in + { params_and_body; newer_version_of; }) + code + in + (* For the moment we don't delete individual closures from sets of closures. + We could do this, but we would be relying on 100% conversion of + [Select_closure] expressions to symbols (which should happen, but even + still). *) + let all_closure_symbols_unused = + Symbol.Set.for_all (fun symbol -> + (not (Name_occurrences.mem_symbol free_names_after symbol)) + && (not (Name_occurrences.mem_symbol free_names_in_const symbol))) + (Bound_symbols.closure_symbols_being_defined bound_symbols) + in + let set_of_closures = + if all_closure_symbols_unused then None + else set_of_closures + in + let static_const : Static_const.t = + Code_and_set_of_closures { + code; + set_of_closures; + } + in + let closure_symbols = + if all_closure_symbols_unused then Closure_id.Map.empty + else closure_symbols + in + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { code_ids; closure_symbols; } + in + if Code_id.Set.is_empty code_ids && Closure_id.Map.is_empty closure_symbols + then body + else + Let_symbol.create bound_symbols static_const body + |> Expr.create_let_symbol diff --git a/middle_end/flambda2.0/simplify/simplify_common.mli b/middle_end/flambda2.0/simplify/simplify_common.mli index 57a7683b504e..814116be0047 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.mli +++ b/middle_end/flambda2.0/simplify/simplify_common.mli @@ -73,3 +73,10 @@ val bind_let_bound : bindings:((Bindable_let_bound.t * Reachable.t) list) -> body:Flambda.Expr.t -> Flambda.Expr.t + +val create_let_symbol + : Code_age_relation.t + -> Flambda.Let_symbol_expr.Bound_symbols.t + -> Flambda.Static_const.t + -> Flambda.Expr.t + -> Flambda.Expr.t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 6ed68ce7d692..7b83a62ef3b8 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -25,7 +25,7 @@ open! Simplify_import more transparent (e.g. through [find_continuation]). Tricky potentially in conjunction with the rewrites. *) -type 'a k = CUE.t -> R.t -> ('a * UA.t) +type 'a k = CUE.t -> Code_age_relation.t -> R.t -> ('a * UA.t) let rec simplify_let : 'a. DA.t -> Let.t -> 'a k -> Expr.t * 'a * UA.t @@ -147,11 +147,10 @@ and simplify_let_symbol LC.bound_symbols lifted_constant, LC.defining_expr lifted_constant) subsequent_lifted_constants in - (* XXX This should do the deletion of the [Let_symbol]s, since we need the - code age relation to do that. *) let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> - Expr.create_let_symbol (LS.create bound_symbols defining_expr body)) + Simplify_common.create_let_symbol (UA.code_age_relation uacc) + bound_symbols defining_expr body) body (List.rev bindings_outermost_first) in @@ -283,7 +282,10 @@ and simplify_non_recursive_let_cont_handler let dacc = DA.with_denv dacc (DE.increment_continuation_scope_level denv) in - simplify_expr dacc body (fun cont_uses_env r -> + simplify_expr dacc body (fun cont_uses_env code_age_relation r -> + (* CR mshinwell: Could assert that the code age relation is + a superset. *) + let dacc = DA.with_code_age_relation dacc code_age_relation in (* Format.eprintf "Parameters for %a: %a\n%!" Continuation.print cont @@ -304,7 +306,8 @@ and simplify_non_recursive_let_cont_handler otherwise, its code will be deleted but any continuation usage information collected during its simplification will remain. *) - let user_data, uacc = k cont_uses_env r in + let code_age_relation = DA.code_age_relation dacc in + let user_data, uacc = k cont_uses_env code_age_relation r in cont_handler, user_data, uacc, false | Uses { handler_typing_env; arg_types_by_use_id; extra_params_and_args; is_single_inlinable_use; } -> @@ -440,7 +443,7 @@ and simplify_recursive_let_cont_handlers in (* let set = Continuation_handlers.domain rec_handlers in *) let body, (handlers, user_data), uacc = - simplify_expr dacc body (fun cont_uses_env r -> + simplify_expr dacc body (fun cont_uses_env _code_age_relation r -> let arg_types = (* We can't know a good type from the call types *) List.map T.unknown arity @@ -472,8 +475,8 @@ and simplify_recursive_let_cont_handlers cont_handler ~params ~handler ~extra_params_and_args: Continuation_extra_params_and_args.empty - (fun cont_uses_env r -> - let user_data, uacc = k cont_uses_env r in + (fun cont_uses_env code_age_relation r -> + let user_data, uacc = k cont_uses_env code_age_relation r in let uacc = UA.map_uenv uacc ~f:(fun uenv -> UE.add_continuation uenv cont @@ -556,7 +559,9 @@ Format.eprintf "Simplifying inlined body with DE depth delta = %d\n%!" ~arg_types:(T.unknown_types_from_arity ( Exn_continuation.arity (Apply.exn_continuation apply))) in - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in let apply = Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id apply @@ -803,7 +808,9 @@ and simplify_direct_function_call in match callee's_code_id with | Bottom -> - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in Expr.create_invalid (), user_data, uacc | Ok callee's_code_id -> let call_kind = @@ -898,7 +905,9 @@ and simplify_function_call_where_callee's_type_unavailable in call_kind, use_id, dacc in - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in let apply = Apply.with_call_kind apply call_kind |> Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id @@ -980,13 +989,18 @@ Format.eprintf "For call to %a: callee's rec info is %a, rec info from type of f ~recursive:(N.recursive non_inlinable) None k | Bottom -> - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) + (DA.r dacc) + in Expr.create_invalid (), user_data, uacc | Unknown -> type_unavailable () end | Unknown -> type_unavailable () | Invalid -> - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in Expr.create_invalid (), user_data, uacc and simplify_apply_shared dacc apply : _ Or_bottom.t = @@ -1061,7 +1075,9 @@ and simplify_method_call in (* CR mshinwell: Need to record exception continuation use (check all other cases like this too) *) - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in let apply = Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id apply @@ -1117,7 +1133,9 @@ and simplify_c_call ~arg_types:(T.unknown_types_from_arity ( Exn_continuation.arity (Apply.exn_continuation apply))) in - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in (* CR mshinwell: Make sure that [resolve_continuation_aliases] has been called before building of any term that contains a continuation *) let apply = @@ -1135,7 +1153,9 @@ and simplify_apply = fun dacc apply k -> match simplify_apply_shared dacc apply with | Bottom -> - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in Expr.create_invalid (), user_data, uacc | Ok (callee_ty, apply, arg_types) -> match Apply.call_kind apply with @@ -1154,7 +1174,9 @@ and simplify_apply_cont let min_name_mode = Name_mode.normal in match S.simplify_simples dacc (AC.args apply_cont) ~min_name_mode with | Bottom -> - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in Expr.create_invalid (), user_data, uacc | Ok args_with_types -> let args, arg_types = List.split args_with_types in @@ -1186,7 +1208,9 @@ Format.eprintf "Apply_cont %a: arg types %a, rewrite ID %a\n%!" Format.eprintf "Apply_cont starts out being %a\n%!" Apply_cont.print apply_cont; *) - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in let uenv = UA.uenv uacc in let rewrite = UE.find_apply_cont_rewrite uenv (AC.continuation apply_cont) in let cont = @@ -1310,7 +1334,9 @@ and simplify_switch let min_name_mode = Name_mode.normal in let scrutinee = Switch.scrutinee switch in let invalid () = - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in Expr.create_invalid (), user_data, uacc in (* @@ -1360,7 +1386,9 @@ and simplify_switch arms (Immediate.Map.empty, dacc) in - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in let uenv = UA.uenv uacc in let new_let_conts, arms, identity_arms, not_arms = Immediate.Map.fold @@ -1501,5 +1529,8 @@ and simplify_expr | Apply_cont apply_cont -> simplify_apply_cont dacc apply_cont k | Switch switch -> simplify_switch dacc switch k | Invalid _ -> - let user_data, uacc = k (DA.continuation_uses_env dacc) (DA.r dacc) in + let user_data, uacc = + (* CR mshinwell: Factor out into [Simplify_common] *) + k (DA.continuation_uses_env dacc) (DA.code_age_relation dacc) (DA.r dacc) + in expr, user_data, uacc diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.mli b/middle_end/flambda2.0/simplify/simplify_expr.rec.mli index 9ff5058fc1e6..9d1adcb5cec3 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.mli +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.mli @@ -18,6 +18,7 @@ type 'a k = Continuation_uses_env.t + -> Code_age_relation.t -> Simplify_env_and_result.Result.t -> ('a * Upwards_acc.t) diff --git a/middle_end/flambda2.0/simplify/simplify_import.ml b/middle_end/flambda2.0/simplify/simplify_import.ml index fc0bad377b2e..c51e5568106f 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.ml +++ b/middle_end/flambda2.0/simplify/simplify_import.ml @@ -18,6 +18,7 @@ module Apply = Flambda.Apply module Apply_cont = Flambda.Apply_cont +module Bound_symbols = Flambda.Let_symbol_expr.Bound_symbols module Continuation_handler = Flambda.Continuation_handler module Continuation_handlers = Flambda.Continuation_handlers module Continuation_params_and_handler = Flambda.Continuation_params_and_handler diff --git a/middle_end/flambda2.0/simplify/simplify_import.mli b/middle_end/flambda2.0/simplify/simplify_import.mli index fc0bad377b2e..c51e5568106f 100644 --- a/middle_end/flambda2.0/simplify/simplify_import.mli +++ b/middle_end/flambda2.0/simplify/simplify_import.mli @@ -18,6 +18,7 @@ module Apply = Flambda.Apply module Apply_cont = Flambda.Apply_cont +module Bound_symbols = Flambda.Let_symbol_expr.Bound_symbols module Continuation_handler = Flambda.Continuation_handler module Continuation_handlers = Flambda.Continuation_handlers module Continuation_params_and_handler = Flambda.Continuation_params_and_handler diff --git a/middle_end/flambda2.0/simplify/simplify_toplevel.rec.ml b/middle_end/flambda2.0/simplify/simplify_toplevel.rec.ml index 13458e1e081a..68d67668d569 100644 --- a/middle_end/flambda2.0/simplify/simplify_toplevel.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_toplevel.rec.ml @@ -22,16 +22,17 @@ let simplify_toplevel dacc expr ~return_continuation ~return_arity exn_continuation ~return_cont_scope ~exn_cont_scope = let expr, cont_uses_env, uacc = try - Simplify_expr.simplify_expr dacc expr (fun cont_uses_env r -> - let uenv = - UE.add_continuation UE.empty return_continuation - return_cont_scope return_arity - in - let uenv = - UE.add_exn_continuation uenv exn_continuation - exn_cont_scope - in - cont_uses_env, UA.create uenv r) + Simplify_expr.simplify_expr dacc expr + (fun cont_uses_env code_age_relation r -> + let uenv = + UE.add_continuation UE.empty return_continuation + return_cont_scope return_arity + in + let uenv = + UE.add_exn_continuation uenv exn_continuation + exn_cont_scope + in + cont_uses_env, UA.create uenv code_age_relation r) with Misc.Fatal_error -> begin if !Clflags.flambda2_context_on_error then begin Format.eprintf "\n%sContext is:%s simplifying toplevel \ diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.ml b/middle_end/flambda2.0/types/env/typing_env.rec.ml index 29e89c808f0f..3271bfb12545 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.ml +++ b/middle_end/flambda2.0/types/env/typing_env.rec.ml @@ -751,6 +751,9 @@ let add_to_code_age_relation t ~newer ~older = let code_age_relation t = t.code_age_relation +let with_code_age_relation t code_age_relation = + { t with code_age_relation; } + let cut t ~unknown_if_defined_at_or_later_than:min_scope = let current_scope = current_scope t in let original_t = t in diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.mli b/middle_end/flambda2.0/types/env/typing_env.rec.mli index 853c47ee758e..afb9cbdd797a 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.mli +++ b/middle_end/flambda2.0/types/env/typing_env.rec.mli @@ -122,6 +122,8 @@ val add_to_code_age_relation : t -> newer:Code_id.t -> older:Code_id.t -> t val code_age_relation : t -> Code_age_relation.t +val with_code_age_relation : t -> Code_age_relation.t -> t + (* CR mshinwell: Consider labelling arguments e.g. [definition_typing_env] *) val cut_and_n_way_join : t diff --git a/middle_end/flambda2.0/types/flambda_type.mli b/middle_end/flambda2.0/types/flambda_type.mli index a7d8e4bd6f7e..9f7ca221bb06 100644 --- a/middle_end/flambda2.0/types/flambda_type.mli +++ b/middle_end/flambda2.0/types/flambda_type.mli @@ -137,6 +137,8 @@ module Typing_env : sig val code_age_relation : t -> Code_age_relation.t + val with_code_age_relation : t -> Code_age_relation.t -> t + val cut_and_n_way_join : t -> (t * Apply_cont_rewrite_id.t * Continuation_use_kind.t From a2e22b048093e4bb9ac835aeb67134fba6f8a246 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 17:05:45 +0000 Subject: [PATCH 30/80] free names / deletion --- .../flambda2.0/simplify/simplify_common.ml | 39 ++++++++++++++++--- .../flambda2.0/terms/function_declarations.ml | 4 ++ .../terms/function_declarations.mli | 2 + .../flambda2.0/terms/set_of_closures.ml | 8 ++++ .../flambda2.0/terms/set_of_closures.mli | 5 +++ 5 files changed, 53 insertions(+), 5 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 56f77db65d4b..1bf6df071126 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -181,7 +181,6 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) Bound_symbols.print bound_symbols Static_const.print static_const in - let free_names_in_const = Static_const.free_names static_const in let code = Code_id.Map.mapi (fun code_id @@ -191,9 +190,28 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) match params_and_body with | Deleted -> Deleted | Present _ -> + (* CR mshinwell: The binding can be completely removed (rather + than going to, or staying as, [Deleted]) if no subsequent + [newer_version_of] references it. *) + (* CR mshinwell: The "free_names_in_others" stuff is + inefficient. *) + let free_names_in_others = + let code = + Code_id.Map.add code_id + (Static_const. { + params_and_body = Deleted; + newer_version_of = None; + }) + code + in + let static_const : Static_const.t = + Code_and_set_of_closures { code; set_of_closures; } + in + Static_const.free_names static_const + in let code_unused = (not (Name_occurrences.mem_code_id free_names_after code_id)) - && (not (Name_occurrences.mem_code_id free_names_in_const + && (not (Name_occurrences.mem_code_id free_names_in_others code_id)) in let can_delete_code = @@ -215,10 +233,21 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) [Select_closure] expressions to symbols (which should happen, but even still). *) let all_closure_symbols_unused = - Symbol.Set.for_all (fun symbol -> + Closure_id.Map.for_all (fun closure_id symbol -> + let free_names_in_others = + match set_of_closures with + | Some set -> + let set = + Set_of_closures.filter_function_declarations set + ~f:(fun closure_id' _ -> + not (Closure_id.equal closure_id closure_id')) + in + Set_of_closures.free_names set + | None -> assert false + in (not (Name_occurrences.mem_symbol free_names_after symbol)) - && (not (Name_occurrences.mem_symbol free_names_in_const symbol))) - (Bound_symbols.closure_symbols_being_defined bound_symbols) + && (not (Name_occurrences.mem_symbol free_names_in_others symbol))) + closure_symbols in let set_of_closures = if all_closure_symbols_unused then None diff --git a/middle_end/flambda2.0/terms/function_declarations.ml b/middle_end/flambda2.0/terms/function_declarations.ml index c094c272ed5f..41a82ce367fa 100644 --- a/middle_end/flambda2.0/terms/function_declarations.ml +++ b/middle_end/flambda2.0/terms/function_declarations.ml @@ -59,3 +59,7 @@ let disjoint_union t1 t2 = let compare { funs = funs1; } { funs = funs2; } = Closure_id.Map.compare Function_declaration.compare funs1 funs2 + +let filter t ~f = + let funs = Closure_id.Map.filter f t.funs in + { funs; } diff --git a/middle_end/flambda2.0/terms/function_declarations.mli b/middle_end/flambda2.0/terms/function_declarations.mli index d1c7931959b0..3d97e13e06ce 100644 --- a/middle_end/flambda2.0/terms/function_declarations.mli +++ b/middle_end/flambda2.0/terms/function_declarations.mli @@ -52,3 +52,5 @@ val find : t -> Closure_id.t -> Function_declaration.t val disjoint_union : t -> t -> t val compare : t -> t -> int + +val filter : t -> f:(Closure_id.t -> Function_declaration.t -> bool) -> t diff --git a/middle_end/flambda2.0/terms/set_of_closures.ml b/middle_end/flambda2.0/terms/set_of_closures.ml index 8cd0faec5bfb..586beb6f0ae1 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.ml +++ b/middle_end/flambda2.0/terms/set_of_closures.ml @@ -137,3 +137,11 @@ let disjoint_union t1 t2 = { function_decls; closure_elements; } + +let filter_function_declarations t ~f = + let function_decls = + Function_declarations.filter t.function_decls ~f + in + { t with + function_decls; + } diff --git a/middle_end/flambda2.0/terms/set_of_closures.mli b/middle_end/flambda2.0/terms/set_of_closures.mli index c21686be2186..48b2ebea2452 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.mli +++ b/middle_end/flambda2.0/terms/set_of_closures.mli @@ -44,4 +44,9 @@ val environment_doesn't_mention_variables : t -> bool val disjoint_union : t -> t -> t +val filter_function_declarations + : t + -> f:(Closure_id.t -> Function_declaration.t -> bool) + -> t + include Identifiable.S with type t := t From 9f5fcb93d1bd86e5c9f8a06c5e6fc5e585758e24 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 17:12:47 +0000 Subject: [PATCH 31/80] free names / deletion --- middle_end/flambda2.0/simplify/simplify_common.ml | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 1bf6df071126..9e896ccb1541 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -161,6 +161,8 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) (static_const : Static_const.t) body = let free_names_after = Expr.free_names body in let symbols_after = Name_occurrences.symbols free_names_after in +Format.eprintf "Creating let_symbol for %a, code age relation:@ %a\n%!" + Bound_symbols.print bound_symbols Code_age_relation.print code_age_relation; match bound_symbols with | Singleton sym -> if Symbol.Set.mem sym symbols_after then @@ -194,16 +196,9 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) than going to, or staying as, [Deleted]) if no subsequent [newer_version_of] references it. *) (* CR mshinwell: The "free_names_in_others" stuff is - inefficient. *) + inefficient and hacky. *) let free_names_in_others = - let code = - Code_id.Map.add code_id - (Static_const. { - params_and_body = Deleted; - newer_version_of = None; - }) - code - in + let code = Code_id.Map.remove code_id code in let static_const : Static_const.t = Code_and_set_of_closures { code; set_of_closures; } in From 7d6982ffd595c2c10091d6df78d9878054bf4ab8 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Jan 2020 17:14:48 +0000 Subject: [PATCH 32/80] free names / deletion --- middle_end/flambda2.0/lifting/reify_continuation_param_types.ml | 1 - middle_end/flambda2.0/simplify/simplify_common.ml | 2 -- 2 files changed, 3 deletions(-) diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index 4fffdc43a8f3..fa04dd9daaba 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -195,7 +195,6 @@ let lift_via_reification_of_continuation_param_types dacc ~params Variable.Set.union (KP.List.var_set params) (KP.List.var_set extra_params_and_args.extra_params) in -Format.eprintf "allowed free vars %a\n%!" Variable.Set.print allowed_free_vars; let dacc, reified_continuation_params_to_symbols, reified_definitions, _closure_symbols_by_set = reify_types_of_continuation_param_types dacc allowed_free_vars diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 9e896ccb1541..08beefe6e159 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -161,8 +161,6 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) (static_const : Static_const.t) body = let free_names_after = Expr.free_names body in let symbols_after = Name_occurrences.symbols free_names_after in -Format.eprintf "Creating let_symbol for %a, code age relation:@ %a\n%!" - Bound_symbols.print bound_symbols Code_age_relation.print code_age_relation; match bound_symbols with | Singleton sym -> if Symbol.Set.mem sym symbols_after then From 566b2b14c681803b9ada83435dc12be244acdb99 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 10:37:27 +0000 Subject: [PATCH 33/80] free names / deletion --- middle_end/flambda2.0/basic/continuation.ml | 1 + middle_end/flambda2.0/basic/continuation.mli | 1 + .../from_lambda/closure_conversion.ml | 4 +- .../flambda2.0/from_lambda/cps_conversion.ml | 4 +- .../lifting/reify_continuation_param_types.ml | 27 +++++--- .../flambda2.0/simplify/simplify_expr.rec.ml | 64 +++++++++++-------- .../simplify/template/simplify.templ.ml | 1 - .../flambda2.0/terms/apply_cont_expr.ml | 23 +++++-- middle_end/flambda2.0/terms/flambda_unit.ml | 11 +--- middle_end/flambda2.0/terms/flambda_unit.mli | 5 -- 10 files changed, 81 insertions(+), 60 deletions(-) diff --git a/middle_end/flambda2.0/basic/continuation.ml b/middle_end/flambda2.0/basic/continuation.ml index 3517208b4650..08e727639f91 100644 --- a/middle_end/flambda2.0/basic/continuation.ml +++ b/middle_end/flambda2.0/basic/continuation.ml @@ -32,6 +32,7 @@ end; type sort = | Normal | Return + | Define_root_symbol | Toplevel_return | Exn diff --git a/middle_end/flambda2.0/basic/continuation.mli b/middle_end/flambda2.0/basic/continuation.mli index 324468eafe83..fdfa0f435a4c 100644 --- a/middle_end/flambda2.0/basic/continuation.mli +++ b/middle_end/flambda2.0/basic/continuation.mli @@ -23,6 +23,7 @@ include Identifiable.S type sort = | Normal | Return + | Define_root_symbol | Toplevel_return | Exn diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index 34d72ad62bf1..082e1d918dbf 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -972,5 +972,5 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words Backend.all_predefined_exception_symbols imported_symbols in - Flambda_unit.create ~imported_symbols ~root_symbol:module_symbol - ~return_continuation:return_cont ~exn_continuation ~body + Flambda_unit.create ~imported_symbols ~return_continuation:return_cont + ~exn_continuation ~body diff --git a/middle_end/flambda2.0/from_lambda/cps_conversion.ml b/middle_end/flambda2.0/from_lambda/cps_conversion.ml index 4abd47c46d07..0983ccbacb7d 100644 --- a/middle_end/flambda2.0/from_lambda/cps_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/cps_conversion.ml @@ -708,9 +708,7 @@ let lambda_to_ilambda lam ~recursive_static_catches:recursive_static_catches' try_stack_at_handler := Continuation.Map.empty; recursive_static_catches := recursive_static_catches'; seen_let_mutable := false; - (* [the_end] is not a [Toplevel_return] continuation---the toplevel return - continuation is introduced by [Closure_conversion]. *) (* XXX *) - let the_end = Continuation.create ~sort:Toplevel_return () in + let the_end = Continuation.create ~sort:Define_root_symbol () in let the_end_exn = Continuation.create ~sort:Exn () in let ilam = cps_tail lam the_end the_end_exn in let exn_continuation : I.exn_continuation = diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index fa04dd9daaba..0984dd27cec9 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -132,8 +132,7 @@ let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc dacc, reified_continuation_params_to_symbols, reified_definitions, closure_symbols_by_set -let reify_types_of_continuation_param_types dacc - reified_continuation_param_types = +let reify_types_of_continuation_param_types dacc ~params = let orig_typing_env = DE.typing_env (DA.denv dacc) in Variable.Set.fold (fun var (dacc, reified_continuation_params_to_symbols, reified_definitions, @@ -154,9 +153,17 @@ let reify_types_of_continuation_param_types dacc dacc, reified_continuation_params_to_symbols, reified_definitions, closure_symbols_by_set | None | Some None -> + (* Since the continuation we're dealing with might be inlined and + we don't handle [extra_params_and_args] on such continuations at + the [Apply_cont] site, be certain that the only variables appearing + in our new [Let_symbol] bindings don't involve any of those + (extra) parameters. *) + let typing_env = DE.typing_env (DA.denv dacc) in + let allowed_free_vars = + Variable.Set.diff (TE.var_domain typing_env) params + in match - T.reify ~allowed_free_vars:reified_continuation_param_types - (DE.typing_env (DA.denv dacc)) ~min_name_mode:NM.normal ty + T.reify ~allowed_free_vars typing_env ~min_name_mode:NM.normal ty with | Lift to_lift -> lift_non_closure_discovered_via_reified_continuation_param_types @@ -170,7 +177,7 @@ let reify_types_of_continuation_param_types dacc | Simple _ | Cannot_reify | Invalid -> dacc, reified_continuation_params_to_symbols, reified_definitions, closure_symbols_by_set) - reified_continuation_param_types + params (dacc, Variable.Map.empty, [], Set_of_closures.Map.empty) module Bindings_top_sort = @@ -191,13 +198,13 @@ module Bindings_top_sort = let lift_via_reification_of_continuation_param_types dacc ~params ~(extra_params_and_args : Continuation_extra_params_and_args.t) ~(handler : Expr.t) = - let allowed_free_vars = - Variable.Set.union (KP.List.var_set params) - (KP.List.var_set extra_params_and_args.extra_params) - in let dacc, reified_continuation_params_to_symbols, reified_definitions, _closure_symbols_by_set = - reify_types_of_continuation_param_types dacc allowed_free_vars + let params = + Variable.Set.union (KP.List.var_set params) + (KP.List.var_set extra_params_and_args.extra_params) + in + reify_types_of_continuation_param_types dacc ~params in (* CR mshinwell: If recursion extends beyond that which can be handled by the set-of-closures cases, then we would need a strongly connected diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 7b83a62ef3b8..670391d7c314 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -316,7 +316,7 @@ and simplify_non_recursive_let_cont_handler | Normal when is_single_inlinable_use -> assert (not is_exn_handler); handler_typing_env, extra_params_and_args - | Normal | Toplevel_return -> + | Normal | Define_root_symbol -> assert (not is_exn_handler); let param_types = TE.find_params handler_typing_env params @@ -324,7 +324,7 @@ and simplify_non_recursive_let_cont_handler Unbox_continuation_params.make_unboxing_decisions handler_typing_env ~arg_types_by_use_id ~params ~param_types extra_params_and_args - | Return -> + | Return | Toplevel_return -> assert (not is_exn_handler); handler_typing_env, extra_params_and_args | Exn -> @@ -340,8 +340,10 @@ and simplify_non_recursive_let_cont_handler | Normal when is_single_inlinable_use || not at_unit_toplevel -> dacc, handler - | Return | Exn -> dacc, handler - | Normal | Toplevel_return -> + | Return | Toplevel_return | Exn -> dacc, handler + | Normal | Define_root_symbol -> + (* CR mshinwell: This shouldn't be [assert] in the + [Define_root_symbol] case *) assert at_unit_toplevel; Reify_continuation_param_types. lift_via_reification_of_continuation_param_types dacc @@ -380,28 +382,37 @@ and simplify_non_recursive_let_cont_handler match uses with | No_uses -> uenv | Uses _ -> - match CH.behaviour handler with - | Unreachable { arity; } -> - UE.add_unreachable_continuation uenv cont scope arity - | Alias_for { arity; alias_for; } -> - UE.add_continuation_alias uenv cont arity ~alias_for - | Apply_cont_with_constant_arg - { cont = destination_cont; arg = destination_arg; - arity; } -> - UE.add_continuation_apply_cont_with_constant_arg uenv cont - scope arity ~destination_cont ~destination_arg - | Unknown { arity; } -> - let can_inline = - if is_single_inlinable_use && (not is_exn_handler) then - Some handler - else - None + let can_inline = + if is_single_inlinable_use && (not is_exn_handler) then begin + Some handler + end else + None + in + match can_inline with + | Some handler -> + (* CR mshinwell: tidy up *) + let arity = + match CH.behaviour handler with + | Unreachable { arity; } + | Alias_for { arity; _ } + | Apply_cont_with_constant_arg { arity; _ } + | Unknown { arity; } -> arity in - match can_inline with - | None -> UE.add_continuation uenv cont scope arity - | Some handler -> - UE.add_continuation_to_inline uenv cont scope arity - handler + UE.add_continuation_to_inline uenv cont scope arity + handler + | None -> + match CH.behaviour handler with + | Unreachable { arity; } -> + UE.add_unreachable_continuation uenv cont scope arity + | Alias_for { arity; alias_for; } -> + UE.add_continuation_alias uenv cont arity ~alias_for + | Apply_cont_with_constant_arg + { cont = destination_cont; arg = destination_arg; + arity; } -> + UE.add_continuation_apply_cont_with_constant_arg uenv cont + scope arity ~destination_cont ~destination_arg + | Unknown { arity; } -> + UE.add_continuation uenv cont scope arity in let uacc = UA.with_uenv uacc uenv in (handler, uenv_to_return, user_data), uacc)) @@ -1192,6 +1203,9 @@ and simplify_apply_cont if Option.is_none (Apply_cont.trap_action apply_cont) then Inlinable else Non_inlinable | Return | Toplevel_return | Exn -> Non_inlinable + | Define_root_symbol -> + assert (Option.is_none (Apply_cont.trap_action apply_cont)); + Inlinable in let dacc, rewrite_id = DA.record_continuation_use dacc diff --git a/middle_end/flambda2.0/simplify/template/simplify.templ.ml b/middle_end/flambda2.0/simplify/template/simplify.templ.ml index 1c15397a6886..77b28203aa9e 100644 --- a/middle_end/flambda2.0/simplify/template/simplify.templ.ml +++ b/middle_end/flambda2.0/simplify/template/simplify.templ.ml @@ -79,7 +79,6 @@ let run ~backend ~round unit = ~imported_symbols:imported_symbols ~predef_exn_symbols ~descr:"after simplification"; FU.create ~imported_symbols - ~root_symbol:(FU.root_symbol unit) ~return_continuation ~exn_continuation ~body diff --git a/middle_end/flambda2.0/terms/apply_cont_expr.ml b/middle_end/flambda2.0/terms/apply_cont_expr.ml index 59c13b94acf4..95f339e6c7f1 100644 --- a/middle_end/flambda2.0/terms/apply_cont_expr.ml +++ b/middle_end/flambda2.0/terms/apply_cont_expr.ml @@ -36,13 +36,26 @@ let print ppf { k; args; trap_action; dbg; } = | Return, None, _::_ -> "return", None | Return, Some trap_action, [] -> "return", Some trap_action | Return, Some trap_action, _::_ -> "return", Some trap_action - | Toplevel_return, None, [] -> "toplevel_init", None - | Toplevel_return, None, _::_ -> "toplevel_init", None - | Toplevel_return, Some trap_action, [] -> "toplevel_init", Some trap_action - | Toplevel_return, Some trap_action, _::_ -> "toplevel_init", Some trap_action + | Define_root_symbol, None, [] -> + "apply_cont", None + | Define_root_symbol, None, _::_ -> + "apply_cont", None + | Define_root_symbol, Some trap_action, [] -> + "apply_cont", Some trap_action + | Define_root_symbol, Some trap_action, _::_ -> + "apply_cont", Some trap_action + | Toplevel_return, None, [] -> + "module_init_end", None + | Toplevel_return, None, _::_ -> + "module_init_end", None + | Toplevel_return, Some trap_action, [] -> + "module_init_end", Some trap_action + | Toplevel_return, Some trap_action, _::_ -> + "module_init_end", Some trap_action (* CR mshinwell: See CR on [create], below. *) | Exn, (None | Some (Push _)), [] - | Exn, (None | Some (Push _)), _::_ -> "apply_cont", trap_action (*assert false*) + | Exn, (None | Some (Push _)), _::_ -> + "apply_cont", trap_action (*assert false*) | Exn, Some (Pop _), [] -> "raise", None | Exn, Some (Pop _), _::_ -> "raise", None in diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index de0d4f481be3..4721012b4536 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -20,40 +20,33 @@ open! Flambda.Import type t = { imported_symbols : Flambda_kind.t Symbol.Map.t; - root_symbol : Symbol.t; return_continuation : Continuation.t; exn_continuation : Continuation.t; body : Flambda.Expr.t; } -let create ~imported_symbols ~root_symbol ~return_continuation - ~exn_continuation ~body = +let create ~imported_symbols ~return_continuation ~exn_continuation ~body = { imported_symbols; - root_symbol; return_continuation; exn_continuation; body; } let imported_symbols t = t.imported_symbols -let root_symbol t = t.root_symbol let return_continuation t = t.return_continuation let exn_continuation t = t.exn_continuation let body t = t.body let print ppf - { imported_symbols; root_symbol; return_continuation; exn_continuation; - body; + { imported_symbols; return_continuation; exn_continuation; body; } = Format.fprintf ppf "@[(\ @[(imported_symbols@ %a)@]@ \ - @[(root_symbol@ %a)@]@ \ @[(return_continuation@ %a)@]@ \ @[(exn_continuation@ %a)@]@ \ @[(body@ %a)@]\ )@]" (Symbol.Map.print Flambda_kind.print) imported_symbols - Symbol.print root_symbol Continuation.print return_continuation Continuation.print exn_continuation Flambda.Expr.print body diff --git a/middle_end/flambda2.0/terms/flambda_unit.mli b/middle_end/flambda2.0/terms/flambda_unit.mli index 9c2e74bb7bf3..ede6ec387585 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.mli +++ b/middle_end/flambda2.0/terms/flambda_unit.mli @@ -29,7 +29,6 @@ val print : Format.formatter -> t -> unit (** Create a unit. *) val create : imported_symbols:Flambda_kind.t Symbol.Map.t - -> root_symbol:Symbol.t -> return_continuation:Continuation.t -> exn_continuation:Continuation.t -> body:Flambda.Expr.t @@ -45,10 +44,6 @@ val used_closure_vars : t -> Var_within_closure.Set.t (** All symbols imported from other compilation units by the given unit. *) val imported_symbols : t -> Flambda_kind.t Symbol.Map.t -(** The module block symbol for the given unit (the only symbol that can never - be eliminated). *) -val root_symbol : t -> Symbol.t - val body : t -> Flambda.Expr.t val iter_sets_of_closures From eb76c4b135153b75bf8878038d13c28acb8f71f2 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 11:32:49 +0000 Subject: [PATCH 34/80] printing --- .../flambda2.0/terms/let_symbol_expr.rec.ml | 133 +++++++++++++++--- .../flambda2.0/terms/static_const.rec.ml | 3 + .../flambda2.0/terms/static_const.rec.mli | 2 + 3 files changed, 117 insertions(+), 21 deletions(-) diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index a0820d27ff52..c9975a0036bc 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -143,29 +143,120 @@ let bound_symbols t = t.bound_symbols let defining_expr t = t.defining_expr let body t = t.body -let print_with_cache ~cache ppf { bound_symbols; defining_expr; body; } = - let rec let_symbol_body (expr : Expr.t) = - match Expr.descr expr with - | Let_symbol { bound_symbols; defining_expr; body; } -> - fprintf ppf - "@ @[%a@<0>%s =@<0>%s@ %a@]" - Bound_symbols.print bound_symbols - (Flambda_colours.elide ()) - (Flambda_colours.normal ()) - Static_const.print defining_expr; (* CR mshinwell: print_with_cache? *) - let_symbol_body body - | _ -> expr - in - fprintf ppf "@[(@<0>%slet_symbol@<0>%s@ (@[\ - @[%a@<0>%s =@<0>%s@ %a@]" - (Flambda_colours.expr_keyword ()) - (Flambda_colours.normal ()) - Bound_symbols.print bound_symbols +type flattened_for_printing_descr = + | Code of Code_id.t * Static_const.code + | Closure of Symbol.t * Function_declaration.t + | Other of Symbol.t * Static_const.t + +type flattened_for_printing = { + second_or_more_binding_within_rec : bool; + descr : flattened_for_printing_descr; +} + +let flatten_for_printing { bound_symbols; defining_expr; _ } = + match bound_symbols with + | Singleton symbol -> + [{ second_or_more_binding_within_rec = false; + descr = Other (symbol, defining_expr); + }] + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + let code, set_of_closures = + match defining_expr with + | Code_and_set_of_closures { code; set_of_closures; } -> + code, set_of_closures + | _ -> + Misc.fatal_errorf "Bad form of static constant:@ %a" + Static_const.print defining_expr + in + let flattened,_ = + Code_id.Map.fold (fun code_id code (flattened', first) -> + let flattened = + { second_or_more_binding_within_rec = not first; + descr = Code (code_id, code); + } + in + flattened :: flattened', false) + code + ([], true) + in + let flattened', _ = + match set_of_closures with + | None -> [], false + | Some set_of_closures -> + Closure_id.Map.fold + (fun closure_id closure_symbol (flattened', first) -> + let function_decl = + Function_declarations.find + (Set_of_closures.function_decls set_of_closures) + closure_id + in + let flattened = + { second_or_more_binding_within_rec = not first; + descr = Closure (closure_symbol, function_decl); + } + in + flattened :: flattened', false) + closure_symbols + ([], true) + in + (List.rev flattened) @ (List.rev flattened') + +let print_flattened_descr_lhs ppf descr = + match descr with + | Code (code_id, _) -> Code_id.print ppf code_id + | Closure (symbol, _) | Other (symbol, _) -> Symbol.print ppf symbol + +(* CR mshinwell: Use [print_with_cache]? *) +let print_flattened_descr_rhs ppf descr = + match descr with + | Code (_, code) -> Static_const.print_code ppf code + | Closure (_, function_decl) -> Function_declaration.print ppf function_decl + | Other (_, static_const) -> Static_const.print ppf static_const + +let print_flattened ppf { second_or_more_binding_within_rec; descr; } = + if second_or_more_binding_within_rec then begin + fprintf ppf "@<0>%sand @<0>%s" + (Flambda_colours.elide ()) + (Flambda_colours.normal ()) + end; + fprintf ppf + "@ @[%a@<0>%s =@<0>%s@ %a@]" + print_flattened_descr_lhs descr (Flambda_colours.elide ()) (Flambda_colours.normal ()) - Static_const.print defining_expr; - let body = let_symbol_body body in - fprintf ppf "@])@ %a)@]" (Expr.print_with_cache ~cache) body + print_flattened_descr_rhs descr + +let flatten t : _ * Expr.t = + let rec flatten (expr : Expr.t) : _ * Expr.t = + match Expr.descr expr with + | Let_symbol t -> + let flattened = flatten_for_printing t in + let flattened', body = flatten t.body in + flattened @ flattened', body + | _ -> [], expr + in + let flattened = flatten_for_printing t in + let flattened', body = flatten t.body in + flattened @ flattened', body + +let print_with_cache ~cache ppf t = + let rec print_more flattened = + match flattened with + | [] -> () + | flat::flattened -> + print_flattened ppf flat; + print_more flattened + in + let flattened, body = flatten t in + match flattened with + | [] -> assert false + | flat::flattened -> + fprintf ppf "@[(@<0>%slet_symbol@<0>%s@ (@[%a" + (Flambda_colours.expr_keyword ()) + (Flambda_colours.normal ()) + print_flattened flat; + print_more flattened; + fprintf ppf "@])@ %a)@]" (Expr.print_with_cache ~cache) body let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index 2d817bc4ea28..decd05db3c09 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -212,6 +212,9 @@ let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = (Flambda_colours.normal ()) (print_params_and_body_with_cache ~cache) params_and_body +let print_code ppf code = + print_code_with_cache ~cache:(Printing_cache.create ()) ppf code + let print_with_cache ~cache ppf t = let print_float_array_field ppf = function | Const f -> fprintf ppf "%a" Numbers.Float_by_bit_pattern.print f diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index 44220aea5572..79d93e0916d9 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -51,6 +51,8 @@ and 'a or_deleted = | Present of 'a | Deleted +val print_code : Format.formatter -> code -> unit + (** The possibly-recursive declaration of pieces of code and any associated set of closures. *) type code_and_set_of_closures = { From 11953fb7cdd4889654e08f6655d14f79e89e01f1 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 11:43:01 +0000 Subject: [PATCH 35/80] printing --- middle_end/flambda2.0/terms/function_declaration.ml | 2 +- middle_end/flambda2.0/terms/let_symbol_expr.rec.ml | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/middle_end/flambda2.0/terms/function_declaration.ml b/middle_end/flambda2.0/terms/function_declaration.ml index 9b1508e94c3f..85497cd95524 100644 --- a/middle_end/flambda2.0/terms/function_declaration.ml +++ b/middle_end/flambda2.0/terms/function_declaration.ml @@ -67,7 +67,7 @@ let print_with_cache ~cache:_ ppf @[@<0>%s(is_a_functor@ %b)@<0>%s@]@ \ @[@<0>%s(params_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ @[@<0>%s(result_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ - @[@<0>%s(recursive@ %a)@<0>%s@]@ " + @[@<0>%s(recursive@ %a)@<0>%s@]" Code_id.print code_id (if not stub then Flambda_colours.elide () else C.normal ()) stub diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index c9975a0036bc..a1abf9f719b8 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -197,7 +197,7 @@ let flatten_for_printing { bound_symbols; defining_expr; _ } = in flattened :: flattened', false) closure_symbols - ([], true) + ([], Code_id.Map.is_empty code) in (List.rev flattened) @ (List.rev flattened') @@ -214,13 +214,14 @@ let print_flattened_descr_rhs ppf descr = | Other (_, static_const) -> Static_const.print ppf static_const let print_flattened ppf { second_or_more_binding_within_rec; descr; } = + fprintf ppf "@["; if second_or_more_binding_within_rec then begin fprintf ppf "@<0>%sand @<0>%s" - (Flambda_colours.elide ()) + (Flambda_colours.expr_keyword ()) (Flambda_colours.normal ()) end; fprintf ppf - "@ @[%a@<0>%s =@<0>%s@ %a@]" + "%a@<0>%s =@<0>%s@ %a@]" print_flattened_descr_lhs descr (Flambda_colours.elide ()) (Flambda_colours.normal ()) @@ -244,6 +245,7 @@ let print_with_cache ~cache ppf t = match flattened with | [] -> () | flat::flattened -> + fprintf ppf "@ "; print_flattened ppf flat; print_more flattened in From cb05d6bfb2afeb217694c0a1464ec128fd474514 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 11:58:52 +0000 Subject: [PATCH 36/80] printing --- .../flambda2.0/terms/function_declaration.ml | 2 +- .../flambda2.0/terms/let_symbol_expr.rec.ml | 24 +++++++++++++------ .../flambda2.0/terms/set_of_closures.ml | 24 ++++++++++++------- 3 files changed, 34 insertions(+), 16 deletions(-) diff --git a/middle_end/flambda2.0/terms/function_declaration.ml b/middle_end/flambda2.0/terms/function_declaration.ml index 85497cd95524..276510870bdf 100644 --- a/middle_end/flambda2.0/terms/function_declaration.ml +++ b/middle_end/flambda2.0/terms/function_declaration.ml @@ -67,7 +67,7 @@ let print_with_cache ~cache:_ ppf @[@<0>%s(is_a_functor@ %b)@<0>%s@]@ \ @[@<0>%s(params_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ @[@<0>%s(result_arity@ @<0>%s%a@<0>%s)@<0>%s@]@ \ - @[@<0>%s(recursive@ %a)@<0>%s@]" + @[@<0>%s(recursive@ %a)@<0>%s@])@]" Code_id.print code_id (if not stub then Flambda_colours.elide () else C.normal ()) stub diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index a1abf9f719b8..b3bcecef7b53 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -145,7 +145,7 @@ let body t = t.body type flattened_for_printing_descr = | Code of Code_id.t * Static_const.code - | Closure of Symbol.t * Function_declaration.t + | Set_of_closures of Symbol.t Closure_id.Map.t * Set_of_closures.t | Other of Symbol.t * Static_const.t type flattened_for_printing = { @@ -179,10 +179,14 @@ let flatten_for_printing { bound_symbols; defining_expr; _ } = code ([], true) in - let flattened', _ = + let flattened' = match set_of_closures with - | None -> [], false + | None -> [] | Some set_of_closures -> + [{ second_or_more_binding_within_rec = not (Code_id.Map.is_empty code); + descr = Set_of_closures (closure_symbols, set_of_closures); + }] +(* Closure_id.Map.fold (fun closure_id closure_symbol (flattened', first) -> let function_decl = @@ -198,26 +202,32 @@ let flatten_for_printing { bound_symbols; defining_expr; _ } = flattened :: flattened', false) closure_symbols ([], Code_id.Map.is_empty code) +*) in (List.rev flattened) @ (List.rev flattened') let print_flattened_descr_lhs ppf descr = match descr with | Code (code_id, _) -> Code_id.print ppf code_id - | Closure (symbol, _) | Other (symbol, _) -> Symbol.print ppf symbol + | Set_of_closures (closure_symbols, _) -> + Format.fprintf ppf "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Bound_symbols.print_closure_binding) + (Closure_id.Map.bindings closure_symbols) + | Other (symbol, _) -> Symbol.print ppf symbol (* CR mshinwell: Use [print_with_cache]? *) let print_flattened_descr_rhs ppf descr = match descr with | Code (_, code) -> Static_const.print_code ppf code - | Closure (_, function_decl) -> Function_declaration.print ppf function_decl + | Set_of_closures (_, set) -> Set_of_closures.print ppf set | Other (_, static_const) -> Static_const.print ppf static_const let print_flattened ppf { second_or_more_binding_within_rec; descr; } = - fprintf ppf "@["; + fprintf ppf "@["; if second_or_more_binding_within_rec then begin fprintf ppf "@<0>%sand @<0>%s" - (Flambda_colours.expr_keyword ()) + (Flambda_colours.elide ()) (Flambda_colours.normal ()) end; fprintf ppf diff --git a/middle_end/flambda2.0/terms/set_of_closures.ml b/middle_end/flambda2.0/terms/set_of_closures.ml index 586beb6f0ae1..b85f7fdd7406 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.ml +++ b/middle_end/flambda2.0/terms/set_of_closures.ml @@ -86,14 +86,22 @@ let print_with_cache ~cache ppf { function_decls; closure_elements; } = - Format.fprintf ppf "@[(%sset_of_closures%s@ \ - @[(function_decls@ %a)@]@ \ - @[(closure_elements@ %a)@]\ - )@]" - (Flambda_colours.prim_constructive ()) - (Flambda_colours.normal ()) - (Function_declarations.print_with_cache ~cache) function_decls - (Var_within_closure.Map.print Simple.print) closure_elements + if Var_within_closure.Map.is_empty closure_elements then + Format.fprintf ppf "@[(%sset_of_closures%s@ \ + @[%a@]\ + )@]" + (Flambda_colours.prim_constructive ()) + (Flambda_colours.normal ()) + (Function_declarations.print_with_cache ~cache) function_decls + else + Format.fprintf ppf "@[(%sset_of_closures%s@ \ + @[%a@]@ \ + @[(env@ %a)@]\ + )@]" + (Flambda_colours.prim_constructive ()) + (Flambda_colours.normal ()) + (Function_declarations.print_with_cache ~cache) function_decls + (Var_within_closure.Map.print Simple.print) closure_elements let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t From f74b5ce9266b756de49a215ab5b1a288c9613d25 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 13:08:00 +0000 Subject: [PATCH 37/80] printing --- .../flambda2.0/naming/bindable_let_bound.ml | 6 ++-- .../simplify/env/simplify_env_and_result.ml | 13 ++++++++ .../env/simplify_env_and_result_intf.ml | 2 ++ .../flambda2.0/simplify/simplify_expr.rec.ml | 32 +++++++++++++------ .../simplify/simplify_static_const.rec.ml | 17 ++++------ .../flambda2.0/terms/let_symbol_expr.rec.ml | 17 +++++++--- 6 files changed, 62 insertions(+), 25 deletions(-) diff --git a/middle_end/flambda2.0/naming/bindable_let_bound.ml b/middle_end/flambda2.0/naming/bindable_let_bound.ml index de93fb81dbce..4069bde95b1c 100644 --- a/middle_end/flambda2.0/naming/bindable_let_bound.ml +++ b/middle_end/flambda2.0/naming/bindable_let_bound.ml @@ -25,9 +25,11 @@ include Identifiable.Make (struct type nonrec t = t let print_closure_binding ppf (closure_id, var) = - Format.fprintf ppf "@[(%a \u{21a6} %a)@]" - Closure_id.print closure_id + Format.fprintf ppf "@[%a @<0>%s\u{21a6}@<0>%s %a@]" Var_in_binding_pos.print var + (Flambda_colours.elide ()) + (Flambda_colours.elide ()) + Closure_id.print closure_id let print ppf t = match t with diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index b14ee0e46e1e..3a6a0b64e584 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -131,6 +131,19 @@ end = struct symbols_currently_being_defined; } + let no_longer_defining_symbol t symbol = + if not (Symbol.Set.mem symbol t.symbols_currently_being_defined) then begin + Misc.fatal_errorf "Not currently defining symbol %a:@ %a" + Symbol.print symbol + print t + end; + let symbols_currently_being_defined = + Symbol.Set.remove symbol t.symbols_currently_being_defined + in + { t with + symbols_currently_being_defined; + } + let symbol_is_currently_being_defined t symbol = Symbol.Set.mem symbol t.symbols_currently_being_defined diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index 5a93c1f5a4b2..c58eef4533f3 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -62,6 +62,8 @@ module type Downwards_env = sig val now_defining_symbol : t -> Symbol.t -> t + val no_longer_defining_symbol : t -> Symbol.t -> t + val symbol_is_currently_being_defined : t -> Symbol.t -> bool val typing_env : t -> Flambda_type.Typing_env.t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 670391d7c314..a9e6be2b5400 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -71,16 +71,30 @@ and simplify_let_symbol let body = LS.body let_symbol_expr in let prior_lifted_constants = R.get_lifted_constants (DA.r dacc) in let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in + let defining = + Name_occurrences.symbols (Bound_symbols.free_names bound_symbols) + in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Symbol.Set.fold (fun symbol denv -> + DE.now_defining_symbol denv symbol) + defining + denv) + in let bound_symbols, defining_expr, dacc = - let dacc = - DA.map_denv dacc ~f:(fun denv -> - Symbol.Set.fold (fun symbol denv -> - DE.now_defining_symbol denv symbol) - (Name_occurrences.symbols (Bound_symbols.free_names bound_symbols)) - denv) - in Simplify_static_const.simplify_static_const dacc bound_symbols defining_expr in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Symbol.Set.fold (fun symbol denv -> + DE.no_longer_defining_symbol denv symbol) + defining + denv) + in +Format.eprintf "dacc after %a = static const@ %a@ is:@ %a\n%!" + Bound_symbols.print bound_symbols + Static_const.print defining_expr + DA.print dacc; let defining_expr_lifted_constants = R.get_lifted_constants (DA.r dacc) in let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let body, user_data, uacc = simplify_expr dacc body k in @@ -383,9 +397,9 @@ and simplify_non_recursive_let_cont_handler | No_uses -> uenv | Uses _ -> let can_inline = - if is_single_inlinable_use && (not is_exn_handler) then begin + if is_single_inlinable_use && (not is_exn_handler) then Some handler - end else + else None in match can_inline with diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index e0b38b0ed9d7..2d1318e17ef1 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -23,29 +23,26 @@ module Field_of_block = Static_const.Field_of_block (* CR-someday mshinwell: Finish improved simplification using types *) -let simplify_field_of_block dacc (of_kind_value : Field_of_block.t) = - let denv = DA.denv dacc in - match of_kind_value with - | Symbol sym -> - let ty = DE.find_symbol denv sym in - of_kind_value, ty - | Tagged_immediate i -> of_kind_value, T.this_tagged_immediate i +let simplify_field_of_block dacc (field : Field_of_block.t) = + match field with + | Symbol sym -> field, T.alias_type_of K.value (Simple.symbol sym) + | Tagged_immediate i -> field, T.this_tagged_immediate i | Dynamically_computed var -> let min_name_mode = Name_mode.normal in match S.simplify_simple dacc (Simple.var var) ~min_name_mode with | Bottom, ty -> assert (K.equal (T.kind ty) K.value); (* CR mshinwell: This should be "invalid" and propagate up *) - of_kind_value, T.bottom K.value + field, T.bottom K.value | Ok simple, ty -> match Simple.descr simple with | Name (Symbol sym) -> Field_of_block.Symbol sym, ty - | Name (Var _) -> of_kind_value, ty + | Name (Var _) -> field, ty | Const (Tagged_immediate imm) -> Field_of_block.Tagged_immediate imm, ty | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _) -> (* CR mshinwell: This should be "invalid" and propagate up *) - of_kind_value, ty + field, ty let simplify_or_variable dacc type_for_const (or_variable : _ Static_const.or_variable) = diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index b3bcecef7b53..618e79d5ea60 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -24,11 +24,13 @@ module Bound_symbols = struct closure_symbols : Symbol.t Closure_id.Map.t; } - (* CR mshinwell: Share with [Bindable_let_bound] *) + (* CR mshinwell: Share with [Bindable_let_bound] and below *) let print_closure_binding ppf (closure_id, sym) = - Format.fprintf ppf "@[(%a \u{21a6} %a)@]" - Closure_id.print closure_id + Format.fprintf ppf "@[%a @<0>%s\u{21a6}@<0>%s %a@]" Symbol.print sym + (Flambda_colours.elide ()) + (Flambda_colours.elide ()) + Closure_id.print closure_id let print ppf t = match t with @@ -206,13 +208,20 @@ let flatten_for_printing { bound_symbols; defining_expr; _ } = in (List.rev flattened) @ (List.rev flattened') +let print_closure_binding ppf (closure_id, sym) = + Format.fprintf ppf "@[%a @<0>%s\u{21a6}@<0>%s %a@]" + Symbol.print sym + (Flambda_colours.elide ()) + (Flambda_colours.elide ()) + Closure_id.print closure_id + let print_flattened_descr_lhs ppf descr = match descr with | Code (code_id, _) -> Code_id.print ppf code_id | Set_of_closures (closure_symbols, _) -> Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:Format.pp_print_space - Bound_symbols.print_closure_binding) + print_closure_binding) (Closure_id.Map.bindings closure_symbols) | Other (symbol, _) -> Symbol.print ppf symbol From 9c745bccd7d9cc4b2ab2b312de2f5f03ce577ac8 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 13:16:08 +0000 Subject: [PATCH 38/80] work --- middle_end/flambda2.0/simplify/simplify_expr.rec.ml | 4 ---- middle_end/flambda2.0/terms/flambda_unit.ml | 2 +- middle_end/flambda2.0/terms/static_const.rec.ml | 4 ++-- utils/misc.ml | 6 ++++++ utils/misc.mli | 6 ++++++ 5 files changed, 15 insertions(+), 7 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index a9e6be2b5400..0a690bb51b69 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -91,10 +91,6 @@ and simplify_let_symbol defining denv) in -Format.eprintf "dacc after %a = static const@ %a@ is:@ %a\n%!" - Bound_symbols.print bound_symbols - Static_const.print defining_expr - DA.print dacc; let defining_expr_lifted_constants = R.get_lifted_constants (DA.r dacc) in let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let body, user_data, uacc = simplify_expr dacc body k in diff --git a/middle_end/flambda2.0/terms/flambda_unit.ml b/middle_end/flambda2.0/terms/flambda_unit.ml index 4721012b4536..273a72c29b8a 100644 --- a/middle_end/flambda2.0/terms/flambda_unit.ml +++ b/middle_end/flambda2.0/terms/flambda_unit.ml @@ -44,7 +44,7 @@ let print ppf @[(imported_symbols@ %a)@]@ \ @[(return_continuation@ %a)@]@ \ @[(exn_continuation@ %a)@]@ \ - @[(body@ %a)@]\ + @[%a@]\ )@]" (Symbol.Map.print Flambda_kind.print) imported_symbols Continuation.print return_continuation diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index decd05db3c09..fbe3ee043ddd 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -196,7 +196,7 @@ let free_names t = let print_params_and_body_with_cache ~cache ppf params_and_body = match params_and_body with - | Deleted -> Format.fprintf ppf "@[(params_and_body@ Deleted)@]" + | Deleted -> Format.fprintf ppf "Deleted" | Present params_and_body -> Function_params_and_body.print_with_cache ~cache ppf params_and_body @@ -208,7 +208,7 @@ let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = )@]" (if Option.is_none newer_version_of then Flambda_colours.elide () else Flambda_colours.normal ()) - (Misc.Stdlib.Option.print Code_id.print) newer_version_of + (Misc.Stdlib.Option.print_compact Code_id.print) newer_version_of (Flambda_colours.normal ()) (print_params_and_body_with_cache ~cache) params_and_body diff --git a/utils/misc.ml b/utils/misc.ml index 9f0a49c9125a..2ca2f00e94fd 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -372,6 +372,12 @@ module Stdlib = struct | None -> Format.pp_print_string ppf "None" | Some contents -> Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents + + let print_compact print_contents ppf t = + match t with + | None -> Format.pp_print_string ppf "()" + | Some contents -> + Format.fprintf ppf "%a" print_contents contents end module Array = struct diff --git a/utils/misc.mli b/utils/misc.mli index 4ad4ea51fedc..806458cf8024 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -151,6 +151,12 @@ module Stdlib : sig -> Format.formatter -> 'a t -> unit + + val print_compact + : (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit end module Array : sig From 56629d6f3a9b979f58d48fba70c29ed84ee835e9 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 14:43:10 +0000 Subject: [PATCH 39/80] work --- .../flambda2.0/simplify/simplify_expr.rec.ml | 6 ++++- .../flambda2.0/simplify/simplify_named.rec.ml | 22 ++++++++++++++----- .../simplify/simplify_static_const.rec.ml | 5 +++++ 3 files changed, 26 insertions(+), 7 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 0a690bb51b69..8b3b033eef0e 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -107,6 +107,8 @@ and simplify_let_symbol need to ensure that the lifted constants end up in the current definition, rather than just above it. *) let bound_names = Bound_symbols.free_names bound_symbols in +Format.eprintf "bound_names of current defn:@ %a\n%!" + Name_occurrences.print bound_names; List.fold_left (fun (defining_expr_lifted_constants_not_in_same_set, bound_symbols, defining_expr) lifted_constant -> @@ -116,6 +118,8 @@ and simplify_let_symbol Name_occurrences.overlap bound_names (Static_const.free_names defining_expr) in +Format.eprintf "...new defn of %a, overlap? %b\n%!" + Bound_symbols.print bound_symbols overlap; match bound_symbols_lifted_constant with | Singleton _ -> let defining_expr_lifted_constants_not_in_same_set = @@ -148,7 +152,7 @@ and simplify_let_symbol defining_expr_lifted_constants_not_in_same_set, bound_symbols, defining_expr) ([], bound_symbols, defining_expr) - defining_expr_lifted_constants + (List.rev defining_expr_lifted_constants) in let bindings_outermost_first = defining_expr_lifted_constants_not_in_same_set diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index a42670171f94..9b818d0933b6 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -383,17 +383,27 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars closure_symbols denv) in + let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let _set_of_closures, dacc, types_of_symbols, bound_symbols, static_const = Simplify_static_const.simplify_set_of_closures0 dacc set_of_closures ~closure_symbols ~closure_elements ~closure_element_types in - let r = - let lifted_constant = - Lifted_constant.create (DA.denv dacc) bound_symbols static_const - ~types_of_symbols - in - R.new_lifted_constant (DA.r dacc) lifted_constant + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Closure_id.Map.fold (fun _closure_id closure_symbol denv -> + DE.no_longer_defining_symbol denv closure_symbol) + closure_symbols + denv) + in + let set_of_closures_lifted_constant = + Lifted_constant.create (DA.denv dacc) bound_symbols static_const + ~types_of_symbols + in + let dacc = + DA.map_r dacc ~f:(fun r -> + R.new_lifted_constant r set_of_closures_lifted_constant) in + let r = DA.r dacc in let denv = DE.add_lifted_constants (DA.denv dacc) ~lifted:(R.get_lifted_constants r) in diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index 2d1318e17ef1..cc8f4dea99c3 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -201,6 +201,11 @@ let simplify_static_const_of_kind_fabricated dacc code_ids bound_symbols Code_id.Set.print code_ids' Static_const.print static_const end; + (* CR-someday mshinwell: If we start simplifying code here, then + the [Let_symbol] case in [Simplify_expr] will have to be able to cope + with lifted constants arriving from the simplification of a + [Let_symbol]'s defining expression, that may need to be put into the + same set of closures as the current defining expression. *) let dacc = Code_id.Map.fold (fun code_id From c08aa680ebc4d2aefb601803c95e1d2a18aeb646 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 16:44:25 +0000 Subject: [PATCH 40/80] work --- .../flambda2.0/basic/code_id_or_symbol.ml | 45 +++ .../flambda2.0/basic/code_id_or_symbol.mli | 21 ++ .../flambda2.0/simplify/simplify_expr.rec.ml | 308 ++++++++++++++---- .../flambda2.0/terms/let_symbol_expr.rec.ml | 15 + .../flambda2.0/terms/let_symbol_expr.rec.mli | 2 + 5 files changed, 332 insertions(+), 59 deletions(-) create mode 100644 middle_end/flambda2.0/basic/code_id_or_symbol.ml create mode 100644 middle_end/flambda2.0/basic/code_id_or_symbol.mli diff --git a/middle_end/flambda2.0/basic/code_id_or_symbol.ml b/middle_end/flambda2.0/basic/code_id_or_symbol.ml new file mode 100644 index 000000000000..07694f02975a --- /dev/null +++ b/middle_end/flambda2.0/basic/code_id_or_symbol.ml @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2020 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-30-40-41-42"] + +type t = + | Code_id of Code_id.t + | Symbol of Symbol.t + +include Identifiable.Make (struct + type nonrec t = t + + let print ppf t = + match t with + | Code_id code_id -> + Format.fprintf ppf "@[(code_id@ %a)@]" Code_id.print code_id + | Symbol symbol -> + Format.fprintf ppf "@[(symbol@ %a)@]" Symbol.print symbol + + let compare t1 t2 = + match t1, t2 with + | Code_id _, Symbol _ -> -1 + | Symbol _, Code_id _ -> 1 + | Code_id code_id1, Code_id code_id2 -> + Code_id.compare code_id1 code_id2 + | Symbol symbol1, Symbol symbol2 -> + Symbol.compare symbol1 symbol2 + + let equal t1 t2 = (compare t1 t2 = 0) + + let output _ _ = Misc.fatal_error "Not yet implemented" + + let hash _ = Misc.fatal_error "Not yet implemented" +end) diff --git a/middle_end/flambda2.0/basic/code_id_or_symbol.mli b/middle_end/flambda2.0/basic/code_id_or_symbol.mli new file mode 100644 index 000000000000..5fd5da3f22e1 --- /dev/null +++ b/middle_end/flambda2.0/basic/code_id_or_symbol.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2020 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-30-40-41-42"] + +type t = + | Code_id of Code_id.t + | Symbol of Symbol.t + +include Identifiable.S with type t := t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 8b3b033eef0e..86fc72928f76 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -27,6 +27,13 @@ open! Simplify_import type 'a k = CUE.t -> Code_age_relation.t -> R.t -> ('a * UA.t) +module SCC_lifted_constants = + Strongly_connected_components.Make (Code_id_or_symbol) + +type non_closure_or_closure_symbol = + | Non_closure_symbol of Static_const.t + | Closure_symbol of Closure_id.t * Set_of_closures.t + let rec simplify_let : 'a. DA.t -> Let.t -> 'a k -> Expr.t * 'a * UA.t = fun dacc let_expr k -> @@ -98,75 +105,258 @@ and simplify_let_symbol let uacc = UA.map_r uacc ~f:(fun r -> R.set_lifted_constants r prior_lifted_constants) in - let defining_expr_lifted_constants_not_in_same_set, - bound_symbols, defining_expr = - (* Lifted constants arising from the simplification of the defining - expression are either not recursive with the current definition - (this is always the case for non-closures), or recursive with the - current definition of code and/or closures. In the latter case we - need to ensure that the lifted constants end up in the current - definition, rather than just above it. *) - let bound_names = Bound_symbols.free_names bound_symbols in -Format.eprintf "bound_names of current defn:@ %a\n%!" - Name_occurrences.print bound_names; - List.fold_left - (fun (defining_expr_lifted_constants_not_in_same_set, - bound_symbols, defining_expr) lifted_constant -> - let bound_symbols_lifted_constant = LC.bound_symbols lifted_constant in - let defining_expr_lifted_constant = LC.defining_expr lifted_constant in - let overlap = - Name_occurrences.overlap bound_names - (Static_const.free_names defining_expr) - in -Format.eprintf "...new defn of %a, overlap? %b\n%!" - Bound_symbols.print bound_symbols overlap; - match bound_symbols_lifted_constant with - | Singleton _ -> - let defining_expr_lifted_constants_not_in_same_set = - (bound_symbols, defining_expr_lifted_constant) - :: defining_expr_lifted_constants_not_in_same_set - in - if overlap then begin - Misc.fatal_errorf "Lifted constant that is not allowed to be \ - involved in a recursive binding uses name(s) from the \ - current [Let_symbol] recursively:@ %a@ Current [Let_symbol] \ - binds:@ %a" - LC.print lifted_constant - Bound_symbols.print bound_symbols - end; - defining_expr_lifted_constants_not_in_same_set, - bound_symbols, defining_expr - | Code_and_set_of_closures _ -> - if overlap then - let bound_symbols = - Bound_symbols.disjoint_union bound_symbols - bound_symbols_lifted_constant - in - let defining_expr = - Static_const.disjoint_union defining_expr - defining_expr_lifted_constant - in - defining_expr_lifted_constants_not_in_same_set, - bound_symbols, defining_expr - else - defining_expr_lifted_constants_not_in_same_set, - bound_symbols, defining_expr) - ([], bound_symbols, defining_expr) - (List.rev defining_expr_lifted_constants) - in - let bindings_outermost_first = - defining_expr_lifted_constants_not_in_same_set + let all_lifted_constants = + List.map (fun lifted_constant -> + LC.bound_symbols lifted_constant, LC.defining_expr lifted_constant) + defining_expr_lifted_constants @ (bound_symbols, defining_expr) :: List.map (fun lifted_constant -> LC.bound_symbols lifted_constant, LC.defining_expr lifted_constant) subsequent_lifted_constants in + (* The various lifted constants may exhibit recursion between themselves + (specifically between closures and/or code). We use SCC to obtain a + topological sort of groups that must be coalesced into single + code-and-set-of-closures definitions. *) + let lifted_constants_dep_graph = + List.fold_left (fun dep_graph (bound_symbols, defining_expr) -> + Code_id_or_symbol.Set.fold + (fun (being_defined : Code_id_or_symbol.t) dep_graph -> + match being_defined with + | Code_id code_id -> + begin match (defining_expr : Static.const.t) with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + assert (Code_id.Map.mem code_id code); + let code = Code_id.Map.find code_id code in + let free_names_params_and_body = + match code.params_and_body with + | Deleted -> Name_occurrences.empty + | Present params_and_body -> + Function_params_and_body.free_names params_and_body + in + let free_names_newer_version_of = + match code.newer_version_of with + | None -> Name_occurrences.empty + | Some newer_version_of -> + (* We treat this like a real code ID dependency, not a + "newer version of code ID" dependency. *) + Name_occurrences.add_code_id Name_occurrences.empty + newer_version_of NM.normal + in + Name_occurrences.union free_names_params_and_body + free_names_newer_version_of + | _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print defining_expr + Bound_symbols.print bound_symbols + end + | Symbol symbol -> + begin match bound_symbols with + | Singleton _ -> Static_const.free_names defining_expr + | Code_and_set_of_closures { code_ids; closure_symbols; } -> + let closure_symbols = + closure_symbols + |> Closure_id.Map.elements + |> List.map (fun (closure_id, sym) -> sym, closure_id) + |> Symbol.Map.of_alist + in + assert (Symbol.Map.mem symbol closure_symbols); + let closure_id = Symbol.Map.find symbol closure_symbols in + match (defining_expr : Static.const.t) with + | Code_and_set_of_closures { code = _; set_of_closures; } -> + begin match set_of_closures with + | None -> + Misc.fatal_errorf "No set of closures given for@ %a" + Symbol.print symbol + | Some set_of_closures -> + (* CR mshinwell: Make sure the closure ID exists in the + set of closures *) + ignore closure_id; + (* We take the free names of the whole set of closures + for every closure symbol defined by it. *) + Set_of_closures.free_names set_of_closures + end + | _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print defining_expr + Bound_symbols.print bound_symbols + end) + (Bound_symbols.everything_being_defined bound_symbols) + dep_graph) + Code_id_or_symbol.Map.empty + all_lifted_constants + in + let connected_components = + SCC_lifted_constants.connected_components_sorted_from_roots_to_leaf + lifted_constants_dep_graph + in + let find_code code_id = + let result = + List.find_opt (fun (_bound_symbols, (static_const : Static_const.t)) -> + match static_const with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + Code_id.Map.find_opt code_id code + | _ -> None) + lifted_constants_dep_graph + in + match result with + | None -> + Misc.fatal_errorf "Definition for code ID %a not found" + Code_id.print code_id + | Some code -> code + in + let find_non_closure_or_closure_symbol sym = + let result = + List.find_opt + (fun ((bound_symbols : Bound_symbols.t), + (static_const : Static_const.t)) + : non_closure_or_closure_symbol -> + match bound_symbols with + | Singleton _ -> Non_closure static_const + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + let closure_symbols = + (* CR mshinwell: duplicated from above *) + closure_symbols + |> Closure_id.Map.elements + |> List.map (fun (closure_id, sym) -> sym, closure_id) + |> Symbol.Map.of_alist + in + match Symbol.Map.find sym closure_symbols with + | exception Not_found -> None + | closure_id -> + (* CR mshinwell: duplicated from above *) + match (defining_expr : Static.const.t) with + | Code_and_set_of_closures { code = _; set_of_closures; } -> + begin match set_of_closures with + | None -> + Misc.fatal_errorf "No set of closures given for@ %a" + Symbol.print symbol + | Some set_of_closures -> + (* CR mshinwell: Make sure the closure ID exists in the + set of closures *) + Closure_symbol (closure_id, set_of_closures) + end + | _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print defining_expr + Bound_symbols.print bound_symbols) + lifted_constants_dep_graph + in + match result with + | None -> + Misc.fatal_errorf "Definition for symbol %a not found" + Symbol.print symbol + | Some result -> result + in + let bindings_outermost_last = + Array.fold_left (fun bindings (group : SCC_lifted_constants.component) -> + let binding = + match group with + | No_loop (Code_id code_id) -> + let code = find_code code_id in + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { + code_ids = Code_id.Set.singleton code_id; + closure_symbols = Closure_id.Map.empty; + } + in + let defining_expr : Static_const.t = + Code_and_set_of_closures { + code = Code_id.Map.singleton code_id code; + set_of_closures = None; + } + in + bound_symbols, defining_expr + | No_loop (Symbol sym) -> + (* CR mshinwell: What happens if [sym] is one part of a set + of closures with more than one closure inside it? *) + begin match find_non_closure_or_closure_symbol sym with + | Non_closure_symbol defining_expr -> + let bound_symbols : Bound_symbols.t = Singleton sym in + bound_symbols, defining_expr + | Closure_symbol (closure_id, set_of_closures) -> + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { + code_ids = Code_id.Set.empty; + closure_symbols = Closure_id.Map.singleton closure_id sym; + } + in + let defining_expr : Static_const.t = + Code_and_set_of_closures { + code = Code_id.Map.empty; + set_of_closures = Some set; + } + in + bound_symbols, defining_expr + end + | Has_loop members -> + (* CR mshinwell: It seems like this may end up copying sets of + closures. *) + let code_ids, closure_symbols, code, set_of_closures = + List.fold_left + (fun (code_ids, closure_symbols, code, set_of_closures) + (member : Code_id_or_symbol.t) -> + match member with + | Code_id code_id -> + let code_ids = Code_id.Set.add code_id code_ids in + let code = + Code_id.Map.add code_id (find_code code_id) code + in + code_ids, closure_symbols, code, set_of_closures + | Symbol symbol -> + match find_code_or_closure_symbol symbol with + | Closure_symbol (closure_id, set) -> + assert (not (Closure_id.Map.mem closure_id + closure_symbols)); + let closure_symbols = + Closure_id.Map.add closure_id symbol closure_symbols + in + let set_of_closures = + match set_of_closures with + | None -> Some set + | Some set' -> + if not (Set_of_closures.equal set set') then begin + Misc.fatal_errorf "Sets of closures differ for %a: \ + %a@ versus@ %a" + Symbol.print symbol + Set_of_closures.print set + Set_of_closures.print set' + end; + set_of_closures + in + code_ids, closure_symbols, code, set_of_closures + | Non_closure_symbol -> + Misc.fatal_errorf "Symbol %a was involved in recursion \ + that cannot be compiled" + Symbol.print symbol) + (Code_id.Set.empty, Closure_id.Map.empty, + Code_id.Map.empty, None) + members + in + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { + code_ids; + closure_symbols; + } + in + let defining_expr : Static_const.t = + Code_and_set_of_closures { + code; + set_of_closures; + } + in + bound_symbols, defining_expr + in + binding :: bindings) + [] + connected_components + in let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> Simplify_common.create_let_symbol (UA.code_age_relation uacc) bound_symbols defining_expr body) body - (List.rev bindings_outermost_first) + bindings_outermost_last in expr, user_data, uacc diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index 618e79d5ea60..c6b33103953a 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -83,6 +83,21 @@ module Bound_symbols = struct | Singleton _ -> Code_id.Set.empty | Code_and_set_of_closures { code_ids; closure_symbols = _; } -> code_ids + let everything_being_defined t = + let code = + Code_id.Set.fold (fun code_id code -> + Code_id_or_symbol.Set.add (Code_id code_id) code) + (code_being_defined t) + Code_id_or_symbol.Set.empty + in + let closure_symbols = + Symbol.Set.fold (fun symbol closure_symbols -> + Code_id_or_symbol.Set.add (Symbol symbol) closure_symbols) + (being_defined t) + Code_id_or_symbol.Set.empty + in + Code_id_or_symbol.Set.union code closure_symbols + let apply_name_permutation t _perm = t let free_names t = diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli index 443032f79766..858404634def 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.mli @@ -37,6 +37,8 @@ module Bound_symbols : sig val closure_symbols_being_defined : t -> Symbol.Set.t + val everything_being_defined : t -> Code_id_or_symbol.Set.t + val disjoint_union : t -> t -> t include Expr_std.S with type t := t From 8dd324b7508ad9c37bb1e9f8dce65a68a11c8fb7 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 16:58:34 +0000 Subject: [PATCH 41/80] SCC compiles --- .../flambda2.0/simplify/simplify_expr.rec.ml | 176 ++++++++++-------- middle_end/flambda2.0/terms/flambda.mli | 2 + 2 files changed, 104 insertions(+), 74 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 86fc72928f76..826782084f06 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -122,65 +122,88 @@ and simplify_let_symbol List.fold_left (fun dep_graph (bound_symbols, defining_expr) -> Code_id_or_symbol.Set.fold (fun (being_defined : Code_id_or_symbol.t) dep_graph -> - match being_defined with - | Code_id code_id -> - begin match (defining_expr : Static.const.t) with - | Code_and_set_of_closures { code; set_of_closures = _; } -> - assert (Code_id.Map.mem code_id code); - let code = Code_id.Map.find code_id code in - let free_names_params_and_body = - match code.params_and_body with - | Deleted -> Name_occurrences.empty - | Present params_and_body -> - Function_params_and_body.free_names params_and_body - in - let free_names_newer_version_of = - match code.newer_version_of with - | None -> Name_occurrences.empty - | Some newer_version_of -> - (* We treat this like a real code ID dependency, not a - "newer version of code ID" dependency. *) - Name_occurrences.add_code_id Name_occurrences.empty - newer_version_of NM.normal - in - Name_occurrences.union free_names_params_and_body - free_names_newer_version_of - | _ -> - Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" - Static_const.print defining_expr - Bound_symbols.print bound_symbols - end - | Symbol symbol -> - begin match bound_symbols with - | Singleton _ -> Static_const.free_names defining_expr - | Code_and_set_of_closures { code_ids; closure_symbols; } -> - let closure_symbols = - closure_symbols - |> Closure_id.Map.elements - |> List.map (fun (closure_id, sym) -> sym, closure_id) - |> Symbol.Map.of_alist - in - assert (Symbol.Map.mem symbol closure_symbols); - let closure_id = Symbol.Map.find symbol closure_symbols in - match (defining_expr : Static.const.t) with - | Code_and_set_of_closures { code = _; set_of_closures; } -> - begin match set_of_closures with - | None -> - Misc.fatal_errorf "No set of closures given for@ %a" - Symbol.print symbol - | Some set_of_closures -> - (* CR mshinwell: Make sure the closure ID exists in the - set of closures *) - ignore closure_id; - (* We take the free names of the whole set of closures - for every closure symbol defined by it. *) - Set_of_closures.free_names set_of_closures - end - | _ -> + let free_names = + match being_defined with + | Code_id code_id -> + begin match (defining_expr : Static_const.t) with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + assert (Code_id.Map.mem code_id code); + let code = Code_id.Map.find code_id code in + let free_names_params_and_body = + match code.params_and_body with + | Deleted -> Name_occurrences.empty + | Present params_and_body -> + Function_params_and_body.free_names params_and_body + in + let free_names_newer_version_of = + match code.newer_version_of with + | None -> Name_occurrences.empty + | Some newer_version_of -> + Name_occurrences.add_newer_version_of_code_id + Name_occurrences.empty newer_version_of NM.normal + in + Name_occurrences.union free_names_params_and_body + free_names_newer_version_of + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ + | Immutable_string _ -> Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" Static_const.print defining_expr Bound_symbols.print bound_symbols - end) + end + | Symbol symbol -> + begin match (bound_symbols : Bound_symbols.t) with + | Singleton _ -> Static_const.free_names defining_expr + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + let closure_symbols = + closure_symbols + |> Closure_id.Map.bindings + |> List.map (fun (closure_id, sym) -> sym, closure_id) + |> Symbol.Map.of_list + in + assert (Symbol.Map.mem symbol closure_symbols); + let closure_id = Symbol.Map.find symbol closure_symbols in + match (defining_expr : Static_const.t) with + | Code_and_set_of_closures { code = _; set_of_closures; } -> + begin match set_of_closures with + | None -> + Misc.fatal_errorf "No set of closures given for@ %a" + Symbol.print symbol + | Some set_of_closures -> + (* CR mshinwell: Make sure the closure ID exists in the + set of closures *) + ignore closure_id; + (* We take the free names of the whole set of closures + for every closure symbol defined by it. *) + Set_of_closures.free_names set_of_closures + end + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ + | Mutable_string _ | Immutable_string _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print defining_expr + Bound_symbols.print bound_symbols + end + in + let free_syms = Name_occurrences.symbols free_names in + let free_code_ids = + Code_id.Set.union (Name_occurrences.code_ids free_names) + (Name_occurrences.newer_version_of_code_ids free_names) + in + let free_syms = + Symbol.Set.fold (fun sym free_syms -> + Code_id_or_symbol.Set.add (Symbol sym) free_syms) + free_syms + Code_id_or_symbol.Set.empty + in + let free_code_ids = + Code_id.Set.fold (fun code_id free_code_ids -> + Code_id_or_symbol.Set.add (Code_id code_id) free_code_ids) + free_code_ids + Code_id_or_symbol.Set.empty + in + let deps = Code_id_or_symbol.Set.union free_syms free_code_ids in + Code_id_or_symbol.Map.add being_defined deps dep_graph) (Bound_symbols.everything_being_defined bound_symbols) dep_graph) Code_id_or_symbol.Map.empty @@ -192,12 +215,14 @@ and simplify_let_symbol in let find_code code_id = let result = - List.find_opt (fun (_bound_symbols, (static_const : Static_const.t)) -> + List.find_map (fun (_bound_symbols, (static_const : Static_const.t)) -> match static_const with | Code_and_set_of_closures { code; set_of_closures = _; } -> Code_id.Map.find_opt code_id code - | _ -> None) - lifted_constants_dep_graph + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ + | Mutable_string _ | Immutable_string _ -> None) + all_lifted_constants in match result with | None -> @@ -207,45 +232,48 @@ and simplify_let_symbol in let find_non_closure_or_closure_symbol sym = let result = - List.find_opt + List.find_map (fun ((bound_symbols : Bound_symbols.t), (static_const : Static_const.t)) - : non_closure_or_closure_symbol -> + : non_closure_or_closure_symbol option -> match bound_symbols with - | Singleton _ -> Non_closure static_const + | Singleton sym' -> + if Symbol.equal sym sym' then Some (Non_closure_symbol static_const) + else None | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> let closure_symbols = (* CR mshinwell: duplicated from above *) closure_symbols - |> Closure_id.Map.elements + |> Closure_id.Map.bindings |> List.map (fun (closure_id, sym) -> sym, closure_id) - |> Symbol.Map.of_alist + |> Symbol.Map.of_list in match Symbol.Map.find sym closure_symbols with | exception Not_found -> None | closure_id -> (* CR mshinwell: duplicated from above *) - match (defining_expr : Static.const.t) with + match (defining_expr : Static_const.t) with | Code_and_set_of_closures { code = _; set_of_closures; } -> begin match set_of_closures with | None -> Misc.fatal_errorf "No set of closures given for@ %a" - Symbol.print symbol + Symbol.print sym | Some set_of_closures -> (* CR mshinwell: Make sure the closure ID exists in the set of closures *) - Closure_symbol (closure_id, set_of_closures) + Some (Closure_symbol (closure_id, set_of_closures)) end - | _ -> + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ + | Mutable_string _ | Immutable_string _ -> Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" Static_const.print defining_expr Bound_symbols.print bound_symbols) - lifted_constants_dep_graph + all_lifted_constants in match result with | None -> - Misc.fatal_errorf "Definition for symbol %a not found" - Symbol.print symbol + Misc.fatal_errorf "Definition for symbol %a not found" Symbol.print sym | Some result -> result in let bindings_outermost_last = @@ -284,7 +312,7 @@ and simplify_let_symbol let defining_expr : Static_const.t = Code_and_set_of_closures { code = Code_id.Map.empty; - set_of_closures = Some set; + set_of_closures = Some set_of_closures; } in bound_symbols, defining_expr @@ -304,7 +332,7 @@ and simplify_let_symbol in code_ids, closure_symbols, code, set_of_closures | Symbol symbol -> - match find_code_or_closure_symbol symbol with + match find_non_closure_or_closure_symbol symbol with | Closure_symbol (closure_id, set) -> assert (not (Closure_id.Map.mem closure_id closure_symbols)); @@ -325,7 +353,7 @@ and simplify_let_symbol set_of_closures in code_ids, closure_symbols, code, set_of_closures - | Non_closure_symbol -> + | Non_closure_symbol _ -> Misc.fatal_errorf "Symbol %a was involved in recursion \ that cannot be compiled" Symbol.print symbol) diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index 31f1f1956685..e6a1599608f0 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -231,6 +231,8 @@ end and Let_symbol_expr : sig val closure_symbols_being_defined : t -> Symbol.Set.t + val everything_being_defined : t -> Code_id_or_symbol.Set.t + val disjoint_union : t -> t -> t include Expr_std.S with type t := t From 6020ed9a3ae6009ff436e8b9fc455534e6793a5f Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 17:12:46 +0000 Subject: [PATCH 42/80] SCC compiles --- .../flambda2.0/simplify/simplify_expr.rec.ml | 24 +++++++++++-------- .../flambda2.0/terms/let_symbol_expr.rec.ml | 2 +- utils/strongly_connected_components.ml | 7 ++++++ 3 files changed, 22 insertions(+), 11 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 826782084f06..d8edbe264995 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -209,6 +209,11 @@ and simplify_let_symbol Code_id_or_symbol.Map.empty all_lifted_constants in +(* + Format.eprintf "SCC graph is:@ %a\n%!" + (Code_id_or_symbol.Map.print Code_id_or_symbol.Set.print) + lifted_constants_dep_graph; +*) let connected_components = SCC_lifted_constants.connected_components_sorted_from_roots_to_leaf lifted_constants_dep_graph @@ -252,12 +257,15 @@ and simplify_let_symbol | exception Not_found -> None | closure_id -> (* CR mshinwell: duplicated from above *) - match (defining_expr : Static_const.t) with + match (static_const : Static_const.t) with | Code_and_set_of_closures { code = _; set_of_closures; } -> begin match set_of_closures with | None -> - Misc.fatal_errorf "No set of closures given for@ %a" + Misc.fatal_errorf "No set of closures given for@ %a@ in \ + binding of:@ %a@ to:@ %a" Symbol.print sym + Bound_symbols.print bound_symbols + Static_const.print static_const | Some set_of_closures -> (* CR mshinwell: Make sure the closure ID exists in the set of closures *) @@ -343,14 +351,10 @@ and simplify_let_symbol match set_of_closures with | None -> Some set | Some set' -> - if not (Set_of_closures.equal set set') then begin - Misc.fatal_errorf "Sets of closures differ for %a: \ - %a@ versus@ %a" - Symbol.print symbol - Set_of_closures.print set - Set_of_closures.print set' - end; - set_of_closures + if not (Set_of_closures.equal set set') then + Some (Set_of_closures.disjoint_union set set') + else + set_of_closures in code_ids, closure_symbols, code, set_of_closures | Non_closure_symbol _ -> diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index c6b33103953a..f7b942b7e543 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -234,7 +234,7 @@ let print_flattened_descr_lhs ppf descr = match descr with | Code (code_id, _) -> Code_id.print ppf code_id | Set_of_closures (closure_symbols, _) -> - Format.fprintf ppf "%a" + Format.fprintf ppf "@[%a@]" (Format.pp_print_list ~pp_sep:Format.pp_print_space print_closure_binding) (Closure_id.Map.bindings closure_symbols) diff --git a/utils/strongly_connected_components.ml b/utils/strongly_connected_components.ml index a11f6987f4d9..01b826711fc9 100644 --- a/utils/strongly_connected_components.ml +++ b/utils/strongly_connected_components.ml @@ -164,6 +164,12 @@ module Make (Id : Identifiable.S) = struct Array.init size (fun i -> let _, dests = a.(i) in Id.Set.fold (fun dest acc -> + (* CR mshinwell: work out what to do about this *) + try + let v = Id.Map.find dest back in + v :: acc + with Not_found -> acc) +(* Old code: let v = try Id.Map.find dest back with Not_found -> @@ -172,6 +178,7 @@ module Make (Id : Identifiable.S) = struct Id.print dest in v :: acc) +*) dests []) in { back; forth }, integer_graph From 0b91a9255c89e42195c3e0cdfcbd3b7e18585b62 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 3 Jan 2020 17:19:07 +0000 Subject: [PATCH 43/80] work --- flambdatest/mlexamples/tests8.ml | 5 +++++ middle_end/flambda2.0/simplify/simplify_expr.rec.ml | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/flambdatest/mlexamples/tests8.ml b/flambdatest/mlexamples/tests8.ml index 718896ad3ba3..fc992ca2b0f4 100644 --- a/flambdatest/mlexamples/tests8.ml +++ b/flambdatest/mlexamples/tests8.ml @@ -4,6 +4,11 @@ type +'a node = and 'a t = unit -> 'a node +(* +external rand : unit -> int = "rand" +let r = rand () +*) + let rec map_foo f seq () = match seq() with | Nil -> Nil | Cons (x, next) -> diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index d8edbe264995..83f265af6bef 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -381,7 +381,7 @@ and simplify_let_symbol in binding :: bindings) [] - connected_components + (Array.of_list (List.rev (Array.to_list connected_components))) in let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> From 03f28119f2e5209fff824cd6a6f4a78cd9503d22 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 11:15:26 +0000 Subject: [PATCH 44/80] Lifting --- .../lifting/reify_continuation_param_types.ml | 105 +----- .../lifting/sort_lifted_constants.ml | 307 ++++++++++++++++++ .../lifting/sort_lifted_constants.mli | 25 ++ .../flambda2.0/simplify/simplify_expr.rec.ml | 298 +---------------- .../flambda2.0/simplify/simplify_named.rec.ml | 1 - middle_end/flambda2.0/utils/top_closure.ml | 79 ----- middle_end/flambda2.0/utils/top_closure.mli | 50 --- 7 files changed, 355 insertions(+), 510 deletions(-) create mode 100644 middle_end/flambda2.0/lifting/sort_lifted_constants.ml create mode 100644 middle_end/flambda2.0/lifting/sort_lifted_constants.mli delete mode 100644 middle_end/flambda2.0/utils/top_closure.ml delete mode 100644 middle_end/flambda2.0/utils/top_closure.mli diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index 0984dd27cec9..5701425f2c14 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -180,25 +180,10 @@ let reify_types_of_continuation_param_types dacc ~params = params (dacc, Variable.Map.empty, [], Set_of_closures.Map.empty) -module Bindings_top_sort = - Top_closure.Make - (struct - type t = Symbol.Set.Set.t - type elt = Symbol.Set.t - let empty = Symbol.Set.Set.empty - let add t elt = Symbol.Set.Set.add elt t - let mem t elt = Symbol.Set.Set.mem elt t - end) - (struct - type 'a t = 'a - let return t = t - let (>>=) t f = f t - end) - let lift_via_reification_of_continuation_param_types dacc ~params ~(extra_params_and_args : Continuation_extra_params_and_args.t) ~(handler : Expr.t) = - let dacc, reified_continuation_params_to_symbols, reified_definitions, + let dacc, _reified_continuation_params_to_symbols, reified_definitions, _closure_symbols_by_set = let params = Variable.Set.union (KP.List.var_set params) @@ -206,90 +191,18 @@ let lift_via_reification_of_continuation_param_types dacc ~params in reify_types_of_continuation_param_types dacc ~params in - (* CR mshinwell: If recursion extends beyond that which can be handled - by the set-of-closures cases, then we would need a strongly connected - components analysis, prior to the top sort. Any set arising from SCC - that has more than one element must be a complicated recursive case, - which could be dealt with using the "symbol placeholder" approach - (variables that are substituted for the continuation's parameters, which - are in turn substituted for symbols at the Cmm translation phase). - (Any case containing >1 set of closures is maybe a bug?) *) - let reified_definitions = - let sorted = - Bindings_top_sort.top_closure reified_definitions - ~key:(fun (bound_syms, _static_const) -> - Let_symbol.Bound_symbols.being_defined bound_syms) - ~deps:(fun (bound_syms, static_const) -> - let var_deps = - static_const - |> Static_const.free_names - |> Name_occurrences.variables - |> Variable.Set.elements - in - let sym_deps = - List.fold_left (fun sym_deps var -> - match - Variable.Map.find var reified_continuation_params_to_symbols - with - | exception Not_found -> - (* The variable's type couldn't be reified. *) - sym_deps - | symbol -> Symbol.Set.add symbol sym_deps) - Symbol.Set.empty - var_deps - in - let sym_deps = - let closure_symbols_being_defined = - (* Closure symbols are bound recursively within the same set. We - need to remove them from the dependency sets to avoid the - topological sort seeing cycles. We don't unilaterally remove - all symbols in [Bound_symbols.being_defined syms] (as opposed - to [closure_symbols_being_defined]) as, in the case where - illegal recursion has been constructed, it could cause the - topological sort to succeed and the fatal error below to be - concealed. *) - Let_symbol.Bound_symbols.closure_symbols_being_defined bound_syms - in - Symbol.Set.diff sym_deps closure_symbols_being_defined - in - Symbol.Set.fold (fun sym deps -> - let dep = - List.find_opt (fun (bound_symbols, _static_const) -> - Symbol.Set.mem sym - (Let_symbol.Bound_symbols.being_defined bound_symbols)) - reified_definitions - in - match dep with - | Some dep -> dep :: deps - | None -> - Misc.fatal_errorf "Couldn't find definition for %a" - Symbol.print sym) - sym_deps - []) - in - match sorted with - | Ok sorted -> sorted - | Error _ -> - Misc.fatal_errorf "Potential [Let_symbol] bindings arising from reified \ - types of continuation parameters contain recursion that cannot be \ - compiled:@ %a" - (Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf (bound_symbols, defining_expr) -> - Format.fprintf ppf "@[%a@ %a@]" - Let_symbol.Bound_symbols.print bound_symbols - Static_const.print defining_expr)) - reified_definitions - in - (* By effectively reversing the list during the fold, we rely on the - following property: - Let the list L be a topological sort of a directed graph G. - Then the reverse of L is a topological sort of the transpose of G. - *) + (* CR mshinwell: If recursion extends beyond that which can be handled by the + set-of-closures cases, then we would need something like the "symbol + placeholder" approach (variables that are substituted for the + continuation's parameters, which are in turn substituted for symbols at the + Cmm translation phase). (Any SCC class containing >1 set of closures is + maybe a bug?) *) + let reified_definitions = Sort_lifted_constants.sort reified_definitions in let handler = List.fold_left (fun handler (bound_symbols, defining_expr) -> Let_symbol.create bound_symbols defining_expr handler |> Expr.create_let_symbol) handler - reified_definitions + reified_definitions.bindings_outermost_last in dacc, handler diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml new file mode 100644 index 000000000000..06e7fea3ff32 --- /dev/null +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml @@ -0,0 +1,307 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2020 OCamlPro SAS *) +(* Copyright 2014--2020 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-30-40-41-42"] + +open! Simplify_import + +module SCC_lifted_constants = + Strongly_connected_components.Make (Code_id_or_symbol) + +type non_closure_or_closure_symbol = + | Non_closure_symbol of Static_const.t + | Closure_symbol of Closure_id.t * Set_of_closures.t + +type result = { + bindings_outermost_last : (Bound_symbols.t * Static_const.t) list; +} + +let sort lifted_constants = + (* The various lifted constants may exhibit recursion between themselves + (specifically between closures and/or code). We use SCC to obtain a + topological sort of groups that must be coalesced into single + code-and-set-of-closures definitions. *) + let lifted_constants_dep_graph = + List.fold_left (fun dep_graph (bound_symbols, defining_expr) -> + Code_id_or_symbol.Set.fold + (fun (being_defined : Code_id_or_symbol.t) dep_graph -> + let free_names = + match being_defined with + | Code_id code_id -> + begin match (defining_expr : Static_const.t) with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + assert (Code_id.Map.mem code_id code); + let code = Code_id.Map.find code_id code in + let free_names_params_and_body = + match code.params_and_body with + | Deleted -> Name_occurrences.empty + | Present params_and_body -> + Function_params_and_body.free_names params_and_body + in + let free_names_newer_version_of = + match code.newer_version_of with + | None -> Name_occurrences.empty + | Some newer_version_of -> + Name_occurrences.add_newer_version_of_code_id + Name_occurrences.empty newer_version_of NM.normal + in + Name_occurrences.union free_names_params_and_body + free_names_newer_version_of + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ + | Immutable_string _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print defining_expr + Bound_symbols.print bound_symbols + end + | Symbol symbol -> + begin match (bound_symbols : Bound_symbols.t) with + | Singleton _ -> Static_const.free_names defining_expr + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + let closure_symbols = + closure_symbols + |> Closure_id.Map.bindings + |> List.map (fun (closure_id, sym) -> sym, closure_id) + |> Symbol.Map.of_list + in + assert (Symbol.Map.mem symbol closure_symbols); + let closure_id = Symbol.Map.find symbol closure_symbols in + match (defining_expr : Static_const.t) with + | Code_and_set_of_closures { code = _; set_of_closures; } -> + begin match set_of_closures with + | None -> + Misc.fatal_errorf "No set of closures given for@ %a" + Symbol.print symbol + | Some set_of_closures -> + (* CR mshinwell: Make sure the closure ID exists in the + set of closures *) + ignore closure_id; + (* We take the free names of the whole set of closures + for every closure symbol defined by it. *) + Set_of_closures.free_names set_of_closures + end + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ + | Mutable_string _ | Immutable_string _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print defining_expr + Bound_symbols.print bound_symbols + end + in + let free_syms = Name_occurrences.symbols free_names in + let free_code_ids = + Code_id.Set.union (Name_occurrences.code_ids free_names) + (Name_occurrences.newer_version_of_code_ids free_names) + in + let free_syms = + Symbol.Set.fold (fun sym free_syms -> + Code_id_or_symbol.Set.add (Symbol sym) free_syms) + free_syms + Code_id_or_symbol.Set.empty + in + let free_code_ids = + Code_id.Set.fold (fun code_id free_code_ids -> + Code_id_or_symbol.Set.add (Code_id code_id) free_code_ids) + free_code_ids + Code_id_or_symbol.Set.empty + in + let deps = Code_id_or_symbol.Set.union free_syms free_code_ids in + Code_id_or_symbol.Map.add being_defined deps dep_graph) + (Bound_symbols.everything_being_defined bound_symbols) + dep_graph) + Code_id_or_symbol.Map.empty + lifted_constants + in +(* + Format.eprintf "SCC graph is:@ %a\n%!" + (Code_id_or_symbol.Map.print Code_id_or_symbol.Set.print) + lifted_constants_dep_graph; +*) + let connected_components = + SCC_lifted_constants.connected_components_sorted_from_roots_to_leaf + lifted_constants_dep_graph + in + let find_code code_id = + let result = + List.find_map (fun (_bound_symbols, (static_const : Static_const.t)) -> + match static_const with + | Code_and_set_of_closures { code; set_of_closures = _; } -> + Code_id.Map.find_opt code_id code + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ + | Mutable_string _ | Immutable_string _ -> None) + lifted_constants + in + match result with + | None -> + Misc.fatal_errorf "Definition for code ID %a not found" + Code_id.print code_id + | Some code -> code + in + let find_non_closure_or_closure_symbol sym = + let result = + List.find_map + (fun ((bound_symbols : Bound_symbols.t), + (static_const : Static_const.t)) + : non_closure_or_closure_symbol option -> + match bound_symbols with + | Singleton sym' -> + if Symbol.equal sym sym' then Some (Non_closure_symbol static_const) + else None + | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> + let closure_symbols = + (* CR mshinwell: duplicated from above *) + closure_symbols + |> Closure_id.Map.bindings + |> List.map (fun (closure_id, sym) -> sym, closure_id) + |> Symbol.Map.of_list + in + match Symbol.Map.find sym closure_symbols with + | exception Not_found -> None + | closure_id -> + (* CR mshinwell: duplicated from above *) + match (static_const : Static_const.t) with + | Code_and_set_of_closures { code = _; set_of_closures; } -> + begin match set_of_closures with + | None -> + Misc.fatal_errorf "No set of closures given for@ %a@ in \ + binding of:@ %a@ to:@ %a" + Symbol.print sym + Bound_symbols.print bound_symbols + Static_const.print static_const + | Some set_of_closures -> + (* CR mshinwell: Make sure the closure ID exists in the + set of closures *) + Some (Closure_symbol (closure_id, set_of_closures)) + end + | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ + | Boxed_nativeint _ | Immutable_float_array _ + | Mutable_string _ | Immutable_string _ -> + Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" + Static_const.print static_const + Bound_symbols.print bound_symbols) + lifted_constants + in + match result with + | None -> + Misc.fatal_errorf "Definition for symbol %a not found" Symbol.print sym + | Some result -> result + in + let bindings_outermost_last = + Array.fold_left (fun bindings (group : SCC_lifted_constants.component) -> + let binding = + match group with + | No_loop (Code_id code_id) -> + let code = find_code code_id in + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { + code_ids = Code_id.Set.singleton code_id; + closure_symbols = Closure_id.Map.empty; + } + in + let defining_expr : Static_const.t = + Code_and_set_of_closures { + code = Code_id.Map.singleton code_id code; + set_of_closures = None; + } + in + bound_symbols, defining_expr + | No_loop (Symbol sym) -> + (* CR mshinwell: What happens if [sym] is one part of a set + of closures with more than one closure inside it? *) + begin match find_non_closure_or_closure_symbol sym with + | Non_closure_symbol defining_expr -> + let bound_symbols : Bound_symbols.t = Singleton sym in + bound_symbols, defining_expr + | Closure_symbol (closure_id, set_of_closures) -> + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { + code_ids = Code_id.Set.empty; + closure_symbols = Closure_id.Map.singleton closure_id sym; + } + in + let defining_expr : Static_const.t = + Code_and_set_of_closures { + code = Code_id.Map.empty; + set_of_closures = Some set_of_closures; + } + in + bound_symbols, defining_expr + end + | Has_loop members -> + (* CR mshinwell: It seems like this may end up copying sets of + closures. *) + let code_ids, closure_symbols, code, set_of_closures = + List.fold_left + (fun (code_ids, closure_symbols, code, set_of_closures) + (member : Code_id_or_symbol.t) -> + match member with + | Code_id code_id -> + let code_ids = Code_id.Set.add code_id code_ids in + let code = + Code_id.Map.add code_id (find_code code_id) code + in + code_ids, closure_symbols, code, set_of_closures + | Symbol symbol -> + match find_non_closure_or_closure_symbol symbol with + | Closure_symbol (closure_id, set) -> + assert (not (Closure_id.Map.mem closure_id + closure_symbols)); + let closure_symbols = + Closure_id.Map.add closure_id symbol closure_symbols + in + let set_of_closures = + match set_of_closures with + | None -> Some set + | Some set' -> + if not (Set_of_closures.equal set set') then + Some (Set_of_closures.disjoint_union set set') + else + set_of_closures + in + code_ids, closure_symbols, code, set_of_closures + | Non_closure_symbol _ -> + Misc.fatal_errorf "Symbol %a was involved in recursion \ + that cannot be compiled" + Symbol.print symbol) + (Code_id.Set.empty, Closure_id.Map.empty, + Code_id.Map.empty, None) + members + in + let bound_symbols : Bound_symbols.t = + Code_and_set_of_closures { + code_ids; + closure_symbols; + } + in + let defining_expr : Static_const.t = + Code_and_set_of_closures { + code; + set_of_closures; + } + in + bound_symbols, defining_expr + in + binding :: bindings) + [] + (Array.of_list (List.rev (Array.to_list connected_components))) + in + (* By effectively reversing the list during a subsequent fold on this + result, we rely on the following property: + Let the list L be a topological sort of a directed graph G. + Then the reverse of L is a topological sort of the transpose of G. + *) + { bindings_outermost_last; } diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.mli b/middle_end/flambda2.0/lifting/sort_lifted_constants.mli new file mode 100644 index 000000000000..dd3418995ad8 --- /dev/null +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2020 OCamlPro SAS *) +(* Copyright 2014--2020 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-30-40-41-42"] + +open! Simplify_import + +type result = private { + bindings_outermost_last : (Bound_symbols.t * Static_const.t) list; +} + +val sort : (Bound_symbols.t * Static_const.t) list -> result diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 83f265af6bef..13d0bbefd797 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -5,8 +5,8 @@ (* Pierre Chambart, OCamlPro *) (* Mark Shinwell and Leo White, Jane Street Europe *) (* *) -(* Copyright 2013--2019 OCamlPro SAS *) -(* Copyright 2014--2019 Jane Street Group LLC *) +(* Copyright 2013--2020 OCamlPro SAS *) +(* Copyright 2014--2020 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 *) @@ -27,13 +27,6 @@ open! Simplify_import type 'a k = CUE.t -> Code_age_relation.t -> R.t -> ('a * UA.t) -module SCC_lifted_constants = - Strongly_connected_components.Make (Code_id_or_symbol) - -type non_closure_or_closure_symbol = - | Non_closure_symbol of Static_const.t - | Closure_symbol of Closure_id.t * Set_of_closures.t - let rec simplify_let : 'a. DA.t -> Let.t -> 'a k -> Expr.t * 'a * UA.t = fun dacc let_expr k -> @@ -98,297 +91,34 @@ and simplify_let_symbol defining denv) in - let defining_expr_lifted_constants = R.get_lifted_constants (DA.r dacc) in - let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let body, user_data, uacc = simplify_expr dacc body k in - let subsequent_lifted_constants = R.get_lifted_constants (UA.r uacc) in + let lifted_constants = R.get_lifted_constants (UA.r uacc) in let uacc = UA.map_r uacc ~f:(fun r -> R.set_lifted_constants r prior_lifted_constants) in let all_lifted_constants = - List.map (fun lifted_constant -> - LC.bound_symbols lifted_constant, LC.defining_expr lifted_constant) - defining_expr_lifted_constants - @ (bound_symbols, defining_expr) + (bound_symbols, defining_expr) :: List.map (fun lifted_constant -> LC.bound_symbols lifted_constant, LC.defining_expr lifted_constant) - subsequent_lifted_constants - in - (* The various lifted constants may exhibit recursion between themselves - (specifically between closures and/or code). We use SCC to obtain a - topological sort of groups that must be coalesced into single - code-and-set-of-closures definitions. *) - let lifted_constants_dep_graph = - List.fold_left (fun dep_graph (bound_symbols, defining_expr) -> - Code_id_or_symbol.Set.fold - (fun (being_defined : Code_id_or_symbol.t) dep_graph -> - let free_names = - match being_defined with - | Code_id code_id -> - begin match (defining_expr : Static_const.t) with - | Code_and_set_of_closures { code; set_of_closures = _; } -> - assert (Code_id.Map.mem code_id code); - let code = Code_id.Map.find code_id code in - let free_names_params_and_body = - match code.params_and_body with - | Deleted -> Name_occurrences.empty - | Present params_and_body -> - Function_params_and_body.free_names params_and_body - in - let free_names_newer_version_of = - match code.newer_version_of with - | None -> Name_occurrences.empty - | Some newer_version_of -> - Name_occurrences.add_newer_version_of_code_id - Name_occurrences.empty newer_version_of NM.normal - in - Name_occurrences.union free_names_params_and_body - free_names_newer_version_of - | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ - | Boxed_nativeint _ | Immutable_float_array _ | Mutable_string _ - | Immutable_string _ -> - Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" - Static_const.print defining_expr - Bound_symbols.print bound_symbols - end - | Symbol symbol -> - begin match (bound_symbols : Bound_symbols.t) with - | Singleton _ -> Static_const.free_names defining_expr - | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> - let closure_symbols = - closure_symbols - |> Closure_id.Map.bindings - |> List.map (fun (closure_id, sym) -> sym, closure_id) - |> Symbol.Map.of_list - in - assert (Symbol.Map.mem symbol closure_symbols); - let closure_id = Symbol.Map.find symbol closure_symbols in - match (defining_expr : Static_const.t) with - | Code_and_set_of_closures { code = _; set_of_closures; } -> - begin match set_of_closures with - | None -> - Misc.fatal_errorf "No set of closures given for@ %a" - Symbol.print symbol - | Some set_of_closures -> - (* CR mshinwell: Make sure the closure ID exists in the - set of closures *) - ignore closure_id; - (* We take the free names of the whole set of closures - for every closure symbol defined by it. *) - Set_of_closures.free_names set_of_closures - end - | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ - | Boxed_nativeint _ | Immutable_float_array _ - | Mutable_string _ | Immutable_string _ -> - Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" - Static_const.print defining_expr - Bound_symbols.print bound_symbols - end - in - let free_syms = Name_occurrences.symbols free_names in - let free_code_ids = - Code_id.Set.union (Name_occurrences.code_ids free_names) - (Name_occurrences.newer_version_of_code_ids free_names) - in - let free_syms = - Symbol.Set.fold (fun sym free_syms -> - Code_id_or_symbol.Set.add (Symbol sym) free_syms) - free_syms - Code_id_or_symbol.Set.empty - in - let free_code_ids = - Code_id.Set.fold (fun code_id free_code_ids -> - Code_id_or_symbol.Set.add (Code_id code_id) free_code_ids) - free_code_ids - Code_id_or_symbol.Set.empty - in - let deps = Code_id_or_symbol.Set.union free_syms free_code_ids in - Code_id_or_symbol.Map.add being_defined deps dep_graph) - (Bound_symbols.everything_being_defined bound_symbols) - dep_graph) - Code_id_or_symbol.Map.empty - all_lifted_constants + lifted_constants in (* - Format.eprintf "SCC graph is:@ %a\n%!" - (Code_id_or_symbol.Map.print Code_id_or_symbol.Set.print) - lifted_constants_dep_graph; +Format.eprintf "All bindings:@ %a\n%!" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf (bound_syms, def) -> + Format.fprintf ppf "@[(%a@ %a)@]" + Bound_symbols.print bound_syms Static_const.print def)) + all_lifted_constants; *) - let connected_components = - SCC_lifted_constants.connected_components_sorted_from_roots_to_leaf - lifted_constants_dep_graph - in - let find_code code_id = - let result = - List.find_map (fun (_bound_symbols, (static_const : Static_const.t)) -> - match static_const with - | Code_and_set_of_closures { code; set_of_closures = _; } -> - Code_id.Map.find_opt code_id code - | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ - | Boxed_nativeint _ | Immutable_float_array _ - | Mutable_string _ | Immutable_string _ -> None) - all_lifted_constants - in - match result with - | None -> - Misc.fatal_errorf "Definition for code ID %a not found" - Code_id.print code_id - | Some code -> code - in - let find_non_closure_or_closure_symbol sym = - let result = - List.find_map - (fun ((bound_symbols : Bound_symbols.t), - (static_const : Static_const.t)) - : non_closure_or_closure_symbol option -> - match bound_symbols with - | Singleton sym' -> - if Symbol.equal sym sym' then Some (Non_closure_symbol static_const) - else None - | Code_and_set_of_closures { code_ids = _; closure_symbols; } -> - let closure_symbols = - (* CR mshinwell: duplicated from above *) - closure_symbols - |> Closure_id.Map.bindings - |> List.map (fun (closure_id, sym) -> sym, closure_id) - |> Symbol.Map.of_list - in - match Symbol.Map.find sym closure_symbols with - | exception Not_found -> None - | closure_id -> - (* CR mshinwell: duplicated from above *) - match (static_const : Static_const.t) with - | Code_and_set_of_closures { code = _; set_of_closures; } -> - begin match set_of_closures with - | None -> - Misc.fatal_errorf "No set of closures given for@ %a@ in \ - binding of:@ %a@ to:@ %a" - Symbol.print sym - Bound_symbols.print bound_symbols - Static_const.print static_const - | Some set_of_closures -> - (* CR mshinwell: Make sure the closure ID exists in the - set of closures *) - Some (Closure_symbol (closure_id, set_of_closures)) - end - | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ - | Boxed_nativeint _ | Immutable_float_array _ - | Mutable_string _ | Immutable_string _ -> - Misc.fatal_errorf "Bad defining expression@ %a@ for@ %a" - Static_const.print defining_expr - Bound_symbols.print bound_symbols) - all_lifted_constants - in - match result with - | None -> - Misc.fatal_errorf "Definition for symbol %a not found" Symbol.print sym - | Some result -> result - in - let bindings_outermost_last = - Array.fold_left (fun bindings (group : SCC_lifted_constants.component) -> - let binding = - match group with - | No_loop (Code_id code_id) -> - let code = find_code code_id in - let bound_symbols : Bound_symbols.t = - Code_and_set_of_closures { - code_ids = Code_id.Set.singleton code_id; - closure_symbols = Closure_id.Map.empty; - } - in - let defining_expr : Static_const.t = - Code_and_set_of_closures { - code = Code_id.Map.singleton code_id code; - set_of_closures = None; - } - in - bound_symbols, defining_expr - | No_loop (Symbol sym) -> - (* CR mshinwell: What happens if [sym] is one part of a set - of closures with more than one closure inside it? *) - begin match find_non_closure_or_closure_symbol sym with - | Non_closure_symbol defining_expr -> - let bound_symbols : Bound_symbols.t = Singleton sym in - bound_symbols, defining_expr - | Closure_symbol (closure_id, set_of_closures) -> - let bound_symbols : Bound_symbols.t = - Code_and_set_of_closures { - code_ids = Code_id.Set.empty; - closure_symbols = Closure_id.Map.singleton closure_id sym; - } - in - let defining_expr : Static_const.t = - Code_and_set_of_closures { - code = Code_id.Map.empty; - set_of_closures = Some set_of_closures; - } - in - bound_symbols, defining_expr - end - | Has_loop members -> - (* CR mshinwell: It seems like this may end up copying sets of - closures. *) - let code_ids, closure_symbols, code, set_of_closures = - List.fold_left - (fun (code_ids, closure_symbols, code, set_of_closures) - (member : Code_id_or_symbol.t) -> - match member with - | Code_id code_id -> - let code_ids = Code_id.Set.add code_id code_ids in - let code = - Code_id.Map.add code_id (find_code code_id) code - in - code_ids, closure_symbols, code, set_of_closures - | Symbol symbol -> - match find_non_closure_or_closure_symbol symbol with - | Closure_symbol (closure_id, set) -> - assert (not (Closure_id.Map.mem closure_id - closure_symbols)); - let closure_symbols = - Closure_id.Map.add closure_id symbol closure_symbols - in - let set_of_closures = - match set_of_closures with - | None -> Some set - | Some set' -> - if not (Set_of_closures.equal set set') then - Some (Set_of_closures.disjoint_union set set') - else - set_of_closures - in - code_ids, closure_symbols, code, set_of_closures - | Non_closure_symbol _ -> - Misc.fatal_errorf "Symbol %a was involved in recursion \ - that cannot be compiled" - Symbol.print symbol) - (Code_id.Set.empty, Closure_id.Map.empty, - Code_id.Map.empty, None) - members - in - let bound_symbols : Bound_symbols.t = - Code_and_set_of_closures { - code_ids; - closure_symbols; - } - in - let defining_expr : Static_const.t = - Code_and_set_of_closures { - code; - set_of_closures; - } - in - bound_symbols, defining_expr - in - binding :: bindings) - [] - (Array.of_list (List.rev (Array.to_list connected_components))) + let sorted_lifted_constants = + Sort_lifted_constants.sort all_lifted_constants in let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> Simplify_common.create_let_symbol (UA.code_age_relation uacc) bound_symbols defining_expr body) body - bindings_outermost_last + sorted_lifted_constants.bindings_outermost_last in expr, user_data, uacc diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index 9b818d0933b6..83cd4c9f528f 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -383,7 +383,6 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars closure_symbols denv) in - let dacc = DA.map_r dacc ~f:R.clear_lifted_constants in let _set_of_closures, dacc, types_of_symbols, bound_symbols, static_const = Simplify_static_const.simplify_set_of_closures0 dacc set_of_closures ~closure_symbols ~closure_elements ~closure_element_types diff --git a/middle_end/flambda2.0/utils/top_closure.ml b/middle_end/flambda2.0/utils/top_closure.ml deleted file mode 100644 index aef0e0569946..000000000000 --- a/middle_end/flambda2.0/utils/top_closure.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* The MIT License - -Copyright (c) 2016 Jane Street Group, LLC - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. *) - -module type Keys = sig - type t - - type elt - - val empty : t - - val add : t -> elt -> t - - val mem : t -> elt -> bool -end - -module type S = sig - type key - - type 'a monad - - val top_closure : - key:('a -> key) - -> deps:('a -> 'a list monad) - -> 'a list - -> ('a list, 'a list) result monad -end - -module Make (Keys : Keys) (Monad : Monad.S) = struct - open Monad - - let top_closure ~key ~deps elements = - let visited = ref Keys.empty in - let res = ref [] in - let rec loop elt ~temporarily_marked = - let key = key elt in - if Keys.mem temporarily_marked key then - return (Error [ elt ]) - else if not (Keys.mem !visited key) then ( - visited := Keys.add !visited key; - let temporarily_marked = Keys.add temporarily_marked key in - deps elt >>= iter_elts ~temporarily_marked >>= function - | Ok () -> - res := elt :: !res; - return (Ok ()) - | Error l -> return (Error (elt :: l)) - ) else - return (Ok ()) - and iter_elts elts ~temporarily_marked = - return elts >>= function - | [] -> return (Ok ()) - | elt :: elts -> ( - loop elt ~temporarily_marked >>= function - | Error _ as result -> return result - | Ok () -> iter_elts elts ~temporarily_marked ) - in - iter_elts elements ~temporarily_marked:Keys.empty >>= function - | Ok () -> return (Ok (List.rev !res)) - | Error elts -> return (Error elts) -end -[@@inlined always] diff --git a/middle_end/flambda2.0/utils/top_closure.mli b/middle_end/flambda2.0/utils/top_closure.mli deleted file mode 100644 index 294c20847563..000000000000 --- a/middle_end/flambda2.0/utils/top_closure.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* The MIT License - -Copyright (c) 2016 Jane Street Group, LLC - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. *) - -module type Keys = sig - type t - - type elt - - val empty : t - - val add : t -> elt -> t - - val mem : t -> elt -> bool -end - -module type S = sig - type key - - type 'a monad - - (** Returns [Error cycle] in case the graph is not a DAG *) - val top_closure : - key:('a -> key) - -> deps:('a -> 'a list monad) - -> 'a list - -> ('a list, 'a list) result monad -end - -module Make (Keys : Keys) (Monad : Monad.S) : - S with type key := Keys.elt and type 'a monad := 'a Monad.t -[@@inlined always] From 007a152670dcbfda12e0fd010d131e0e0ace8153 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 12:28:04 +0000 Subject: [PATCH 45/80] Improve simplify_phys_equal --- .../simplify/simplify_binary_primitive.ml | 134 +++++++++--------- 1 file changed, 68 insertions(+), 66 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_binary_primitive.ml b/middle_end/flambda2.0/simplify/simplify_binary_primitive.ml index e88c30c17f16..2d257e64a447 100644 --- a/middle_end/flambda2.0/simplify/simplify_binary_primitive.ml +++ b/middle_end/flambda2.0/simplify/simplify_binary_primitive.ml @@ -851,76 +851,78 @@ let simplify_phys_equal (op : P.equality_comparison) (kind : K.t) dacc ~original_term dbg ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var = let result = Name.var (Var_in_binding_pos.var result_var) in - begin match kind with - | Value -> - let typing_env = DE.typing_env (DA.denv dacc) in - let proof1 = T.prove_equals_tagged_immediates typing_env arg1_ty in - let proof2 = T.prove_equals_tagged_immediates typing_env arg2_ty in - begin match proof1, proof2 with - | Proved _, Proved _ -> - Binary_int_eq_comp_tagged_immediate.simplify op dacc ~original_term dbg - ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var - | _, _ -> - let physically_equal = - false - (* CR mshinwell: Resurrect this -- see cps_types branch. - T.values_physically_equal arg1_ty arg2_ty - *) - in - let physically_distinct = - false - (* CR mshinwell: Resurrect this -- see cps_types branch. - (* Structural inequality implies physical inequality. *) - let env = E.get_typing_environment env in - T.values_structurally_distinct (env, arg1_ty) (env, arg2_ty) - *) - in - let _const bool = - let env_extension = - TEE.one_equation result - (T.this_naked_immediate (Immediate.bool bool)) + let const bool = + let env_extension = + TEE.one_equation result + (T.this_naked_immediate (Immediate.bool bool)) + in + Reachable.reachable (Named.create_simple (Simple.const_bool bool)), + env_extension, dacc + in + if Simple.equal arg1 arg2 then const true + else + begin match kind with + | Value -> + let typing_env = DE.typing_env (DA.denv dacc) in + let proof1 = T.prove_equals_tagged_immediates typing_env arg1_ty in + let proof2 = T.prove_equals_tagged_immediates typing_env arg2_ty in + begin match proof1, proof2 with + | Proved _, Proved _ -> + Binary_int_eq_comp_tagged_immediate.simplify op dacc ~original_term dbg + ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var + | _, _ -> + let physically_equal = + false + (* CR mshinwell: Resurrect this -- see cps_types branch. + T.values_physically_equal arg1_ty arg2_ty + *) in - Reachable.reachable (Named.create_simple (Simple.const_bool bool)), - env_extension, dacc - in - begin match op, physically_equal, physically_distinct with -(* - | Eq, true, _ -> const true - | Neq, true, _ -> const false - | Eq, _, true -> const false - | Neq, _, true -> const true -*) - | _, _, _ -> - let env_extension = - TEE.one_equation result - (T.these_naked_immediates Immediate.all_bools) + let physically_distinct = + false + (* CR mshinwell: Resurrect this -- see cps_types branch. + (* Structural inequality implies physical inequality. *) + let env = E.get_typing_environment env in + T.values_structurally_distinct (env, arg1_ty) (env, arg2_ty) + *) in - Reachable.reachable original_term, env_extension, dacc + begin match op, physically_equal, physically_distinct with + (* + | Eq, true, _ -> const true + | Neq, true, _ -> const false + | Eq, _, true -> const false + | Neq, _, true -> const true + *) + | _, _, _ -> + let env_extension = + TEE.one_equation result + (T.these_naked_immediates Immediate.all_bools) + in + Reachable.reachable original_term, env_extension, dacc + end end + | Naked_number Naked_immediate -> + Misc.fatal_error "Not yet implemented" (* CR mshinwell: deal with this *) + | Naked_number Naked_float -> + (* CR mshinwell: Should this case be statically disallowed in the type, + to force people to use [Float_comp]? *) + let op : P.comparison = + match op with + | Eq -> Eq + | Neq -> Neq + in + Binary_float_comp.simplify op dacc ~original_term dbg + ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var + | Naked_number Naked_int32 -> + Binary_int_eq_comp_int32.simplify op dacc ~original_term dbg + ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var + | Naked_number Naked_int64 -> + Binary_int_eq_comp_int64.simplify op dacc ~original_term dbg + ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var + | Naked_number Naked_nativeint -> + Binary_int_eq_comp_nativeint.simplify op dacc ~original_term dbg + ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var + | Fabricated -> Misc.fatal_error "Fabricated kind not expected here" end - | Naked_number Naked_immediate -> - Misc.fatal_error "Not yet implemented" (* CR mshinwell: deal with this *) - | Naked_number Naked_float -> - (* CR mshinwell: Should this case be statically disallowed in the type, - to force people to use [Float_comp]? *) - let op : P.comparison = - match op with - | Eq -> Eq - | Neq -> Neq - in - Binary_float_comp.simplify op dacc ~original_term dbg - ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var - | Naked_number Naked_int32 -> - Binary_int_eq_comp_int32.simplify op dacc ~original_term dbg - ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var - | Naked_number Naked_int64 -> - Binary_int_eq_comp_int64.simplify op dacc ~original_term dbg - ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var - | Naked_number Naked_nativeint -> - Binary_int_eq_comp_nativeint.simplify op dacc ~original_term dbg - ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var - | Fabricated -> Misc.fatal_error "Fabricated kind not expected here" - end let try_cse dacc prim arg1 arg2 ~min_name_mode ~result_var : Simplify_common.cse = From 61cbfc352d83a05ac7e1c3f181b04933fa34ef10 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 12:34:39 +0000 Subject: [PATCH 46/80] Improve exception handler annotation on continuations when printing --- middle_end/flambda2.0/compilenv_deps/flambda_colours.ml | 1 + middle_end/flambda2.0/compilenv_deps/flambda_colours.mli | 1 + middle_end/flambda2.0/terms/continuation_handler.rec.ml | 6 ++++-- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml index 48a7c0fdf033..dec56e27615b 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml @@ -47,6 +47,7 @@ let static_part () = (C.fg_256 255) ^ (C.bg_256 237) let continuation () = C.fg_256 35 let continuation_definition () = C.bg_256 237 +let continuation_annotation () = (C.fg_256 202) ^ (C.bg_256 237) let name_abstraction () = C.fg_256 172 diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli index 77a68dd07e75..70d7d107ef8e 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli @@ -45,6 +45,7 @@ val static_part : unit -> string val continuation : unit -> string val continuation_definition : unit -> string +val continuation_annotation : unit -> string val name_abstraction : unit -> string diff --git a/middle_end/flambda2.0/terms/continuation_handler.rec.ml b/middle_end/flambda2.0/terms/continuation_handler.rec.ml index 1d40075435e4..ce75aa0e5209 100644 --- a/middle_end/flambda2.0/terms/continuation_handler.rec.ml +++ b/middle_end/flambda2.0/terms/continuation_handler.rec.ml @@ -31,7 +31,7 @@ let print_using_where_with_cache (recursive : Recursive.t) ~cache ppf k end; Continuation_params_and_handler.pattern_match t.params_and_handler ~f:(fun params ~handler -> - fprintf ppf "@[@<0>%s%a@<0>%s@<0>%s%s@<0>%s%s%s" + fprintf ppf "@[@<0>%s%a@<0>%s@<0>%s%s@<0>%s%s@<0>%s%s@<0>%s" (Flambda_colours.continuation_definition ()) Continuation.print k (Flambda_colours.normal ()) @@ -39,7 +39,9 @@ let print_using_where_with_cache (recursive : Recursive.t) ~cache ppf k (match recursive with Non_recursive -> "" | Recursive -> " (rec)") (Flambda_colours.normal ()) (if stub then " *stub*" else "") - (if is_exn_handler then " *exn*" else ""); + (Flambda_colours.continuation_annotation ()) + (if is_exn_handler then "[eh]" else "") + (Flambda_colours.normal ()); if List.length params > 0 then begin fprintf ppf " %a" Kinded_parameter.List.print params end; From a9950c411a02e3710efa9150f636278db50ca42b Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 12:52:17 +0000 Subject: [PATCH 47/80] Remove some useless let-bindings --- .../inlining/inlining_transforms.ml | 5 +- .../flambda2.0/simplify/env/downwards_acc.ml | 3 ++ .../flambda2.0/simplify/env/downwards_acc.mli | 2 + .../flambda2.0/simplify/simplify_common.ml | 6 ++- .../flambda2.0/simplify/simplify_common.mli | 3 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 10 ++-- .../flambda2.0/terms/apply_cont_expr.ml | 5 +- middle_end/flambda2.0/terms/expr.rec.ml | 47 ++++++++----------- middle_end/flambda2.0/terms/expr.rec.mli | 9 ++-- middle_end/flambda2.0/terms/flambda.mli | 9 ++-- .../flambda2.0/types/env/typing_env.rec.ml | 2 + .../flambda2.0/types/env/typing_env.rec.mli | 2 + middle_end/flambda2.0/types/flambda_type.mli | 2 + 13 files changed, 63 insertions(+), 42 deletions(-) diff --git a/middle_end/flambda2.0/inlining/inlining_transforms.ml b/middle_end/flambda2.0/inlining/inlining_transforms.ml index 652c5ee5a0a5..3ffb83028967 100644 --- a/middle_end/flambda2.0/inlining/inlining_transforms.ml +++ b/middle_end/flambda2.0/inlining/inlining_transforms.ml @@ -79,7 +79,10 @@ let inline dacc ~callee ~args function_decl apply_exn_continuation in Expr.apply_name_permutation - (Expr.bind_parameters_to_simples ~bind:params ~target:args + (Expr.bind_parameters_to_simples + ~name_mode_of_var: + (fun var -> DA.find_name_mode dacc (Name.var var)) + ~bind:params ~target:args (Expr.create_let (VB.create my_closure Name_mode.normal) (Named.create_simple callee) diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.ml b/middle_end/flambda2.0/simplify/env/downwards_acc.ml index 45f78d48c3db..0ee4f71ba84c 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.ml +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.ml @@ -106,3 +106,6 @@ let with_code_age_relation t code_age_relation = TE.with_code_age_relation (DE.typing_env (denv t)) code_age_relation in with_denv t (DE.with_typing_env (denv t) typing_env) + +let find_name_mode t name = + TE.find_name_mode (DE.typing_env (denv t)) name diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.mli b/middle_end/flambda2.0/simplify/env/downwards_acc.mli index a9d4bc5e3034..0a096e781461 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.mli +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.mli @@ -69,3 +69,5 @@ val continuation_uses_env : t -> Continuation_uses_env.t val code_age_relation : t -> Code_age_relation.t val with_code_age_relation : t -> Code_age_relation.t -> t + +val find_name_mode : t -> Name.t -> Name_mode.t diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 08beefe6e159..1d76c116f053 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -144,7 +144,8 @@ let update_exn_continuation_extra_args uacc ~exn_cont_use_id apply = (* CR mshinwell: Should probably move [Reachable] into the [Flambda] recursive loop and then move this into [Expr]. Maybe this could be tidied up a bit too? *) -let bind_let_bound ~bindings ~body = +let bind_let_bound dacc ~bindings ~body = + let name_mode_of_var var = DA.find_name_mode dacc (Name.var var) in List.fold_left (fun expr ((bound : Bindable_let_bound.t), (defining_expr : Reachable.t)) -> @@ -152,7 +153,8 @@ let bind_let_bound ~bindings ~body = | Invalid _ -> Expr.create_invalid () | Reachable defining_expr -> match bound with - | Singleton var -> Expr.bind ~bindings:[var, defining_expr] ~body:expr + | Singleton var -> + Expr.bind ~name_mode_of_var ~bindings:[var, defining_expr] ~body:expr | Set_of_closures _ -> Expr.create_pattern_let bound defining_expr expr) body (List.rev bindings) diff --git a/middle_end/flambda2.0/simplify/simplify_common.mli b/middle_end/flambda2.0/simplify/simplify_common.mli index 814116be0047..5d5af3b2c26f 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.mli +++ b/middle_end/flambda2.0/simplify/simplify_common.mli @@ -70,7 +70,8 @@ val update_exn_continuation_extra_args -> Apply_expr.t val bind_let_bound - : bindings:((Bindable_let_bound.t * Reachable.t) list) + : Downwards_acc.t + -> bindings:((Bindable_let_bound.t * Reachable.t) list) -> body:Flambda.Expr.t -> Flambda.Expr.t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 13d0bbefd797..58a24455852a 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -37,7 +37,7 @@ let rec simplify_let Simplify_named.simplify_named dacc ~bound_vars (L.defining_expr let_expr) in let body, user_data, uacc = simplify_expr dacc body k in - Simplify_common.bind_let_bound ~bindings ~body, user_data, uacc) + Simplify_common.bind_let_bound dacc ~bindings ~body, user_data, uacc) and simplify_let_symbol : 'a. DA.t -> Let_symbol.t -> 'a k -> Expr.t * 'a * UA.t @@ -1303,7 +1303,10 @@ Format.eprintf "Apply_cont is now %a\n%!" Expr.print apply_cont_expr; (List.combine params args) in let expr = - Expr.bind_parameters ~bindings:params_and_args ~body:handler + Expr.bind_parameters + ~name_mode_of_var:(fun _var -> Name_mode.normal) + (* All parameters and arguments must have [Normal] mode. *) + ~bindings:params_and_args ~body:handler in expr, user_data, uacc) @@ -1455,7 +1458,8 @@ and simplify_switch Simplify_named.simplify_named dacc ~bound_vars named in let body = k ~tagged_scrutinee:(Simple.var bound_to) in - Simplify_common.bind_let_bound ~bindings ~body, user_data, uacc + let body = Simplify_common.bind_let_bound dacc ~bindings ~body in + body, user_data, uacc in let body, user_data, uacc = match switch_is_identity with diff --git a/middle_end/flambda2.0/terms/apply_cont_expr.ml b/middle_end/flambda2.0/terms/apply_cont_expr.ml index 95f339e6c7f1..d17c0eeff1f8 100644 --- a/middle_end/flambda2.0/terms/apply_cont_expr.ml +++ b/middle_end/flambda2.0/terms/apply_cont_expr.ml @@ -70,7 +70,10 @@ let print ppf { k; args; trap_action; dbg; } = | args -> Format.fprintf ppf " %a" Simple.List.print args end; - Format.fprintf ppf "%a" Debuginfo.print_or_elide dbg; + Format.fprintf ppf "@<0>%s%a@<0>%s" + (Flambda_colours.elide ()) + Debuginfo.print_or_elide dbg + (Flambda_colours.normal ()); Format.fprintf ppf "@]" let print_with_cache ~cache:_ ppf t = print ppf t diff --git a/middle_end/flambda2.0/terms/expr.rec.ml b/middle_end/flambda2.0/terms/expr.rec.ml index 62f2e205827b..87ac17eae6f6 100644 --- a/middle_end/flambda2.0/terms/expr.rec.ml +++ b/middle_end/flambda2.0/terms/expr.rec.ml @@ -389,38 +389,29 @@ let create_if_then_else ~scrutinee ~if_true ~if_false = in create_switch ~scrutinee ~arms -let bind ~bindings ~body = +let bind ~name_mode_of_var ~bindings ~body = List.fold_left (fun expr (var, (target : Named.t)) -> -(* + let var_name_mode = Var_in_binding_pos.name_mode var in match target with | Simple simple -> - begin match Simple.descr simple with - | Name (Var rhs_var) -> - begin match Simple.rec_info simple with - | None -> - let perm = - Can't do this unless the name modes match! - Name_permutation.add_variable Name_permutation.empty - (Var_in_binding_pos.var var) rhs_var - in - (* CR mshinwell: Think more about this. - This is still leaving some let-bindings behind when it - shouldn't need to, e.g. - let bar = foo in - switch foo ... - seems to be turning into - let bar = foo in - switch bar *) - create_let var target (apply_name_permutation expr perm) - | Some _ -> create_let var target expr - end - | _ -> create_let var target expr + begin match Simple.must_be_var simple with + (* This isn't guaranteed to delete the [Let] (it won't in the case + where [rhs_var] appears in [body]), but will in many cases, and + helps with legibility of terms. *) + | Some rhs_var + when Name_mode.equal (name_mode_of_var rhs_var) var_name_mode -> + let perm = + Name_permutation.add_variable Name_permutation.empty + (Var_in_binding_pos.var var) rhs_var + in + create_let var target (apply_name_permutation expr perm) + | Some _ | None -> create_let var target expr end - | _ -> *) create_let var target expr) + | Prim _ | Set_of_closures _ -> create_let var target expr) body (List.rev bindings) -let bind_parameters ~bindings ~body = +let bind_parameters ~name_mode_of_var ~bindings ~body = let bindings = List.map (fun (bind, target) -> let var = @@ -429,9 +420,9 @@ let bind_parameters ~bindings ~body = var, target) bindings in - bind ~bindings ~body + bind ~name_mode_of_var ~bindings ~body -let bind_parameters_to_simples ~bind ~target body = +let bind_parameters_to_simples ~name_mode_of_var ~bind ~target body = if List.compare_lengths bind target <> 0 then begin Misc.fatal_errorf "Mismatching parameters and arguments: %a and %a" KP.List.print bind @@ -441,4 +432,4 @@ let bind_parameters_to_simples ~bind ~target body = List.map (fun (bind, target) -> bind, Named.create_simple target) (List.combine bind target) in - bind_parameters ~bindings ~body + bind_parameters ~name_mode_of_var ~bindings ~body diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index a62aa97668e0..cd9667f77c8a 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -113,12 +113,14 @@ val create_invalid : unit -> t [Immutable] [Let] expressions the given [(var, expr)] pairs around the body. *) val bind - : bindings:(Var_in_binding_pos.t * Named.t) list + : name_mode_of_var:(Variable.t -> Name_mode.t) + -> bindings:(Var_in_binding_pos.t * Named.t) list -> body:t -> t val bind_parameters - : bindings:(Kinded_parameter.t * Named.t) list + : name_mode_of_var:(Variable.t -> Name_mode.t) + -> bindings:(Kinded_parameter.t * Named.t) list -> body:t -> t @@ -127,7 +129,8 @@ val bind_parameters expression with bindings of each [p_i] to the corresponding [s_i], such as is typically used when performing an inlining transformation. *) val bind_parameters_to_simples - : bind:Kinded_parameter.t list + : name_mode_of_var:(Variable.t -> Name_mode.t) + -> bind:Kinded_parameter.t list -> target:Simple.t list -> t -> t diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index e6a1599608f0..c28f7fee72de 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -134,12 +134,14 @@ module rec Expr : sig [Immutable] [Let] expressions the given [(var, expr)] pairs around the body. *) val bind - : bindings:(Var_in_binding_pos.t * Named.t) list + : name_mode_of_var:(Variable.t -> Name_mode.t) + -> bindings:(Var_in_binding_pos.t * Named.t) list -> body:t -> t val bind_parameters - : bindings:(Kinded_parameter.t * Named.t) list + : name_mode_of_var:(Variable.t -> Name_mode.t) + -> bindings:(Kinded_parameter.t * Named.t) list -> body:t -> t @@ -148,7 +150,8 @@ module rec Expr : sig expression with bindings of each [p_i] to the corresponding [s_i], such as is typically used when performing an inlining transformation. *) val bind_parameters_to_simples - : bind:Kinded_parameter.t list + : name_mode_of_var:(Variable.t -> Name_mode.t) + -> bind:Kinded_parameter.t list -> target:Simple.t list -> t -> t diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.ml b/middle_end/flambda2.0/types/env/typing_env.rec.ml index 3271bfb12545..3398eb19ac4f 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.ml +++ b/middle_end/flambda2.0/types/env/typing_env.rec.ml @@ -716,6 +716,8 @@ let find_cse_rev t ~bound_to = | exception Not_found -> None | equation -> Some equation +let find_name_mode t name = snd (find_with_name_mode t name) + let meet_equation t name ty = let existing_ty = find t name in Format.eprintf "For %a, new type is %a, existing type %a\n%!" diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.mli b/middle_end/flambda2.0/types/env/typing_env.rec.mli index afb9cbdd797a..98db991b4889 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.mli +++ b/middle_end/flambda2.0/types/env/typing_env.rec.mli @@ -80,6 +80,8 @@ val find_cse_rev -> bound_to:Simple.t -> Flambda_primitive.Eligible_for_cse.t option +val find_name_mode : t -> Name.t -> Name_mode.t + val add_env_extension_from_level : t -> Typing_env_level.t diff --git a/middle_end/flambda2.0/types/flambda_type.mli b/middle_end/flambda2.0/types/flambda_type.mli index 9f7ca221bb06..0b83ec835744 100644 --- a/middle_end/flambda2.0/types/flambda_type.mli +++ b/middle_end/flambda2.0/types/flambda_type.mli @@ -116,6 +116,8 @@ module Typing_env : sig -> bound_to:Simple.t -> Flambda_primitive.Eligible_for_cse.t option + val find_name_mode : t -> Name.t -> Name_mode.t + val add_env_extension : t -> env_extension:Typing_env_extension.t From 19904d592dda46377c0b16f963cd6f37f63aa7ef Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 12:58:47 +0000 Subject: [PATCH 48/80] Improve printing of Let_symbol --- middle_end/flambda2.0/terms/let_symbol_expr.rec.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index f7b942b7e543..ca30125d2f1f 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -235,7 +235,11 @@ let print_flattened_descr_lhs ppf descr = | Code (code_id, _) -> Code_id.print ppf code_id | Set_of_closures (closure_symbols, _) -> Format.fprintf ppf "@[%a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space + (Format.pp_print_list + ~pp_sep:(fun ppf () -> + Format.fprintf ppf "@<0>%s,@ @<0>%s" + (Flambda_colours.elide ()) + (Flambda_colours.normal ())) print_closure_binding) (Closure_id.Map.bindings closure_symbols) | Other (symbol, _) -> Symbol.print ppf symbol From 53c40d3741fe8d1ebb9d99df752e24fd165b4397 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 13:04:24 +0000 Subject: [PATCH 49/80] Remove [Closure_element] This should stop confusing type errors between Closure_id.t and Var_within_closure.t. It also enables separate colouring for closure IDs and closure vars. --- .../flambda2.0/basic/closure_element.ml | 91 ------------------- .../flambda2.0/basic/closure_element.mli | 34 ------- middle_end/flambda2.0/basic/closure_id.ml | 71 ++++++++++++++- middle_end/flambda2.0/basic/closure_id.mli | 15 ++- .../flambda2.0/basic/var_within_closure.ml | 71 ++++++++++++++- .../flambda2.0/basic/var_within_closure.mli | 13 ++- .../compilenv_deps/flambda_colours.ml | 3 + .../compilenv_deps/flambda_colours.mli | 3 + 8 files changed, 169 insertions(+), 132 deletions(-) delete mode 100644 middle_end/flambda2.0/basic/closure_element.ml delete mode 100644 middle_end/flambda2.0/basic/closure_element.mli diff --git a/middle_end/flambda2.0/basic/closure_element.ml b/middle_end/flambda2.0/basic/closure_element.ml deleted file mode 100644 index e793e603f77c..000000000000 --- a/middle_end/flambda2.0/basic/closure_element.ml +++ /dev/null @@ -1,91 +0,0 @@ -(**************************************************************************) -(* *) -(* 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"] - -(* CR mshinwell: Delete things we don't need and review this whole thing. - And Variable. *) - -type t = { - compilation_unit : Compilation_unit.t; - name : string; - name_stamp : int; - (** [name_stamp]s are unique within any given compilation unit. *) -} - -module Self = Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - if t1 == t2 then 0 - else - let c = t1.name_stamp - t2.name_stamp in - if c <> 0 then c - else Compilation_unit.compare t1.compilation_unit t2.compilation_unit - - let equal t1 t2 = (compare t1 t2 = 0) - - let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) - - let print ppf t = - Format.fprintf ppf "@<0>%s" (Flambda_colours.closure_element ()); - if Compilation_unit.equal t.compilation_unit - (Compilation_unit.get_current_exn ()) - then begin - Format.fprintf ppf "%s/%d" - t.name t.name_stamp - end else begin - Format.fprintf ppf "%a.%s/%d" - Compilation_unit.print t.compilation_unit - t.name t.name_stamp - end; - Format.fprintf ppf "@<0>%s" (Flambda_colours.normal ()) - - let output chan t = - print (Format.formatter_of_out_channel chan) t -end) - -include Self - -let next_stamp = ref 0 - -let get_next_stamp () = - let stamp = !next_stamp in - incr next_stamp; - stamp - -let in_compilation_unit t cu = - Compilation_unit.equal cu t.compilation_unit - -let get_compilation_unit t = t.compilation_unit - -let to_string t = - t.name ^ "_" ^ (string_of_int t.name_stamp) - -let rename t = - { t with - name_stamp = get_next_stamp (); - } - -let unwrap t = - Variable.create ~current_compilation_unit:t.compilation_unit - (to_string t) - -let wrap compilation_unit var = - { compilation_unit; - name = Variable.raw_name var; - name_stamp = get_next_stamp (); - } diff --git a/middle_end/flambda2.0/basic/closure_element.mli b/middle_end/flambda2.0/basic/closure_element.mli deleted file mode 100644 index 40f0608a514b..000000000000 --- a/middle_end/flambda2.0/basic/closure_element.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* 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"] - -include Identifiable.S - -(* CR mshinwell for pchambart: These should be deleted, right? - Hmm, except that in e.g. Flambda.make_closure_declaration we still have - uses *) - -val wrap : Compilation_unit.t -> Variable.t -> t - -val unwrap : t -> Variable.t - -val in_compilation_unit : t -> Compilation_unit.t -> bool -val get_compilation_unit : t -> Compilation_unit.t - -val to_string : t -> string - -val rename : t -> t diff --git a/middle_end/flambda2.0/basic/closure_id.ml b/middle_end/flambda2.0/basic/closure_id.ml index 4003a6095b39..a22cf8d6ceef 100644 --- a/middle_end/flambda2.0/basic/closure_id.ml +++ b/middle_end/flambda2.0/basic/closure_id.ml @@ -16,4 +16,73 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] -include Closure_element +type t = { + compilation_unit : Compilation_unit.t; + name : string; + name_stamp : int; + (** [name_stamp]s are unique within any given compilation unit. *) +} + +module Self = Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + if t1 == t2 then 0 + else + let c = t1.name_stamp - t2.name_stamp in + if c <> 0 then c + else Compilation_unit.compare t1.compilation_unit t2.compilation_unit + + let equal t1 t2 = (compare t1 t2 = 0) + + let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) + + let print ppf t = + Format.fprintf ppf "@<0>%s" (Flambda_colours.closure_element ()); + if Compilation_unit.equal t.compilation_unit + (Compilation_unit.get_current_exn ()) + then begin + Format.fprintf ppf "%s/%d" + t.name t.name_stamp + end else begin + Format.fprintf ppf "%a.%s/%d" + Compilation_unit.print t.compilation_unit + t.name t.name_stamp + end; + Format.fprintf ppf "@<0>%s" (Flambda_colours.normal ()) + + let output chan t = + print (Format.formatter_of_out_channel chan) t +end) + +include Self + +let next_stamp = ref 0 + +let get_next_stamp () = + let stamp = !next_stamp in + incr next_stamp; + stamp + +let in_compilation_unit t cu = + Compilation_unit.equal cu t.compilation_unit + +let get_compilation_unit t = t.compilation_unit + +let to_string t = + t.name ^ "_" ^ (string_of_int t.name_stamp) + +let rename t = + { t with + name_stamp = get_next_stamp (); + } + +let unwrap t = + Variable.create ~current_compilation_unit:t.compilation_unit + (to_string t) + +let wrap compilation_unit var = + { compilation_unit; + name = Variable.raw_name var; + name_stamp = get_next_stamp (); + } diff --git a/middle_end/flambda2.0/basic/closure_id.mli b/middle_end/flambda2.0/basic/closure_id.mli index 5475fa507b9e..d6bc7c5cc037 100644 --- a/middle_end/flambda2.0/basic/closure_id.mli +++ b/middle_end/flambda2.0/basic/closure_id.mli @@ -25,8 +25,15 @@ unit), that identifies a closure within a particular set of closures (viz. [Project_closure]). *) -include module type of Closure_element +include Identifiable.S -(* CR mshinwell: Fix the problem that Closure_id and Var_within_closure seem - to be being used interchangeably by the type checker---presumably they are - actually equal?? *) +val wrap : Compilation_unit.t -> Variable.t -> t + +val unwrap : t -> Variable.t + +val in_compilation_unit : t -> Compilation_unit.t -> bool +val get_compilation_unit : t -> Compilation_unit.t + +val to_string : t -> string + +val rename : t -> t diff --git a/middle_end/flambda2.0/basic/var_within_closure.ml b/middle_end/flambda2.0/basic/var_within_closure.ml index 4003a6095b39..0137251dce49 100644 --- a/middle_end/flambda2.0/basic/var_within_closure.ml +++ b/middle_end/flambda2.0/basic/var_within_closure.ml @@ -16,4 +16,73 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] -include Closure_element +type t = { + compilation_unit : Compilation_unit.t; + name : string; + name_stamp : int; + (** [name_stamp]s are unique within any given compilation unit. *) +} + +module Self = Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + if t1 == t2 then 0 + else + let c = t1.name_stamp - t2.name_stamp in + if c <> 0 then c + else Compilation_unit.compare t1.compilation_unit t2.compilation_unit + + let equal t1 t2 = (compare t1 t2 = 0) + + let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) + + let print ppf t = + Format.fprintf ppf "@<0>%s" (Flambda_colours.closure_var ()); + if Compilation_unit.equal t.compilation_unit + (Compilation_unit.get_current_exn ()) + then begin + Format.fprintf ppf "%s/%d" + t.name t.name_stamp + end else begin + Format.fprintf ppf "%a.%s/%d" + Compilation_unit.print t.compilation_unit + t.name t.name_stamp + end; + Format.fprintf ppf "@<0>%s" (Flambda_colours.normal ()) + + let output chan t = + print (Format.formatter_of_out_channel chan) t +end) + +include Self + +let next_stamp = ref 0 + +let get_next_stamp () = + let stamp = !next_stamp in + incr next_stamp; + stamp + +let in_compilation_unit t cu = + Compilation_unit.equal cu t.compilation_unit + +let get_compilation_unit t = t.compilation_unit + +let to_string t = + t.name ^ "_" ^ (string_of_int t.name_stamp) + +let rename t = + { t with + name_stamp = get_next_stamp (); + } + +let unwrap t = + Variable.create ~current_compilation_unit:t.compilation_unit + (to_string t) + +let wrap compilation_unit var = + { compilation_unit; + name = Variable.raw_name var; + name_stamp = get_next_stamp (); + } diff --git a/middle_end/flambda2.0/basic/var_within_closure.mli b/middle_end/flambda2.0/basic/var_within_closure.mli index 56f0af0ad6ff..33c38cfa3455 100644 --- a/middle_end/flambda2.0/basic/var_within_closure.mli +++ b/middle_end/flambda2.0/basic/var_within_closure.mli @@ -21,4 +21,15 @@ [Project_var], and not [Var], nodes are tagged with these identifiers. *) -include module type of Closure_element +include Identifiable.S + +val wrap : Compilation_unit.t -> Variable.t -> t + +val unwrap : t -> Variable.t + +val in_compilation_unit : t -> Compilation_unit.t -> bool +val get_compilation_unit : t -> Compilation_unit.t + +val to_string : t -> string + +val rename : t -> t diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml index dec56e27615b..6c945e4efc01 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.ml @@ -37,7 +37,10 @@ let name () = C.fg_256 111 let parameter () = C.fg_256 198 let symbol () = C.fg_256 98 let variable () = C.fg_256 111 + let closure_element () = C.fg_256 31 +let closure_var () = C.fg_256 43 + let code_id () = C.fg_256 169 let expr_keyword () = C.fg_256 51 diff --git a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli index 70d7d107ef8e..14ae1e01de8c 100644 --- a/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli +++ b/middle_end/flambda2.0/compilenv_deps/flambda_colours.mli @@ -35,7 +35,10 @@ val name : unit -> string val parameter : unit -> string val symbol : unit -> string val variable : unit -> string + val closure_element : unit -> string +val closure_var : unit -> string + val code_id : unit -> string val expr_keyword : unit -> string From 238e139a7a29f3c78b8b44c29adcb20920bc3a70 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 13:09:06 +0000 Subject: [PATCH 50/80] Improve printing of Let_symbol --- middle_end/flambda2.0/naming/bindable_let_bound.ml | 2 +- middle_end/flambda2.0/terms/let_symbol_expr.rec.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/middle_end/flambda2.0/naming/bindable_let_bound.ml b/middle_end/flambda2.0/naming/bindable_let_bound.ml index 4069bde95b1c..6d8f518aa16d 100644 --- a/middle_end/flambda2.0/naming/bindable_let_bound.ml +++ b/middle_end/flambda2.0/naming/bindable_let_bound.ml @@ -25,7 +25,7 @@ include Identifiable.Make (struct type nonrec t = t let print_closure_binding ppf (closure_id, var) = - Format.fprintf ppf "@[%a @<0>%s\u{21a6}@<0>%s %a@]" + Format.fprintf ppf "@[%a @<0>%s\u{21a4}@<0>%s %a@]" Var_in_binding_pos.print var (Flambda_colours.elide ()) (Flambda_colours.elide ()) diff --git a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml index ca30125d2f1f..fba2e45f8d15 100644 --- a/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml +++ b/middle_end/flambda2.0/terms/let_symbol_expr.rec.ml @@ -26,7 +26,7 @@ module Bound_symbols = struct (* CR mshinwell: Share with [Bindable_let_bound] and below *) let print_closure_binding ppf (closure_id, sym) = - Format.fprintf ppf "@[%a @<0>%s\u{21a6}@<0>%s %a@]" + Format.fprintf ppf "@[%a @<0>%s\u{21a4}@<0>%s %a@]" Symbol.print sym (Flambda_colours.elide ()) (Flambda_colours.elide ()) @@ -224,7 +224,7 @@ let flatten_for_printing { bound_symbols; defining_expr; _ } = (List.rev flattened) @ (List.rev flattened') let print_closure_binding ppf (closure_id, sym) = - Format.fprintf ppf "@[%a @<0>%s\u{21a6}@<0>%s %a@]" + Format.fprintf ppf "@[%a @<0>%s\u{21a4}@<0>%s %a@]" Symbol.print sym (Flambda_colours.elide ()) (Flambda_colours.elide ()) From 7f3bac65913e22fb1b3abba3492189e21d48747f Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 13:13:05 +0000 Subject: [PATCH 51/80] Revert a9950c411a02e3710efa9150f636278db50ca42b --- .../inlining/inlining_transforms.ml | 5 +- .../flambda2.0/simplify/env/downwards_acc.ml | 3 -- .../flambda2.0/simplify/env/downwards_acc.mli | 2 - .../flambda2.0/simplify/simplify_common.ml | 6 +-- .../flambda2.0/simplify/simplify_common.mli | 3 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 10 ++-- .../flambda2.0/terms/apply_cont_expr.ml | 5 +- middle_end/flambda2.0/terms/expr.rec.ml | 47 +++++++++++-------- middle_end/flambda2.0/terms/expr.rec.mli | 9 ++-- middle_end/flambda2.0/terms/flambda.mli | 9 ++-- .../flambda2.0/types/env/typing_env.rec.ml | 2 - .../flambda2.0/types/env/typing_env.rec.mli | 2 - middle_end/flambda2.0/types/flambda_type.mli | 2 - 13 files changed, 42 insertions(+), 63 deletions(-) diff --git a/middle_end/flambda2.0/inlining/inlining_transforms.ml b/middle_end/flambda2.0/inlining/inlining_transforms.ml index 3ffb83028967..652c5ee5a0a5 100644 --- a/middle_end/flambda2.0/inlining/inlining_transforms.ml +++ b/middle_end/flambda2.0/inlining/inlining_transforms.ml @@ -79,10 +79,7 @@ let inline dacc ~callee ~args function_decl apply_exn_continuation in Expr.apply_name_permutation - (Expr.bind_parameters_to_simples - ~name_mode_of_var: - (fun var -> DA.find_name_mode dacc (Name.var var)) - ~bind:params ~target:args + (Expr.bind_parameters_to_simples ~bind:params ~target:args (Expr.create_let (VB.create my_closure Name_mode.normal) (Named.create_simple callee) diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.ml b/middle_end/flambda2.0/simplify/env/downwards_acc.ml index 0ee4f71ba84c..45f78d48c3db 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.ml +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.ml @@ -106,6 +106,3 @@ let with_code_age_relation t code_age_relation = TE.with_code_age_relation (DE.typing_env (denv t)) code_age_relation in with_denv t (DE.with_typing_env (denv t) typing_env) - -let find_name_mode t name = - TE.find_name_mode (DE.typing_env (denv t)) name diff --git a/middle_end/flambda2.0/simplify/env/downwards_acc.mli b/middle_end/flambda2.0/simplify/env/downwards_acc.mli index 0a096e781461..a9d4bc5e3034 100644 --- a/middle_end/flambda2.0/simplify/env/downwards_acc.mli +++ b/middle_end/flambda2.0/simplify/env/downwards_acc.mli @@ -69,5 +69,3 @@ val continuation_uses_env : t -> Continuation_uses_env.t val code_age_relation : t -> Code_age_relation.t val with_code_age_relation : t -> Code_age_relation.t -> t - -val find_name_mode : t -> Name.t -> Name_mode.t diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 1d76c116f053..08beefe6e159 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -144,8 +144,7 @@ let update_exn_continuation_extra_args uacc ~exn_cont_use_id apply = (* CR mshinwell: Should probably move [Reachable] into the [Flambda] recursive loop and then move this into [Expr]. Maybe this could be tidied up a bit too? *) -let bind_let_bound dacc ~bindings ~body = - let name_mode_of_var var = DA.find_name_mode dacc (Name.var var) in +let bind_let_bound ~bindings ~body = List.fold_left (fun expr ((bound : Bindable_let_bound.t), (defining_expr : Reachable.t)) -> @@ -153,8 +152,7 @@ let bind_let_bound dacc ~bindings ~body = | Invalid _ -> Expr.create_invalid () | Reachable defining_expr -> match bound with - | Singleton var -> - Expr.bind ~name_mode_of_var ~bindings:[var, defining_expr] ~body:expr + | Singleton var -> Expr.bind ~bindings:[var, defining_expr] ~body:expr | Set_of_closures _ -> Expr.create_pattern_let bound defining_expr expr) body (List.rev bindings) diff --git a/middle_end/flambda2.0/simplify/simplify_common.mli b/middle_end/flambda2.0/simplify/simplify_common.mli index 5d5af3b2c26f..814116be0047 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.mli +++ b/middle_end/flambda2.0/simplify/simplify_common.mli @@ -70,8 +70,7 @@ val update_exn_continuation_extra_args -> Apply_expr.t val bind_let_bound - : Downwards_acc.t - -> bindings:((Bindable_let_bound.t * Reachable.t) list) + : bindings:((Bindable_let_bound.t * Reachable.t) list) -> body:Flambda.Expr.t -> Flambda.Expr.t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 58a24455852a..13d0bbefd797 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -37,7 +37,7 @@ let rec simplify_let Simplify_named.simplify_named dacc ~bound_vars (L.defining_expr let_expr) in let body, user_data, uacc = simplify_expr dacc body k in - Simplify_common.bind_let_bound dacc ~bindings ~body, user_data, uacc) + Simplify_common.bind_let_bound ~bindings ~body, user_data, uacc) and simplify_let_symbol : 'a. DA.t -> Let_symbol.t -> 'a k -> Expr.t * 'a * UA.t @@ -1303,10 +1303,7 @@ Format.eprintf "Apply_cont is now %a\n%!" Expr.print apply_cont_expr; (List.combine params args) in let expr = - Expr.bind_parameters - ~name_mode_of_var:(fun _var -> Name_mode.normal) - (* All parameters and arguments must have [Normal] mode. *) - ~bindings:params_and_args ~body:handler + Expr.bind_parameters ~bindings:params_and_args ~body:handler in expr, user_data, uacc) @@ -1458,8 +1455,7 @@ and simplify_switch Simplify_named.simplify_named dacc ~bound_vars named in let body = k ~tagged_scrutinee:(Simple.var bound_to) in - let body = Simplify_common.bind_let_bound dacc ~bindings ~body in - body, user_data, uacc + Simplify_common.bind_let_bound ~bindings ~body, user_data, uacc in let body, user_data, uacc = match switch_is_identity with diff --git a/middle_end/flambda2.0/terms/apply_cont_expr.ml b/middle_end/flambda2.0/terms/apply_cont_expr.ml index d17c0eeff1f8..95f339e6c7f1 100644 --- a/middle_end/flambda2.0/terms/apply_cont_expr.ml +++ b/middle_end/flambda2.0/terms/apply_cont_expr.ml @@ -70,10 +70,7 @@ let print ppf { k; args; trap_action; dbg; } = | args -> Format.fprintf ppf " %a" Simple.List.print args end; - Format.fprintf ppf "@<0>%s%a@<0>%s" - (Flambda_colours.elide ()) - Debuginfo.print_or_elide dbg - (Flambda_colours.normal ()); + Format.fprintf ppf "%a" Debuginfo.print_or_elide dbg; Format.fprintf ppf "@]" let print_with_cache ~cache:_ ppf t = print ppf t diff --git a/middle_end/flambda2.0/terms/expr.rec.ml b/middle_end/flambda2.0/terms/expr.rec.ml index 87ac17eae6f6..62f2e205827b 100644 --- a/middle_end/flambda2.0/terms/expr.rec.ml +++ b/middle_end/flambda2.0/terms/expr.rec.ml @@ -389,29 +389,38 @@ let create_if_then_else ~scrutinee ~if_true ~if_false = in create_switch ~scrutinee ~arms -let bind ~name_mode_of_var ~bindings ~body = +let bind ~bindings ~body = List.fold_left (fun expr (var, (target : Named.t)) -> - let var_name_mode = Var_in_binding_pos.name_mode var in +(* match target with | Simple simple -> - begin match Simple.must_be_var simple with - (* This isn't guaranteed to delete the [Let] (it won't in the case - where [rhs_var] appears in [body]), but will in many cases, and - helps with legibility of terms. *) - | Some rhs_var - when Name_mode.equal (name_mode_of_var rhs_var) var_name_mode -> - let perm = - Name_permutation.add_variable Name_permutation.empty - (Var_in_binding_pos.var var) rhs_var - in - create_let var target (apply_name_permutation expr perm) - | Some _ | None -> create_let var target expr + begin match Simple.descr simple with + | Name (Var rhs_var) -> + begin match Simple.rec_info simple with + | None -> + let perm = + Can't do this unless the name modes match! + Name_permutation.add_variable Name_permutation.empty + (Var_in_binding_pos.var var) rhs_var + in + (* CR mshinwell: Think more about this. + This is still leaving some let-bindings behind when it + shouldn't need to, e.g. + let bar = foo in + switch foo ... + seems to be turning into + let bar = foo in + switch bar *) + create_let var target (apply_name_permutation expr perm) + | Some _ -> create_let var target expr + end + | _ -> create_let var target expr end - | Prim _ | Set_of_closures _ -> create_let var target expr) + | _ -> *) create_let var target expr) body (List.rev bindings) -let bind_parameters ~name_mode_of_var ~bindings ~body = +let bind_parameters ~bindings ~body = let bindings = List.map (fun (bind, target) -> let var = @@ -420,9 +429,9 @@ let bind_parameters ~name_mode_of_var ~bindings ~body = var, target) bindings in - bind ~name_mode_of_var ~bindings ~body + bind ~bindings ~body -let bind_parameters_to_simples ~name_mode_of_var ~bind ~target body = +let bind_parameters_to_simples ~bind ~target body = if List.compare_lengths bind target <> 0 then begin Misc.fatal_errorf "Mismatching parameters and arguments: %a and %a" KP.List.print bind @@ -432,4 +441,4 @@ let bind_parameters_to_simples ~name_mode_of_var ~bind ~target body = List.map (fun (bind, target) -> bind, Named.create_simple target) (List.combine bind target) in - bind_parameters ~name_mode_of_var ~bindings ~body + bind_parameters ~bindings ~body diff --git a/middle_end/flambda2.0/terms/expr.rec.mli b/middle_end/flambda2.0/terms/expr.rec.mli index cd9667f77c8a..a62aa97668e0 100644 --- a/middle_end/flambda2.0/terms/expr.rec.mli +++ b/middle_end/flambda2.0/terms/expr.rec.mli @@ -113,14 +113,12 @@ val create_invalid : unit -> t [Immutable] [Let] expressions the given [(var, expr)] pairs around the body. *) val bind - : name_mode_of_var:(Variable.t -> Name_mode.t) - -> bindings:(Var_in_binding_pos.t * Named.t) list + : bindings:(Var_in_binding_pos.t * Named.t) list -> body:t -> t val bind_parameters - : name_mode_of_var:(Variable.t -> Name_mode.t) - -> bindings:(Kinded_parameter.t * Named.t) list + : bindings:(Kinded_parameter.t * Named.t) list -> body:t -> t @@ -129,8 +127,7 @@ val bind_parameters expression with bindings of each [p_i] to the corresponding [s_i], such as is typically used when performing an inlining transformation. *) val bind_parameters_to_simples - : name_mode_of_var:(Variable.t -> Name_mode.t) - -> bind:Kinded_parameter.t list + : bind:Kinded_parameter.t list -> target:Simple.t list -> t -> t diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index c28f7fee72de..e6a1599608f0 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -134,14 +134,12 @@ module rec Expr : sig [Immutable] [Let] expressions the given [(var, expr)] pairs around the body. *) val bind - : name_mode_of_var:(Variable.t -> Name_mode.t) - -> bindings:(Var_in_binding_pos.t * Named.t) list + : bindings:(Var_in_binding_pos.t * Named.t) list -> body:t -> t val bind_parameters - : name_mode_of_var:(Variable.t -> Name_mode.t) - -> bindings:(Kinded_parameter.t * Named.t) list + : bindings:(Kinded_parameter.t * Named.t) list -> body:t -> t @@ -150,8 +148,7 @@ module rec Expr : sig expression with bindings of each [p_i] to the corresponding [s_i], such as is typically used when performing an inlining transformation. *) val bind_parameters_to_simples - : name_mode_of_var:(Variable.t -> Name_mode.t) - -> bind:Kinded_parameter.t list + : bind:Kinded_parameter.t list -> target:Simple.t list -> t -> t diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.ml b/middle_end/flambda2.0/types/env/typing_env.rec.ml index 3398eb19ac4f..3271bfb12545 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.ml +++ b/middle_end/flambda2.0/types/env/typing_env.rec.ml @@ -716,8 +716,6 @@ let find_cse_rev t ~bound_to = | exception Not_found -> None | equation -> Some equation -let find_name_mode t name = snd (find_with_name_mode t name) - let meet_equation t name ty = let existing_ty = find t name in Format.eprintf "For %a, new type is %a, existing type %a\n%!" diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.mli b/middle_end/flambda2.0/types/env/typing_env.rec.mli index 98db991b4889..afb9cbdd797a 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.mli +++ b/middle_end/flambda2.0/types/env/typing_env.rec.mli @@ -80,8 +80,6 @@ val find_cse_rev -> bound_to:Simple.t -> Flambda_primitive.Eligible_for_cse.t option -val find_name_mode : t -> Name.t -> Name_mode.t - val add_env_extension_from_level : t -> Typing_env_level.t diff --git a/middle_end/flambda2.0/types/flambda_type.mli b/middle_end/flambda2.0/types/flambda_type.mli index 0b83ec835744..9f7ca221bb06 100644 --- a/middle_end/flambda2.0/types/flambda_type.mli +++ b/middle_end/flambda2.0/types/flambda_type.mli @@ -116,8 +116,6 @@ module Typing_env : sig -> bound_to:Simple.t -> Flambda_primitive.Eligible_for_cse.t option - val find_name_mode : t -> Name.t -> Name_mode.t - val add_env_extension : t -> env_extension:Typing_env_extension.t From b5eb4873bb9d6f8b187e46bd8a6573c6afd7e47b Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 13:58:40 +0000 Subject: [PATCH 52/80] Constant sharing --- flambdatest/mlexamples/tests.ml | 2 +- flambdatest/mlexamples/tests4.ml | 7 + .../from_lambda/closure_conversion.ml | 29 +- middle_end/flambda2.0/lifting/reification.ml | 42 ++- .../lifting/reify_continuation_param_types.ml | 50 ++- .../simplify/env/simplify_env_and_result.ml | 18 +- .../env/simplify_env_and_result_intf.ml | 6 + .../flambda2.0/simplify/simplify_expr.rec.ml | 7 + middle_end/flambda2.0/terms/flambda.mli | 6 +- .../flambda2.0/terms/static_const.rec.ml | 340 +++++++++++------- .../flambda2.0/terms/static_const.rec.mli | 6 +- 11 files changed, 336 insertions(+), 177 deletions(-) diff --git a/flambdatest/mlexamples/tests.ml b/flambdatest/mlexamples/tests.ml index cba67b8ce3e3..3f7cd16b0323 100644 --- a/flambdatest/mlexamples/tests.ml +++ b/flambdatest/mlexamples/tests.ml @@ -118,4 +118,4 @@ let foo3 arr f i = let f c m n x' y' = let x = if c < 0 then x' else x' + 10 in let y = if c < 0 then y' else y' + 20 in - x + y + x + y, 2L diff --git a/flambdatest/mlexamples/tests4.ml b/flambdatest/mlexamples/tests4.ml index 00ea09ace1de..fb14bf53a2a5 100644 --- a/flambdatest/mlexamples/tests4.ml +++ b/flambdatest/mlexamples/tests4.ml @@ -52,6 +52,13 @@ let pr2162_1 z x y = float_of_int a -. b *) +let pr2162_2_first z x y = + let a, b = + if z then (x * 2, y *. 3.) + else (x, y +. 0.) + in + float_of_int a -. b + let pr2162_2 z x y = let a, b = if z then (x * 2, y *. 3.) diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index 082e1d918dbf..421ab28a4dba 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -40,6 +40,7 @@ type t = { mutable imported_symbols : Symbol.Set.t; (* All symbols in [imported_symbols] are to be of kind [Value]. *) mutable declared_symbols : (Symbol.t * Static_const.t) list; + mutable shareable_constants : Symbol.t Static_const.Map.t; mutable code : (Code_id.t * Function_params_and_body.t) list; } @@ -148,16 +149,23 @@ let tupled_function_call_stub func_decl, code_id, params_and_body let register_const0 t constant name = - let current_compilation_unit = Compilation_unit.get_current_exn () in - (* Create a variable to ensure uniqueness of the symbol. *) - let var = Variable.create ~current_compilation_unit name in - let symbol = - Symbol.create (Compilation_unit.get_current_exn ()) - (Linkage_name.create - (Variable.unique_name (Variable.rename var))) - in - t.declared_symbols <- (symbol, constant) :: t.declared_symbols; - symbol + match Static_const.Map.find constant t.shareable_constants with + | exception Not_found -> + let current_compilation_unit = Compilation_unit.get_current_exn () in + (* Create a variable to ensure uniqueness of the symbol. *) + let var = Variable.create ~current_compilation_unit name in + let symbol = + Symbol.create (Compilation_unit.get_current_exn ()) + (Linkage_name.create + (Variable.unique_name (Variable.rename var))) + in + t.declared_symbols <- (symbol, constant) :: t.declared_symbols; + if Static_const.can_share constant then begin + t.shareable_constants + <- Static_const.Map.add constant symbol t.shareable_constants + end; + symbol + | symbol -> symbol let register_const t constant name : Static_const.Field_of_block.t * string = let symbol = register_const0 t constant name in @@ -851,6 +859,7 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words filename; imported_symbols = Symbol.Set.empty; declared_symbols = []; + shareable_constants = Static_const.Map.empty; code = []; } in diff --git a/middle_end/flambda2.0/lifting/reification.ml b/middle_end/flambda2.0/lifting/reification.ml index ae3b154cfe14..e939133803f1 100644 --- a/middle_end/flambda2.0/lifting/reification.ml +++ b/middle_end/flambda2.0/lifting/reification.ml @@ -37,27 +37,39 @@ let create_static_const (to_lift : T.to_lift) : Static_const.t = | Boxed_nativeint i -> Boxed_nativeint (Const i) let lift dacc ty ~bound_to static_const = - let symbol = - Symbol.create (Compilation_unit.get_current_exn ()) - (Linkage_name.create (Variable.unique_name bound_to)) - in - if not (K.equal (T.kind ty) K.value) then begin - Misc.fatal_errorf "Cannot lift non-[Value] variable: %a" - Variable.print bound_to - end; - let dacc = - DA.map_r dacc ~f:(fun r -> - Lifted_constant.create (DA.denv dacc) - (Singleton symbol) static_const - ~types_of_symbols:(Symbol.Map.singleton symbol ty) - |> R.new_lifted_constant r) + let dacc, symbol = + match R.find_shareable_constant (DA.r dacc) static_const with + | Some symbol -> dacc, symbol + | None -> + let symbol = + Symbol.create (Compilation_unit.get_current_exn ()) + (Linkage_name.create (Variable.unique_name bound_to)) + in + if not (K.equal (T.kind ty) K.value) then begin + Misc.fatal_errorf "Cannot lift non-[Value] variable: %a" + Variable.print bound_to + end; + let dacc = + DA.map_r dacc ~f:(fun r -> + Lifted_constant.create (DA.denv dacc) + (Singleton symbol) static_const + ~types_of_symbols:(Symbol.Map.singleton symbol ty) + |> R.new_lifted_constant r) + in + let dacc = + DA.map_r dacc ~f:(fun r -> + R.consider_constant_for_sharing r symbol static_const) + in + let dacc = + DA.map_denv dacc ~f:(fun denv -> DE.add_symbol denv symbol ty) + in + dacc, symbol in let symbol' = Simple.symbol symbol in let term = Named.create_simple symbol' in let var_ty = T.alias_type_of (T.kind ty) symbol' in let dacc = DA.map_denv dacc ~f:(fun denv -> - let denv = DE.add_symbol denv symbol ty in DE.add_equation_on_variable denv bound_to var_ty) in Reachable.reachable term, dacc, var_ty diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index 5701425f2c14..4f6983b4ef6a 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -22,25 +22,37 @@ let lift_non_closure_discovered_via_reified_continuation_param_types dacc var to_lift ~reified_continuation_params_to_symbols ~reified_definitions ~closure_symbols_by_set = let static_const = Reification.create_static_const to_lift in - let symbol = - Symbol.create (Compilation_unit.get_current_exn ()) - (Linkage_name.create (Variable.unique_name var)) - in - let dacc = - DA.map_denv dacc ~f:(fun denv -> - DE.add_equation_on_name (DE.define_symbol denv symbol K.value) - (Name.var var) - (T.alias_type_of K.value (Simple.symbol symbol))) - in - let reified_definitions = - (Let_symbol.Bound_symbols.Singleton symbol, static_const) - :: reified_definitions - in - let reified_continuation_params_to_symbols = - Variable.Map.add var symbol reified_continuation_params_to_symbols - in - dacc, reified_continuation_params_to_symbols, reified_definitions, - closure_symbols_by_set + match R.find_shareable_constant (DA.r dacc) static_const with + | Some symbol -> + let reified_continuation_params_to_symbols = + Variable.Map.add var symbol reified_continuation_params_to_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set + | None -> + let symbol = + Symbol.create (Compilation_unit.get_current_exn ()) + (Linkage_name.create (Variable.unique_name var)) + in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + DE.add_equation_on_name (DE.define_symbol denv symbol K.value) + (Name.var var) + (T.alias_type_of K.value (Simple.symbol symbol))) + in + let dacc = + DA.map_r dacc ~f:(fun r -> + R.consider_constant_for_sharing r symbol static_const) + in + let reified_definitions = + (Let_symbol.Bound_symbols.Singleton symbol, static_const) + :: reified_definitions + in + let reified_continuation_params_to_symbols = + Variable.Map.add var symbol reified_continuation_params_to_symbols + in + dacc, reified_continuation_params_to_symbols, reified_definitions, + closure_symbols_by_set let lift_set_of_closures_discovered_via_reified_continuation_param_types dacc var closure_id function_decls ~closure_vars diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 3a6a0b64e584..6539b952eac1 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -630,23 +630,28 @@ end = struct { resolver : (Export_id.t -> Flambda_type.t option); imported_symbols : Flambda_kind.t Symbol.Map.t; lifted_constants_innermost_last : Lifted_constant.t list; + shareable_constants : Symbol.t Static_const.Map.t; } let print ppf { resolver = _; imported_symbols; lifted_constants_innermost_last; + shareable_constants; } = Format.fprintf ppf "@[(\ @[(imported_symbols@ %a)@]@ \ - @[(lifted_constants_innermost_last@ %a)@]\ + @[(lifted_constants_innermost_last@ %a)@]@ \ + @[(shareable_constants@ %a)@]\ )@]" (Symbol.Map.print Flambda_kind.print) imported_symbols (Format.pp_print_list ~pp_sep:Format.pp_print_space Lifted_constant.print) lifted_constants_innermost_last + (Static_const.Map.print Symbol.print) shareable_constants let create ~resolver = { resolver; imported_symbols = Symbol.Map.empty; lifted_constants_innermost_last = []; + shareable_constants = Static_const.Map.empty; } let imported_symbols t = t.imported_symbols @@ -666,6 +671,17 @@ end = struct { t with lifted_constants_innermost_last = []; } + + let find_shareable_constant t static_const = + Static_const.Map.find_opt static_const t.shareable_constants + + let consider_constant_for_sharing t symbol static_const = + if not (Static_const.can_share static_const) then t + else + { t with + shareable_constants = + Static_const.Map.add static_const symbol t.shareable_constants; + } end and Lifted_constant : sig include Simplify_env_and_result_intf.Lifted_constant with type downwards_env := Downwards_env.t diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index c58eef4533f3..f8069bd02ede 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -273,6 +273,12 @@ module type Result = sig val set_lifted_constants : t -> lifted_constant list -> t + (* CR mshinwell: This whole lifted/shareable constant interface probably + still needs some work *) + val find_shareable_constant : t -> Static_const.t -> Symbol.t option + + val consider_constant_for_sharing : t -> Symbol.t -> Static_const.t -> t + val imported_symbols : t -> Flambda_kind.t Symbol.Map.t val clear_lifted_constants : t -> t diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 13d0bbefd797..60632ab0edec 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -91,6 +91,13 @@ and simplify_let_symbol defining denv) in + let dacc = + match bound_symbols with + | Singleton symbol -> + DA.map_r dacc ~f:(fun r -> + R.consider_constant_for_sharing r symbol defining_expr) + | Code_and_set_of_closures _ -> dacc + in let body, user_data, uacc = simplify_expr dacc body k in let lifted_constants = R.get_lifted_constants (UA.r uacc) in let uacc = diff --git a/middle_end/flambda2.0/terms/flambda.mli b/middle_end/flambda2.0/terms/flambda.mli index e6a1599608f0..2e12aa43f285 100644 --- a/middle_end/flambda2.0/terms/flambda.mli +++ b/middle_end/flambda2.0/terms/flambda.mli @@ -537,9 +537,7 @@ end and Static_const : sig | Mutable_string of { initial_value : string; } | Immutable_string of string - (** Print a static structure definition to a formatter. *) - val print : Format.formatter -> t -> unit - + include Identifiable.S with type t := t include Contains_names.S with type t := t (** Return all pieces of code defined by the given term. *) @@ -553,6 +551,8 @@ end and Static_const : sig val is_fully_static : t -> bool val disjoint_union : t -> t -> t + + val can_share : t -> bool end module Function_declaration = Function_declaration diff --git a/middle_end/flambda2.0/terms/static_const.rec.ml b/middle_end/flambda2.0/terms/static_const.rec.ml index fbe3ee043ddd..0f3497969317 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.ml +++ b/middle_end/flambda2.0/terms/static_const.rec.ml @@ -94,7 +94,9 @@ type 'a or_variable = | Const of 'a | Var of Variable.t +(* CR mshinwell: Move to its own module *) type mutable_or_immutable = Mutable | Immutable +let compare_mutable_or_immutable mut1 mut2 = Stdlib.compare mut1 mut2 type code = { params_and_body : Function_params_and_body.t or_deleted; @@ -104,6 +106,27 @@ and 'a or_deleted = | Present of 'a | Deleted +let print_params_and_body_with_cache ~cache ppf params_and_body = + match params_and_body with + | Deleted -> Format.fprintf ppf "Deleted" + | Present params_and_body -> + Function_params_and_body.print_with_cache ~cache ppf + params_and_body + +let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = + Format.fprintf ppf "@[(\ + @[@<0>%s(newer_version_of@ %a)@<0>%s@]@ \ + %a\ + )@]" + (if Option.is_none newer_version_of then Flambda_colours.elide () + else Flambda_colours.normal ()) + (Misc.Stdlib.Option.print_compact Code_id.print) newer_version_of + (Flambda_colours.normal ()) + (print_params_and_body_with_cache ~cache) params_and_body + +let print_code ppf code = + print_code_with_cache ~cache:(Printing_cache.create ()) ppf code + type code_and_set_of_closures = { code : code Code_id.Map.t; set_of_closures : Set_of_closures.t option; @@ -120,6 +143,185 @@ type t = | Mutable_string of { initial_value : string; } | Immutable_string of string +include Identifiable.Make (struct + type nonrec t = t + + let print_with_cache ~cache ppf t = + let print_float_array_field ppf = function + | Const f -> fprintf ppf "%a" Numbers.Float_by_bit_pattern.print f + | Var v -> Variable.print ppf v + in + match t with + | Block (tag, mut, fields) -> + fprintf ppf "@[(@<0>%s%sblock@<0>%s (tag %a) (%a))@]" + (Flambda_colours.static_part ()) + (match mut with Immutable -> "Immutable_" | Mutable -> "Mutable_") + (Flambda_colours.normal ()) + Tag.Scannable.print tag + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Field_of_block.print) fields + | Code_and_set_of_closures { code; set_of_closures; } -> + if Option.is_none set_of_closures then + match Code_id.Map.get_singleton code with + | None -> + fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ + @[%a@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Code_id.Map.print (print_code_with_cache ~cache)) code + | Some (_code_id, code) -> + fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ + @[%a@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (print_code_with_cache ~cache) code + else + fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ + @[(code@ (%a))@]@ \ + @[(set_of_closures@ (%a))@]\ + ))@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Code_id.Map.print (print_code_with_cache ~cache)) code + (Misc.Stdlib.Option.print + (Set_of_closures.print_with_cache ~cache)) + set_of_closures + | Boxed_float (Const f) -> + fprintf ppf "@[(@<0>%sBoxed_float@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Numbers.Float_by_bit_pattern.print f + | Boxed_float (Var v) -> + fprintf ppf "@[(@<0>%sBoxed_float@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Boxed_int32 (Const n) -> + fprintf ppf "@[(@<0>%sBoxed_int32@<0>%s %ld)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + n + | Boxed_int32 (Var v) -> + fprintf ppf "@[(@<0>%sBoxed_int32@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Boxed_int64 (Const n) -> + fprintf ppf "@[(@<0>%sBoxed_int64@<0>%s %Ld)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + n + | Boxed_int64 (Var v) -> + fprintf ppf "@[(@<0>%sBoxed_int64@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Boxed_nativeint (Const n) -> + fprintf ppf "@[(@<0>%sBoxed_nativeint@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Targetint.print n + | Boxed_nativeint (Var v) -> + fprintf ppf "@[(@<0>%sBoxed_nativeint@<0>%s %a)@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + Variable.print v + | Immutable_float_array fields -> + fprintf ppf "@[(@<0>%sImmutable_float_array@<0>%s@ @[[| %a |]@])@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") + print_float_array_field) + fields + | Mutable_string { initial_value = s; } -> + fprintf ppf "@[(@<0>%sMutable_string@<0>%s@ \"%s\")@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + s + | Immutable_string s -> + fprintf ppf "@[(@<0>%sImmutable_string@<0>%s@ \"%s\")@]" + (Flambda_colours.static_part ()) + (Flambda_colours.normal ()) + s + + let print ppf t = + print_with_cache ~cache:(Printing_cache.create ()) ppf t + + let compare t1 t2 = + match t1, t2 with + | Block (tag1, mut1, fields1), Block (tag2, mut2, fields2) -> + let c = Tag.Scannable.compare tag1 tag2 in + if c <> 0 then c + else + let c = compare_mutable_or_immutable mut1 mut2 in + if c <> 0 then c + else Misc.Stdlib.List.compare Field_of_block.compare fields1 fields2 + | Code_and_set_of_closures { code = code1; set_of_closures = set1; }, + Code_and_set_of_closures { code = code2; set_of_closures = set2; } -> + let c = + Code_id.Set.compare (Code_id.Map.keys code1) (Code_id.Map.keys code2) + in + if c <> 0 then c + else Option.compare Set_of_closures.compare set1 set2 + | Boxed_float (Const f1), Boxed_float (Const f2) -> + Numbers.Float_by_bit_pattern.compare f1 f2 + (* CR mshinwell: Move [or_variable] into its own module and add + [compare] *) + | Boxed_float (Var v1), Boxed_float (Var v2) -> Variable.compare v1 v2 + | Boxed_float (Const _), Boxed_float (Var _) -> -1 + | Boxed_float (Var _), Boxed_float (Const _) -> 1 + | Boxed_int32 (Const n1), Boxed_int32 (Const n2) -> Int32.compare n1 n2 + | Boxed_int32 (Var v1), Boxed_int32 (Var v2) -> Variable.compare v1 v2 + | Boxed_int32 (Const _), Boxed_int32 (Var _) -> -1 + | Boxed_int32 (Var _), Boxed_int32 (Const _) -> 1 + | Boxed_int64 (Const n1), Boxed_int64 (Const n2) -> Int64.compare n1 n2 + | Boxed_int64 (Var v1), Boxed_int64 (Var v2) -> Variable.compare v1 v2 + | Boxed_int64 (Const _), Boxed_int64 (Var _) -> -1 + | Boxed_int64 (Var _), Boxed_int64 (Const _) -> 1 + | Boxed_nativeint (Const n1), Boxed_nativeint (Const n2) -> + Targetint.compare n1 n2 + | Boxed_nativeint (Var v1), Boxed_nativeint (Var v2) -> + Variable.compare v1 v2 + | Boxed_nativeint (Const _), Boxed_nativeint (Var _) -> -1 + | Boxed_nativeint (Var _), Boxed_nativeint (Const _) -> 1 + | Immutable_float_array fields1, Immutable_float_array fields2 -> + Misc.Stdlib.List.compare (fun field1 field2 -> + match field1, field2 with + | Var var1, Var var2 -> Variable.compare var1 var2 + | Const f1, Const f2 -> Numbers.Float_by_bit_pattern.compare f1 f2 + | Const _, Var _ -> -1 + | Var _, Const _ -> 1) + fields1 fields2 + | Mutable_string { initial_value = s1; }, + Mutable_string { initial_value = s2; } + | Immutable_string s1, Immutable_string s2 -> String.compare s1 s2 + | Block _, _ -> -1 + | _, Block _ -> 1 + | Code_and_set_of_closures _, _ -> -1 + | _, Code_and_set_of_closures _ -> 1 + | Boxed_float _, _ -> -1 + | _, Boxed_float _ -> 1 + | Boxed_int32 _, _ -> -1 + | _, Boxed_int32 _ -> 1 + | Boxed_int64 _, _ -> -1 + | _, Boxed_int64 _ -> 1 + | Boxed_nativeint _, _ -> -1 + | _, Boxed_nativeint _ -> 1 + | Immutable_float_array _, _ -> -1 + | _, Immutable_float_array _ -> 1 + | Mutable_string _, _ -> -1 + | Immutable_string _, Mutable_string _ -> 1 + + let equal t1 t2 = (compare t1 t2 = 0) + + let hash _t = Misc.fatal_error "Not yet implemented" + + let output _ _ = Misc.fatal_error "Not yet implemented" +end) + let get_pieces_of_code t = match t with | Code_and_set_of_closures { code; set_of_closures = _; } -> @@ -194,131 +396,6 @@ let free_names t = (Name_occurrences.empty) fields -let print_params_and_body_with_cache ~cache ppf params_and_body = - match params_and_body with - | Deleted -> Format.fprintf ppf "Deleted" - | Present params_and_body -> - Function_params_and_body.print_with_cache ~cache ppf - params_and_body - -let print_code_with_cache ~cache ppf { params_and_body; newer_version_of; } = - Format.fprintf ppf "@[(\ - @[@<0>%s(newer_version_of@ %a)@<0>%s@]@ \ - %a\ - )@]" - (if Option.is_none newer_version_of then Flambda_colours.elide () - else Flambda_colours.normal ()) - (Misc.Stdlib.Option.print_compact Code_id.print) newer_version_of - (Flambda_colours.normal ()) - (print_params_and_body_with_cache ~cache) params_and_body - -let print_code ppf code = - print_code_with_cache ~cache:(Printing_cache.create ()) ppf code - -let print_with_cache ~cache ppf t = - let print_float_array_field ppf = function - | Const f -> fprintf ppf "%a" Numbers.Float_by_bit_pattern.print f - | Var v -> Variable.print ppf v - in - match t with - | Block (tag, mut, fields) -> - fprintf ppf "@[(@<0>%s%sblock@<0>%s (tag %a) (%a))@]" - (Flambda_colours.static_part ()) - (match mut with Immutable -> "Immutable_" | Mutable -> "Mutable_") - (Flambda_colours.normal ()) - Tag.Scannable.print tag - (Format.pp_print_list ~pp_sep:Format.pp_print_space - Field_of_block.print) fields - | Code_and_set_of_closures { code; set_of_closures; } -> - if Option.is_none set_of_closures then - match Code_id.Map.get_singleton code with - | None -> - fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ - @[%a@]\ - ))@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Code_id.Map.print (print_code_with_cache ~cache)) code - | Some (_code_id, code) -> - fprintf ppf "@[(@<0>%sCode@<0>%s@ (\ - @[%a@]\ - ))@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (print_code_with_cache ~cache) code - else - fprintf ppf "@[(@<0>%sCode_and_set_of_closures@<0>%s@ (\ - @[(code@ (%a))@]@ \ - @[(set_of_closures@ (%a))@]\ - ))@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Code_id.Map.print (print_code_with_cache ~cache)) code - (Misc.Stdlib.Option.print - (Set_of_closures.print_with_cache ~cache)) - set_of_closures - | Boxed_float (Const f) -> - fprintf ppf "@[(@<0>%sBoxed_float@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Numbers.Float_by_bit_pattern.print f - | Boxed_float (Var v) -> - fprintf ppf "@[(@<0>%sBoxed_float@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Boxed_int32 (Const n) -> - fprintf ppf "@[(@<0>%sBoxed_int32@<0>%s %ld)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - n - | Boxed_int32 (Var v) -> - fprintf ppf "@[(@<0>%sBoxed_int32@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Boxed_int64 (Const n) -> - fprintf ppf "@[(@<0>%sBoxed_int64@<0>%s %Ld)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - n - | Boxed_int64 (Var v) -> - fprintf ppf "@[(@<0>%sBoxed_int64@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Boxed_nativeint (Const n) -> - fprintf ppf "@[(@<0>%sBoxed_nativeint@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Targetint.print n - | Boxed_nativeint (Var v) -> - fprintf ppf "@[(@<0>%sBoxed_nativeint@<0>%s %a)@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - Variable.print v - | Immutable_float_array fields -> - fprintf ppf "@[(@<0>%sImmutable_float_array@<0>%s@ @[[| %a |]@])@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") - print_float_array_field) - fields - | Mutable_string { initial_value = s; } -> - fprintf ppf "@[(@<0>%sMutable_string@<0>%s@ \"%s\")@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - s - | Immutable_string s -> - fprintf ppf "@[(@<0>%sImmutable_string@<0>%s@ \"%s\")@]" - (Flambda_colours.static_part ()) - (Flambda_colours.normal ()) - s - -let print ppf t = - print_with_cache ~cache:(Printing_cache.create ()) ppf t - (* let _invariant env t = try @@ -505,3 +582,16 @@ let disjoint_union t1 t2 = Misc.fatal_errorf "Cannot [disjoint_union] the following:@ %a@ and@ %a" print t1 print t2 + +let can_share t = + match t with + | Block (_, Immutable, _) + | Code_and_set_of_closures _ + | Boxed_float _ + | Boxed_int32 _ + | Boxed_int64 _ + | Boxed_nativeint _ + | Immutable_float_array _ + | Immutable_string _ -> true + | Block (_, Mutable, _) + | Mutable_string _ -> false diff --git a/middle_end/flambda2.0/terms/static_const.rec.mli b/middle_end/flambda2.0/terms/static_const.rec.mli index 79d93e0916d9..a124694f70c2 100644 --- a/middle_end/flambda2.0/terms/static_const.rec.mli +++ b/middle_end/flambda2.0/terms/static_const.rec.mli @@ -74,9 +74,7 @@ type t = | Mutable_string of { initial_value : string; } | Immutable_string of string -(** Print a static structure definition to a formatter. *) -val print : Format.formatter -> t -> unit - +include Identifiable.S with type t := t include Contains_names.S with type t := t val get_pieces_of_code @@ -86,3 +84,5 @@ val get_pieces_of_code val is_fully_static : t -> bool val disjoint_union : t -> t -> t + +val can_share : t -> bool From a231adf668d12026d6e73c37eef6f52df9818b2e Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 14:49:00 +0000 Subject: [PATCH 53/80] Colours --- middle_end/flambda2.0/terms/flambda_primitive.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/middle_end/flambda2.0/terms/flambda_primitive.ml b/middle_end/flambda2.0/terms/flambda_primitive.ml index f60683c2cb96..61e86b03298e 100644 --- a/middle_end/flambda2.0/terms/flambda_primitive.ml +++ b/middle_end/flambda2.0/terms/flambda_primitive.ml @@ -589,13 +589,15 @@ let print_unary_primitive ppf p = fprintf ppf "Box_%a" K.Boxable_number.print_lowercase_short k | Select_closure { move_from; move_to; } -> Format.fprintf ppf "@[(Select_closure@ \ - (%a \u{2192} %a))@]" + (%a \u{2192} %a@<0>%s))@]" Closure_id.print move_from Closure_id.print move_to + (Flambda_colours.prim_destructive ()) | Project_var { project_from; var = var_within_closure; } -> - Format.fprintf ppf "@[(Project_var@ (%a@ %a))@]" + Format.fprintf ppf "@[(Project_var@ (%a@ %a@<0>%s))@]" Closure_id.print project_from Var_within_closure.print var_within_closure + (Flambda_colours.prim_destructive ()) let arg_kind_of_unary_primitive p = match p with From f5a52724e4910ba63d02e8c3e1173e6c24f53d63 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 14:55:24 +0000 Subject: [PATCH 54/80] Indentation --- .../flambda2.0/simplify/simplify_expr.rec.ml | 106 +++++++++--------- 1 file changed, 53 insertions(+), 53 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 60632ab0edec..ff78b6e84899 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -421,59 +421,59 @@ and simplify_recursive_let_cont_handlers in let params_and_handler = CH.params_and_handler cont_handler in CPH.pattern_match params_and_handler ~f:(fun params ~handler -> - let arity = KP.List.arity params in - let dacc = - DA.map_denv dacc ~f:DE.increment_continuation_scope_level - in - (* let set = Continuation_handlers.domain rec_handlers in *) - let body, (handlers, user_data), uacc = - simplify_expr dacc body (fun cont_uses_env _code_age_relation r -> - let arg_types = - (* We can't know a good type from the call types *) - List.map T.unknown arity - in - let (cont_uses_env, _apply_cont_rewrite_id) : - Continuation_uses_env.t * Apply_cont_rewrite_id.t = - (* We don't know anything, it's like it was called - with an arbitrary argument! *) - CUE.record_continuation_use cont_uses_env - cont - Non_inlinable (* Maybe simpler ? *) - ~typing_env_at_use:( - (* not useful as we will have only top *) - DE.typing_env definition_denv - ) - ~arg_types - in - let denv = - (* XXX These don't have the same scope level as the - non-recursive case *) - DE.add_parameters definition_denv params ~param_types:arg_types - in - let dacc = DA.create denv cont_uses_env r in - let dacc = - DA.map_denv dacc ~f:DE.set_not_at_unit_toplevel - in - let handler, user_data, uacc = - simplify_one_continuation_handler dacc cont Recursive - cont_handler ~params ~handler - ~extra_params_and_args: - Continuation_extra_params_and_args.empty - (fun cont_uses_env code_age_relation r -> - let user_data, uacc = k cont_uses_env code_age_relation r in - let uacc = - UA.map_uenv uacc ~f:(fun uenv -> - UE.add_continuation uenv cont - original_cont_scope_level - arity) - in - user_data, uacc) - in - let handlers = Continuation.Map.singleton cont handler in - (handlers, user_data), uacc) - in - let expr = Flambda.Let_cont.create_recursive handlers ~body in - expr, user_data, uacc)) + let arity = KP.List.arity params in + let dacc = + DA.map_denv dacc ~f:DE.increment_continuation_scope_level + in + (* let set = Continuation_handlers.domain rec_handlers in *) + let body, (handlers, user_data), uacc = + simplify_expr dacc body (fun cont_uses_env _code_age_relation r -> + let arg_types = + (* We can't know a good type from the call types *) + List.map T.unknown arity + in + let (cont_uses_env, _apply_cont_rewrite_id) : + Continuation_uses_env.t * Apply_cont_rewrite_id.t = + (* We don't know anything, it's like it was called + with an arbitrary argument! *) + CUE.record_continuation_use cont_uses_env + cont + Non_inlinable (* Maybe simpler ? *) + ~typing_env_at_use:( + (* not useful as we will have only top *) + DE.typing_env definition_denv + ) + ~arg_types + in + let denv = + (* XXX These don't have the same scope level as the + non-recursive case *) + DE.add_parameters definition_denv params ~param_types:arg_types + in + let dacc = DA.create denv cont_uses_env r in + let dacc = + DA.map_denv dacc ~f:DE.set_not_at_unit_toplevel + in + let handler, user_data, uacc = + simplify_one_continuation_handler dacc cont Recursive + cont_handler ~params ~handler + ~extra_params_and_args: + Continuation_extra_params_and_args.empty + (fun cont_uses_env code_age_relation r -> + let user_data, uacc = k cont_uses_env code_age_relation r in + let uacc = + UA.map_uenv uacc ~f:(fun uenv -> + UE.add_continuation uenv cont + original_cont_scope_level + arity) + in + user_data, uacc) + in + let handlers = Continuation.Map.singleton cont handler in + (handlers, user_data), uacc) + in + let expr = Flambda.Let_cont.create_recursive handlers ~body in + expr, user_data, uacc)) and simplify_let_cont : 'a. DA.t -> Let_cont.t -> 'a k -> Expr.t * 'a * UA.t From d217ebf2297f4359da8fddbefb860ab6161b9b03 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 15:21:14 +0000 Subject: [PATCH 55/80] Colours --- middle_end/flambda2.0/terms/apply_cont_expr.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/middle_end/flambda2.0/terms/apply_cont_expr.ml b/middle_end/flambda2.0/terms/apply_cont_expr.ml index 95f339e6c7f1..013d1b20747c 100644 --- a/middle_end/flambda2.0/terms/apply_cont_expr.ml +++ b/middle_end/flambda2.0/terms/apply_cont_expr.ml @@ -70,8 +70,10 @@ let print ppf { k; args; trap_action; dbg; } = | args -> Format.fprintf ppf " %a" Simple.List.print args end; - Format.fprintf ppf "%a" Debuginfo.print_or_elide dbg; - Format.fprintf ppf "@]" + Format.fprintf ppf "@<0>%s%a@<0>%s@]" + (Flambda_colours.elide ()) + Debuginfo.print_or_elide dbg + (Flambda_colours.normal ()) let print_with_cache ~cache:_ ppf t = print ppf t From 1547823511247cf58ff6b84cb0ea876fab3d6bf6 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 15:29:56 +0000 Subject: [PATCH 56/80] Improved printing of Switch --- middle_end/flambda2.0/terms/switch_expr.ml | 36 +++++++++++++++++++--- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/middle_end/flambda2.0/terms/switch_expr.ml b/middle_end/flambda2.0/terms/switch_expr.ml index bfcfc3b5b1c1..32f82eaa141b 100644 --- a/middle_end/flambda2.0/terms/switch_expr.ml +++ b/middle_end/flambda2.0/terms/switch_expr.ml @@ -26,16 +26,44 @@ type t = { let fprintf = Format.fprintf let print_arms ppf arms = + let arms = + Immediate.Map.fold (fun discr k arms_inverse -> + match Continuation.Map.find k arms_inverse with + | exception Not_found -> + Continuation.Map.add k (Immediate.Set.singleton discr) + arms_inverse + | discrs -> + Continuation.Map.add k (Immediate.Set.add discr discrs) + arms_inverse) + arms + Continuation.Map.empty + in let spc = ref false in - Immediate.Map.iter (fun discriminant l -> + let arms = + List.sort (fun (k1, discrs1) (k2, discrs2) -> + let min1 = Immediate.Set.min_elt_opt discrs1 in + let min2 = Immediate.Set.min_elt_opt discrs2 in + match min1, min2 with + | None, None -> Continuation.compare k1 k2 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some min1, Some min2 -> Immediate.compare min1 min2) + (Continuation.Map.bindings arms) + in + List.iter (fun (k, discrs) -> if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[| %a @<0>%s\u{21a6}@<0>%s@ @<0>%sgoto@<0>%s %a@]" - Immediate.print discriminant + let discrs = Immediate.Set.elements discrs in + fprintf ppf "@[@[| %a @<0>%s\u{21a6}@<0>%s@ @]\ + @<0>%sgoto@<0>%s %a@]" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ | ") + Immediate.print) + discrs (Flambda_colours.elide ()) (Flambda_colours.normal ()) (Flambda_colours.expr_keyword ()) (Flambda_colours.normal ()) - Continuation.print l) + Continuation.print k) arms let print ppf { scrutinee; arms; } = From 094ec607cd2582445fc3271773874338378500d9 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 15:33:30 +0000 Subject: [PATCH 57/80] Truncate long Debuginfo printing --- lambda/debuginfo.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lambda/debuginfo.ml b/lambda/debuginfo.ml index 1006a56f85d0..a2648121d544 100644 --- a/lambda/debuginfo.ml +++ b/lambda/debuginfo.ml @@ -144,6 +144,20 @@ let rec print_compact ppf t = Format.fprintf ppf ";"; print_compact ppf t +(* CR mshinwell: read the formatter margin? *) +let print_compact ppf t = + let str = Format.asprintf "%a" print_compact t in + if String.length str < 30 then print_compact ppf t + else begin + let t = + match t with + | [] | [_] -> t + | item::_ -> [item] + in + print_compact ppf t; + Format.fprintf ppf "; ..." + end + let print_or_elide ppf t = if not (is_none t) then begin Format.fprintf ppf "@ <%a>" print_compact t From f2641ff282d997d4fe5e7d688e7ab7f4e858c9df Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 15:53:06 +0000 Subject: [PATCH 58/80] Formatting --- middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 6539b952eac1..4caaf93d426a 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -55,8 +55,8 @@ end = struct @[(inlining_depth_increment@ %d)@]@ \ @[(float_const_prop@ %b)@] \ @[(at_unit_toplevel@ %b)@] \ - @[(unit_toplevel_exn_continuation@ %a)@] \ - @[(symbols_currently_being_defined@ %a)@] \ + @[(unit_toplevel_exn_continuation@ %a)@]@ \ + @[(symbols_currently_being_defined@ %a)@]@ \ @[(code@ %a)@]\ )@]" round From e540556e4880d930c3298e4a7928b7c2eafee387 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 15:58:15 +0000 Subject: [PATCH 59/80] Improve error in Simplify_named --- middle_end/flambda2.0/simplify/simplify_named.rec.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index 83cd4c9f528f..fdcd882fa6fb 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -132,8 +132,12 @@ let bind_closure_types_inside_function ~denv_outside_function Closure_id.Map.fold (fun closure_id closure_type denv -> match Closure_id.Map.find closure_id closure_bound_names_inside with | exception Not_found -> - Misc.fatal_errorf "No bound variable for closure ID %a" + Misc.fatal_errorf "No closure name for closure ID %a.@ \ + closure_bound_names = %a.@ closure_bound_names_inside = %a." Closure_id.print closure_id + (Closure_id.Map.print Name_in_binding_pos.print) closure_bound_names + (Closure_id.Map.print Name_in_binding_pos.print) + closure_bound_names_inside | bound_name -> DE.add_equation_on_name denv (Name_in_binding_pos.name bound_name) @@ -175,8 +179,12 @@ let denv_inside_function ~denv_outside_function ~denv_after_enter_closure let denv = DE.add_parameters_with_unknown_types denv params in match Closure_id.Map.find closure_id closure_bound_names_inside with | exception Not_found -> - Misc.fatal_errorf "No closure name for closure ID %a" + Misc.fatal_errorf "No closure name for closure ID %a.@ \ + closure_bound_names = %a.@ closure_bound_names_inside = %a." Closure_id.print closure_id + (Closure_id.Map.print Name_in_binding_pos.print) closure_bound_names + (Closure_id.Map.print Name_in_binding_pos.print) + closure_bound_names_inside | name -> let name = Name_in_binding_pos.name name in DE.add_variable denv From b4b76fb31eb3e0de9f2bb2e1de04315a0294db03 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 17:27:26 +0000 Subject: [PATCH 60/80] Fixing proving of closures --- .../lifting/sort_lifted_constants.ml | 10 ++++++++- .../flambda2.0/simplify/simplify_named.rec.ml | 5 ++++- .../simplify/simplify_static_const.rec.ml | 2 ++ .../simplify/simplify_variadic_primitive.ml | 5 ----- middle_end/flambda2.0/types/flambda_type.mli | 10 +++++---- .../types/structures/closures_entry.rec.ml | 2 ++ .../types/structures/closures_entry.rec.mli | 4 ++++ .../types/template/flambda_type.templ.ml | 22 ++++++++----------- .../unboxing/unbox_continuation_params.ml | 17 +++++--------- 9 files changed, 42 insertions(+), 35 deletions(-) diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml index 06e7fea3ff32..e8a9a71fde9f 100644 --- a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml @@ -91,7 +91,15 @@ let sort lifted_constants = ignore closure_id; (* We take the free names of the whole set of closures for every closure symbol defined by it. *) - Set_of_closures.free_names set_of_closures + (* CR mshinwell: Think about this more. We need to + prevent sets of closures being split apart somehow. For + the moment add explicit dependencies between all + closure symbols in the set. *) + Symbol.Map.fold (fun symbol _ free_names -> + Name_occurrences.add_symbol free_names symbol + NM.normal) + closure_symbols + (Set_of_closures.free_names set_of_closures) end | Block _ | Boxed_float _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ | Immutable_float_array _ diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index fdcd882fa6fb..d7ace8d3b119 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -202,6 +202,8 @@ type simplify_function_result = { let simplify_function dacc closure_id function_decl ~all_function_decls_in_set ~closure_bound_names ~closure_element_types ~old_to_new_code_ids = let name = Format.asprintf "%a" Closure_id.print closure_id in + Format.eprintf "simplify_function %s, closure_bound_names %a\n%!" name + (Closure_id.Map.print Name_in_binding_pos.print) closure_bound_names; Profile.record_call ~accumulate:true name (fun () -> let denv_after_enter_closure = DE.enter_closure (DA.denv dacc) in let code_id = FD.code_id function_decl in @@ -217,6 +219,7 @@ let simplify_function dacc closure_id function_decl ~all_function_decls_in_set closure_id ~all_function_decls_in_set ~closure_bound_names ~closure_element_types ~old_to_new_code_ids) in +Format.eprintf "DA for body of %s:@ %a\n%!" name DA.print dacc; match Simplify_toplevel.simplify_toplevel dacc body ~return_continuation @@ -353,7 +356,7 @@ let simplify_set_of_closures0 dacc set_of_closures ~bind_to:(Name_in_binding_pos.to_name bound_name) in DE.with_typing_env denv - (TE.add_env_extension suitable_for ~env_extension)) + (TE.add_env_extension (DE.typing_env denv) ~env_extension)) closure_types_by_bound_name suitable_for_denv) in diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index cc8f4dea99c3..8b5b5d5f0dc0 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -192,6 +192,8 @@ let simplify_static_const_of_kind_value dacc let simplify_static_const_of_kind_fabricated dacc code_ids bound_symbols (static_const : Static_const.t) ~closure_symbols : Bound_symbols.t * SC.t * DA.t = +Format.eprintf "Simplifying with closure symbols %a\n%!" + (Closure_id.Map.print Symbol.print) closure_symbols; match static_const with | Code_and_set_of_closures { code; set_of_closures; } -> let code_ids' = Code_id.Map.keys code in diff --git a/middle_end/flambda2.0/simplify/simplify_variadic_primitive.ml b/middle_end/flambda2.0/simplify/simplify_variadic_primitive.ml index 12e428f64c99..19e7cd4b6d6e 100644 --- a/middle_end/flambda2.0/simplify/simplify_variadic_primitive.ml +++ b/middle_end/flambda2.0/simplify/simplify_variadic_primitive.ml @@ -22,11 +22,6 @@ let simplify_make_block dacc _prim dbg ~(make_block_kind : P.make_block_kind) ~(mutable_or_immutable : Effects.mutable_or_immutable) args_with_tys ~result_var = - (* -Format.eprintf "simplifying make_block on %a (num args %d)\n%!" - Variable.print result_var - (List.length args_with_tys); - *) let denv = DA.denv dacc in let args, _arg_tys = List.split args_with_tys in let invalid () = diff --git a/middle_end/flambda2.0/types/flambda_type.mli b/middle_end/flambda2.0/types/flambda_type.mli index 9f7ca221bb06..f75830c7c797 100644 --- a/middle_end/flambda2.0/types/flambda_type.mli +++ b/middle_end/flambda2.0/types/flambda_type.mli @@ -198,6 +198,8 @@ end module Closures_entry : sig type t + val closure_types : t -> flambda_type Closure_id.Map.t + val function_decl_types : t -> Function_declaration_type.t Closure_id.Map.t val closure_var_types : t -> flambda_type Var_within_closure.Map.t end @@ -451,10 +453,10 @@ val prove_unique_tag_and_size val prove_is_int : Typing_env.t -> t -> bool proof -(** Prove that the given type, of kind [Value], is a closures type - describing exactly one closure. The function declaration type corresponding - to such closure is returned together with its closure ID, if it is - known. *) +(** Prove that the given type, of kind [Value], is a closures type describing + exactly one set of closures. The function declaration type corresponding to + such closure is returned together with its closure ID, if it is known. *) +(* CR mshinwell: Fix comment and/or function name *) val prove_single_closures_entry : Typing_env.t -> t diff --git a/middle_end/flambda2.0/types/structures/closures_entry.rec.ml b/middle_end/flambda2.0/types/structures/closures_entry.rec.ml index ac62c0b52026..394f4ce8bfb1 100644 --- a/middle_end/flambda2.0/types/structures/closures_entry.rec.ml +++ b/middle_end/flambda2.0/types/structures/closures_entry.rec.ml @@ -171,6 +171,8 @@ let free_names { function_decls; closure_types; closure_var_types; } = (Name_occurrences.union (PC.free_names closure_types) (PV.free_names closure_var_types)) +let function_decl_types t = t.function_decls +let closure_types t = PC.to_map t.closure_types let closure_var_types t = PV.to_map t.closure_var_types let find_function_declaration t closure_id : _ Or_bottom.t = diff --git a/middle_end/flambda2.0/types/structures/closures_entry.rec.mli b/middle_end/flambda2.0/types/structures/closures_entry.rec.mli index 7f8bcf5b3df4..9975ff5026af 100644 --- a/middle_end/flambda2.0/types/structures/closures_entry.rec.mli +++ b/middle_end/flambda2.0/types/structures/closures_entry.rec.mli @@ -39,6 +39,10 @@ val find_function_declaration -> Closure_id.t -> Function_declaration_type.t Or_bottom.t +val closure_types : t -> Type_grammar.t Closure_id.Map.t + +val function_decl_types : t -> Function_declaration_type.t Closure_id.Map.t + val closure_var_types : t -> Type_grammar.t Var_within_closure.Map.t include Type_structure_intf.S diff --git a/middle_end/flambda2.0/types/template/flambda_type.templ.ml b/middle_end/flambda2.0/types/template/flambda_type.templ.ml index b3bccb7eb0bf..50b4abca6326 100644 --- a/middle_end/flambda2.0/types/template/flambda_type.templ.ml +++ b/middle_end/flambda2.0/types/template/flambda_type.templ.ml @@ -149,21 +149,17 @@ let prove_single_closures_entry' env t : _ proof_allowing_kind_mismatch = with | None -> Unknown | Some ((closure_id, set_of_closures_contents), closures_entry) -> - let closure_id' = + let closure_ids = Set_of_closures_contents.closures set_of_closures_contents - |> Closure_id.Set.get_singleton in - match closure_id' with - | None -> Unknown - | Some closure_id' -> - assert (Closure_id.equal closure_id closure_id'); - let function_decl = - Closures_entry.find_function_declaration closures_entry closure_id - in - match function_decl with - | Bottom -> Invalid - | Ok function_decl -> - Proved (closure_id, closures_entry, function_decl) + assert (Closure_id.Set.mem closure_id closure_ids); + let function_decl = + Closures_entry.find_function_declaration closures_entry closure_id + in + match function_decl with + | Bottom -> Invalid + | Ok function_decl -> + Proved (closure_id, closures_entry, function_decl) end | Value (Ok _) -> Invalid | Value Unknown -> Unknown diff --git a/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml b/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml index 022b64f4a821..8a39564e2038 100644 --- a/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml +++ b/middle_end/flambda2.0/unboxing/unbox_continuation_params.ml @@ -273,8 +273,7 @@ end module Closures_info = struct type t = { closure_id : Closure_id.t; - func_decl_type : T.Function_declaration_type.t0; - closure_type : T.t; + closures_entry : T.Closures_entry.t; } end @@ -288,13 +287,11 @@ struct let var_name = "unboxed_clos_var" let make_boxed_value (info : Info.t) ~fields:closure_vars = + let closures_entry = info.closures_entry in let all_function_decls_in_set = - Closure_id.Map.singleton info.closure_id - (Or_unknown_or_bottom.Ok info.func_decl_type) - in - let all_closures_in_set = - Closure_id.Map.singleton info.closure_id info.closure_type + T.Closures_entry.function_decl_types closures_entry in + let all_closures_in_set = T.Closures_entry.closure_types closures_entry in T.exactly_this_closure info.closure_id ~all_function_decls_in_set ~all_closures_in_set @@ -468,16 +465,14 @@ let rec make_unboxing_decision typing_env ~depth ~arg_types_by_use_id TE.print typing_env end | Wrong_kind | Invalid | Unknown -> - (* CR-someday mshinwell: We could support more than a unique closure. *) match T.prove_single_closures_entry' typing_env param_type with - | Proved (closure_id, closures_entry, Ok func_decl_type) -> + | Proved (closure_id, closures_entry, Ok _func_decl_type) -> let closure_var_types = T.Closures_entry.closure_var_types closures_entry in let info : Closures_spec.Info.t = { closure_id; - func_decl_type; - closure_type = param_type; + closures_entry; } in let closure_vars = Var_within_closure.Map.keys closure_var_types in From 62896552d44ad2cbde83b6b11b8d3f63f557bf45 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 17:34:34 +0000 Subject: [PATCH 61/80] Lifting --- middle_end/flambda2.0/simplify/simplify_named.rec.ml | 3 --- middle_end/flambda2.0/simplify/simplify_static_const.rec.ml | 2 -- 2 files changed, 5 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index d7ace8d3b119..e31ef67ad09c 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -202,8 +202,6 @@ type simplify_function_result = { let simplify_function dacc closure_id function_decl ~all_function_decls_in_set ~closure_bound_names ~closure_element_types ~old_to_new_code_ids = let name = Format.asprintf "%a" Closure_id.print closure_id in - Format.eprintf "simplify_function %s, closure_bound_names %a\n%!" name - (Closure_id.Map.print Name_in_binding_pos.print) closure_bound_names; Profile.record_call ~accumulate:true name (fun () -> let denv_after_enter_closure = DE.enter_closure (DA.denv dacc) in let code_id = FD.code_id function_decl in @@ -219,7 +217,6 @@ let simplify_function dacc closure_id function_decl ~all_function_decls_in_set closure_id ~all_function_decls_in_set ~closure_bound_names ~closure_element_types ~old_to_new_code_ids) in -Format.eprintf "DA for body of %s:@ %a\n%!" name DA.print dacc; match Simplify_toplevel.simplify_toplevel dacc body ~return_continuation diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index 8b5b5d5f0dc0..cc8f4dea99c3 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -192,8 +192,6 @@ let simplify_static_const_of_kind_value dacc let simplify_static_const_of_kind_fabricated dacc code_ids bound_symbols (static_const : Static_const.t) ~closure_symbols : Bound_symbols.t * SC.t * DA.t = -Format.eprintf "Simplifying with closure symbols %a\n%!" - (Closure_id.Map.print Symbol.print) closure_symbols; match static_const with | Code_and_set_of_closures { code; set_of_closures; } -> let code_ids' = Code_id.Map.keys code in From 76d2bd0f2058fdabe65b2600aac901835489d298 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 18:25:02 +0000 Subject: [PATCH 62/80] Various lifting fixes --- .../flambda2.0/simplify/simplify_common.ml | 97 +++++++------------ 1 file changed, 37 insertions(+), 60 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_common.ml b/middle_end/flambda2.0/simplify/simplify_common.ml index 08beefe6e159..b7c5272d1afa 100644 --- a/middle_end/flambda2.0/simplify/simplify_common.ml +++ b/middle_end/flambda2.0/simplify/simplify_common.ml @@ -181,69 +181,47 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) Bound_symbols.print bound_symbols Static_const.print static_const in - let code = - Code_id.Map.mapi + (* CR mshinwell: For the moment, delete everything or nothing. This + should be improved at some point. *) + let code_unused = + Code_id.Map.for_all (fun code_id - ({ params_and_body; newer_version_of; } : Static_const.code) - : Static_const.code -> - let params_and_body : _ Static_const.or_deleted = - match params_and_body with - | Deleted -> Deleted - | Present _ -> - (* CR mshinwell: The binding can be completely removed (rather - than going to, or staying as, [Deleted]) if no subsequent - [newer_version_of] references it. *) - (* CR mshinwell: The "free_names_in_others" stuff is - inefficient and hacky. *) - let free_names_in_others = - let code = Code_id.Map.remove code_id code in - let static_const : Static_const.t = - Code_and_set_of_closures { code; set_of_closures; } - in - Static_const.free_names static_const - in - let code_unused = - (not (Name_occurrences.mem_code_id free_names_after code_id)) - && (not (Name_occurrences.mem_code_id free_names_in_others - code_id)) - in - let can_delete_code = - (* We cannot delete code unless it is certain that a - non-trivial join operation between later versions of it - cannot happen. *) - code_unused - && Code_age_relation.newer_versions_form_linear_chain - code_age_relation code_id - in - if can_delete_code then Deleted - else params_and_body - in - { params_and_body; newer_version_of; }) + ({ params_and_body; newer_version_of = _; } : Static_const.code) -> + match params_and_body with + | Deleted -> true + | Present _ -> + (* CR mshinwell: The binding can be completely removed (rather + than going to, or staying as, [Deleted]) if no subsequent + [newer_version_of] references it. *) + let code_unused = + not (Name_occurrences.mem_code_id free_names_after code_id) + in + (* We cannot delete code unless it is certain that a + non-trivial join operation between later versions of it + cannot happen. *) + code_unused + && Code_age_relation.newer_versions_form_linear_chain + code_age_relation code_id) code in - (* For the moment we don't delete individual closures from sets of closures. - We could do this, but we would be relying on 100% conversion of - [Select_closure] expressions to symbols (which should happen, but even - still). *) - let all_closure_symbols_unused = - Closure_id.Map.for_all (fun closure_id symbol -> - let free_names_in_others = - match set_of_closures with - | Some set -> - let set = - Set_of_closures.filter_function_declarations set - ~f:(fun closure_id' _ -> - not (Closure_id.equal closure_id closure_id')) - in - Set_of_closures.free_names set - | None -> assert false - in - (not (Name_occurrences.mem_symbol free_names_after symbol)) - && (not (Name_occurrences.mem_symbol free_names_in_others symbol))) + let set_of_closures_unused = + Closure_id.Map.for_all (fun _closure_id symbol -> + not (Name_occurrences.mem_symbol free_names_after symbol)) closure_symbols in + let delete = code_unused && set_of_closures_unused in + let code = + if not delete then code + else + Code_id.Map.map + (fun ({ params_and_body = _; newer_version_of; } : Static_const.code) + : Static_const.code -> + let params_and_body : _ Static_const.or_deleted = Deleted in + { params_and_body; newer_version_of; }) + code + in let set_of_closures = - if all_closure_symbols_unused then None + if delete then None else set_of_closures in let static_const : Static_const.t = @@ -253,14 +231,13 @@ let create_let_symbol code_age_relation (bound_symbols : Bound_symbols.t) } in let closure_symbols = - if all_closure_symbols_unused then Closure_id.Map.empty + if delete then Closure_id.Map.empty else closure_symbols in let bound_symbols : Bound_symbols.t = Code_and_set_of_closures { code_ids; closure_symbols; } in - if Code_id.Set.is_empty code_ids && Closure_id.Map.is_empty closure_symbols - then body + if delete then body else Let_symbol.create bound_symbols static_const body |> Expr.create_let_symbol From 49e23f67ad4b90991102cf43d5908a891af1ee1e Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 6 Jan 2020 18:25:07 +0000 Subject: [PATCH 63/80] New example --- flambdatest/mlexamples/toplevel_rec.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 flambdatest/mlexamples/toplevel_rec.ml diff --git a/flambdatest/mlexamples/toplevel_rec.ml b/flambdatest/mlexamples/toplevel_rec.ml new file mode 100644 index 000000000000..98670cf59d5e --- /dev/null +++ b/flambdatest/mlexamples/toplevel_rec.ml @@ -0,0 +1,10 @@ +external ( + ) : int -> int -> int = "%addint" +external ( - ) : int -> int -> int = "%subint" +external opaque : 'a -> 'a = "%opaque" + +let z = opaque 42 + +let rec f x = + z + g (x + 1) +and g y = + z + f (y - 1) From 7ddcccab469b2810653e81704766643a4013e35c Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 11:40:55 +0000 Subject: [PATCH 64/80] Add checks and fix bug in let-code --- .../simplify/env/simplify_env_and_result.ml | 7 +++++++ .../simplify/env/simplify_env_and_result_intf.ml | 2 ++ middle_end/flambda2.0/simplify/simplify_expr.rec.ml | 7 +++++++ .../flambda2.0/simplify/simplify_named.rec.ml | 3 +++ .../simplify/simplify_static_const.rec.ml | 13 +++++++++++++ 5 files changed, 32 insertions(+) diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 4caaf93d426a..662adac7278c 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -337,6 +337,13 @@ end = struct (* CR mshinwell: Convert [Typing_env] to map from [Simple]s. *) | Const _ -> () + let check_code_id_is_bound t code_id = + if not (Code_id.Map.mem code_id t.code) then begin + Misc.fatal_errorf "Unbound code ID %a in environment:@ %a" + Code_id.print code_id + print t + end + let define_code t ?newer_version_of ~code_id ~params_and_body:code = if Code_id.Map.mem code_id t.code then begin Misc.fatal_errorf "Code ID %a is already defined, cannot redefine to@ %a" diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml index f8069bd02ede..b741f12ea7e8 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.ml @@ -127,6 +127,8 @@ module type Downwards_env = sig val check_simple_is_bound : t -> Simple.t -> unit + val check_code_id_is_bound : t -> Code_id.t -> unit + (** Add the given lifted constants to the given environment. Symbols defined in the lifted constants but already defined in the given environment are ignored. diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index ff78b6e84899..d0dac8e68b85 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -84,6 +84,13 @@ and simplify_let_symbol let bound_symbols, defining_expr, dacc = Simplify_static_const.simplify_static_const dacc bound_symbols defining_expr in + let bound_symbols_free_names = Bound_symbols.free_names bound_symbols in + Symbol.Set.iter (fun sym -> + DE.check_symbol_is_bound (DA.denv dacc) sym) + (Name_occurrences.symbols bound_symbols_free_names); + Code_id.Set.iter (fun code_id -> + DE.check_code_id_is_bound (DA.denv dacc) code_id) + (Name_occurrences.code_ids bound_symbols_free_names); let dacc = DA.map_denv dacc ~f:(fun denv -> Symbol.Set.fold (fun symbol denv -> diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index e31ef67ad09c..fdbe768d0faf 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -449,6 +449,9 @@ let simplify_non_lifted_set_of_closures dacc ~bound_vars ~closure_bound_vars let defining_expr = Reachable.reachable (Named.create_set_of_closures set_of_closures) in + (* CR mshinwell: This next part should probably be shared between the + lifted and non-lifted cases; we always need the new code in the + environment and [r]. *) let dacc = DA.map_r dacc ~f:(fun r -> R.new_lifted_constant r diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index cc8f4dea99c3..39f3258acd56 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -69,6 +69,19 @@ let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols Simplify_named.simplify_set_of_closures0 dacc set_of_closures ~closure_bound_names ~closure_elements ~closure_element_types in + (* CR mshinwell: See comment in simplify_non_lifted_set_of_closures about + the following *) + let dacc = + DA.map_r dacc ~f:(fun r -> + R.new_lifted_constant r + (Lifted_constant.create_pieces_of_code (DA.denv dacc) + code ~newer_versions_of)) + in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + DE.add_lifted_constants denv + ~lifted:(R.get_lifted_constants (DA.r dacc))) + in let code = Code_id.Map.mapi (fun code_id params_and_body : Static_const.code -> { params_and_body = Present params_and_body; From 6feae67966eeeec4e53784a8acb5901843104950 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 11:48:33 +0000 Subject: [PATCH 65/80] Improve diagnostic --- .../flambda2.0/lifting/sort_lifted_constants.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml index e8a9a71fde9f..1d7b52067629 100644 --- a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml @@ -276,7 +276,18 @@ let sort lifted_constants = | None -> Some set | Some set' -> if not (Set_of_closures.equal set set') then - Some (Set_of_closures.disjoint_union set set') + match Set_of_closures.disjoint_union set set' with + | exception (Invalid_argument _) -> + Misc.fatal_errorf "Sets of closures for SCC \ + component {%a} are not disjoint:@ %a@ and@ \ + %a" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + Code_id_or_symbol.print) + members + Set_of_closures.print set + Set_of_closures.print set' + | set -> Some set else set_of_closures in From a6a0a1b8b17e5c4ac52df00f98932e02e9bec6f2 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 12:10:48 +0000 Subject: [PATCH 66/80] Unions --- middle_end/flambda2.0/lifting/sort_lifted_constants.ml | 2 +- middle_end/flambda2.0/terms/function_declaration.ml | 2 ++ middle_end/flambda2.0/terms/function_declaration.mli | 2 ++ middle_end/flambda2.0/terms/function_declarations.ml | 6 +++++- middle_end/flambda2.0/terms/set_of_closures.ml | 3 ++- middle_end/flambda2.0/terms/set_of_closures.mli | 2 ++ 6 files changed, 14 insertions(+), 3 deletions(-) diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml index 1d7b52067629..241c823b73c5 100644 --- a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml @@ -279,7 +279,7 @@ let sort lifted_constants = match Set_of_closures.disjoint_union set set' with | exception (Invalid_argument _) -> Misc.fatal_errorf "Sets of closures for SCC \ - component {%a} are not disjoint:@ %a@ and@ \ + component@ {%a}@ are not disjoint:@ %a@ and@ \ %a" (Format.pp_print_list ~pp_sep:Format.pp_print_space diff --git a/middle_end/flambda2.0/terms/function_declaration.ml b/middle_end/flambda2.0/terms/function_declaration.ml index 276510870bdf..0d8750b9fa06 100644 --- a/middle_end/flambda2.0/terms/function_declaration.ml +++ b/middle_end/flambda2.0/terms/function_declaration.ml @@ -138,3 +138,5 @@ let update_code_id t code_id = { t with code_id; } other things in [t1] and [t2] are equal *) let compare t1 t2 = Code_id.compare t1.code_id t2.code_id + +let equal t1 t2 = (compare t1 t2 = 0) diff --git a/middle_end/flambda2.0/terms/function_declaration.mli b/middle_end/flambda2.0/terms/function_declaration.mli index f51c1cb37784..a86e64dd480f 100644 --- a/middle_end/flambda2.0/terms/function_declaration.mli +++ b/middle_end/flambda2.0/terms/function_declaration.mli @@ -70,3 +70,5 @@ val update_code_id : t -> Code_id.t -> t val recursive : t -> Recursive.t val compare : t -> t -> int + +val equal : t -> t -> bool diff --git a/middle_end/flambda2.0/terms/function_declarations.ml b/middle_end/flambda2.0/terms/function_declarations.ml index 41a82ce367fa..3dc29919a1f1 100644 --- a/middle_end/flambda2.0/terms/function_declarations.ml +++ b/middle_end/flambda2.0/terms/function_declarations.ml @@ -54,7 +54,11 @@ let apply_name_permutation ({ funs; } as t) perm = else { funs = funs'; } let disjoint_union t1 t2 = - let funs = Closure_id.Map.disjoint_union t1.funs t2.funs in + let funs = + Closure_id.Map.disjoint_union + ~eq:Function_declaration.equal + t1.funs t2.funs + in { funs; } let compare { funs = funs1; } { funs = funs2; } = diff --git a/middle_end/flambda2.0/terms/set_of_closures.ml b/middle_end/flambda2.0/terms/set_of_closures.ml index b85f7fdd7406..44521cdc8cde 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.ml +++ b/middle_end/flambda2.0/terms/set_of_closures.ml @@ -139,7 +139,8 @@ let disjoint_union t1 t2 = Function_declarations.disjoint_union t1.function_decls t2.function_decls in let closure_elements = - Var_within_closure.Map.disjoint_union t1.closure_elements + Var_within_closure.Map.disjoint_union ~eq:Simple.equal + t1.closure_elements t2.closure_elements in { function_decls; diff --git a/middle_end/flambda2.0/terms/set_of_closures.mli b/middle_end/flambda2.0/terms/set_of_closures.mli index 48b2ebea2452..66c5129b01c4 100644 --- a/middle_end/flambda2.0/terms/set_of_closures.mli +++ b/middle_end/flambda2.0/terms/set_of_closures.mli @@ -42,6 +42,8 @@ val has_empty_environment : t -> bool may be lifted.) *) val environment_doesn't_mention_variables : t -> bool +(* CR mshinwell: name may be misleading -- equal function decls etc. are + allowed *) val disjoint_union : t -> t -> t val filter_function_declarations From a780c1183a9a45157cf4aac3728b243cd743e28a Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 13:07:03 +0000 Subject: [PATCH 67/80] Fix for invariant check --- middle_end/flambda2.0/naming/name_occurrences.ml | 6 ++++++ middle_end/flambda2.0/naming/name_occurrences.mli | 2 ++ middle_end/flambda2.0/types/env/typing_env.rec.ml | 5 ++++- 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/middle_end/flambda2.0/naming/name_occurrences.ml b/middle_end/flambda2.0/naming/name_occurrences.ml index f5ad02a01afa..d56ea01e6303 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.ml +++ b/middle_end/flambda2.0/naming/name_occurrences.ml @@ -618,3 +618,9 @@ let downgrade_occurrences_at_strictly_greater_kind code_ids; newer_version_of_code_ids; } + +let without_code_ids t = + { t with + code_ids = For_code_ids.empty; + newer_version_of_code_ids = For_code_ids.empty; + } diff --git a/middle_end/flambda2.0/naming/name_occurrences.mli b/middle_end/flambda2.0/naming/name_occurrences.mli index 3b78847d2e80..876e8df79315 100644 --- a/middle_end/flambda2.0/naming/name_occurrences.mli +++ b/middle_end/flambda2.0/naming/name_occurrences.mli @@ -112,6 +112,8 @@ val code_ids : t -> Code_id.Set.t val newer_version_of_code_ids : t -> Code_id.Set.t +val without_code_ids : t -> t + val mem_var : t -> Variable.t -> bool val mem_symbol : t -> Symbol.t -> bool diff --git a/middle_end/flambda2.0/types/env/typing_env.rec.ml b/middle_end/flambda2.0/types/env/typing_env.rec.ml index 3271bfb12545..9a6509309d72 100644 --- a/middle_end/flambda2.0/types/env/typing_env.rec.ml +++ b/middle_end/flambda2.0/types/env/typing_env.rec.ml @@ -465,7 +465,10 @@ let invariant_for_new_equation t name ty = let defined_names = Name_occurrences.create_names (domain0 t) Name_mode.in_types in - let free_names = Type_grammar.free_names ty in + (* CR mshinwell: It's a shame we can't check code IDs here. *) + let free_names = + Name_occurrences.without_code_ids (Type_grammar.free_names ty) + in if not (Name_occurrences.subset_domain free_names defined_names) then begin let unbound_names = Name_occurrences.diff free_names defined_names in Misc.fatal_errorf "New equation@ %a@ =@ %a@ has unbound names@ (%a):@ %a" From b1ef7cba157b6efca768bd7a8ba338cc9458f7a3 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 13:56:46 +0000 Subject: [PATCH 68/80] debugging --- middle_end/flambda2.0/simplify/simplify_named.rec.ml | 11 +++++++++++ .../flambda2.0/simplify/simplify_static_const.rec.ml | 7 +++++++ 2 files changed, 18 insertions(+) diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index fdbe768d0faf..ce7a4a4da359 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -260,6 +260,12 @@ let simplify_function dacc closure_id function_decl ~all_function_decls_in_set ~params_and_body |> DE.add_lifted_constants ~lifted:(R.get_lifted_constants r) in + (* Only holds in the symbols case + Closure_id.Map.iter (fun _ name -> + DE.check_name_is_bound denv_outside_function + (Name_in_binding_pos.to_name name)) + closure_bound_names; + *) function_decl_type ~denv_outside_function function_decl Rec_info.initial in { function_decl; @@ -357,11 +363,16 @@ let simplify_set_of_closures0 dacc set_of_closures closure_types_by_bound_name suitable_for_denv) in + let orig_set_of_closures = set_of_closures in let set_of_closures = Set_of_closures.create (Function_declarations.create all_function_decls_in_set) ~closure_elements in + Format.eprintf "Starting SOC:@ %a@ Returned SOC:@ %a@ dacc:@ %a\n%!" + Set_of_closures.print orig_set_of_closures + Set_of_closures.print set_of_closures + DA.print dacc; let newer_versions_of = Code_id.invert_map old_to_new_code_ids in { set_of_closures; closure_types_by_bound_name; diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index 39f3258acd56..b502f0fcba3a 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -59,6 +59,13 @@ let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols let closure_bound_names = Closure_id.Map.map Name_in_binding_pos.symbol closure_symbols in + let dacc = + DA.map_denv dacc ~f:(fun denv -> + Closure_id.Map.fold (fun _closure_id symbol denv -> + DE.define_symbol denv symbol K.value) + closure_symbols + denv) + in let { Simplify_named. set_of_closures; closure_types_by_bound_name; From c5ab7720a6bfd7e91261a88559231837993869ea Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 13:57:04 +0000 Subject: [PATCH 69/80] comments --- middle_end/flambda2.0/simplify/simplify_named.rec.ml | 2 ++ middle_end/flambda2.0/simplify/simplify_static_const.rec.ml | 5 ----- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index ce7a4a4da359..50bcf2a8d177 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -124,6 +124,8 @@ let bind_closure_types_inside_function ~denv_outside_function (* The name may be bound already when reifying computed values at toplevel (see [Simplify_static.simplify_return_continuation_handler]). *) + (* CR mshinwell: update out of date comment. Do we still need + [define_name_if_undefined] here? *) DE.define_name_if_undefined denv bound_name K.value) closure_bound_names_inside denv diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index b502f0fcba3a..9fb8f0e61bf7 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -221,11 +221,6 @@ let simplify_static_const_of_kind_fabricated dacc code_ids bound_symbols Code_id.Set.print code_ids' Static_const.print static_const end; - (* CR-someday mshinwell: If we start simplifying code here, then - the [Let_symbol] case in [Simplify_expr] will have to be able to cope - with lifted constants arriving from the simplification of a - [Let_symbol]'s defining expression, that may need to be put into the - same set of closures as the current defining expression. *) let dacc = Code_id.Map.fold (fun code_id From e7d91795fe51c9e3664f38b23ce608b357d1d34a Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 17:21:37 +0000 Subject: [PATCH 70/80] Remove cruft from tests8 --- flambdatest/mlexamples/tests8.ml | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/flambdatest/mlexamples/tests8.ml b/flambdatest/mlexamples/tests8.ml index fc992ca2b0f4..d70c84e195c8 100644 --- a/flambdatest/mlexamples/tests8.ml +++ b/flambdatest/mlexamples/tests8.ml @@ -4,22 +4,8 @@ type +'a node = and 'a t = unit -> 'a node -(* -external rand : unit -> int = "rand" -let r = rand () -*) - let rec map_foo f seq () = match seq() with | Nil -> Nil | Cons (x, next) -> - Cons (f x, fun () -> (map_foo [@inlined never]) (fun x -> x) (fun () -> Nil) ()) -(* -let iter f seq = - let rec aux seq = match seq () with - | Nil -> () - | Cons (x, next) -> - f x; - aux next - in - aux seq -*) + Cons (f x, + fun () -> (map_foo [@inlined never]) (fun x -> x) (fun () -> Nil) ()) From cd6c6ef9d21f1f4e9d389667261e04c0aa9695a1 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 17:22:12 +0000 Subject: [PATCH 71/80] Fix problem with invariant check when adding LCs --- .../simplify/env/simplify_env_and_result.ml | 25 ++++++++++--------- .../flambda2.0/simplify/simplify_expr.rec.ml | 2 ++ 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml index 662adac7278c..ad82edf25769 100644 --- a/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml +++ b/middle_end/flambda2.0/simplify/env/simplify_env_and_result.ml @@ -380,6 +380,16 @@ end = struct Lifted_constant.print) lifted; *) let module LC = Lifted_constant in + let t = + List.fold_left (fun t lifted_constant -> + let types_of_symbols = LC.types_of_symbols lifted_constant in + Symbol.Map.fold (fun sym typ t -> + define_symbol_if_undefined t sym (T.kind typ)) + types_of_symbols + t) + t + lifted + in List.fold_left (fun denv lifted_constant -> let denv_at_definition = LC.denv_at_definition lifted_constant in let types_of_symbols = LC.types_of_symbols lifted_constant in @@ -399,17 +409,7 @@ end = struct to be found:@ %a@ denv:@ %a" LC.print lifted_constant print denv - else - let typing_env = - Symbol.Map.fold (fun sym typ typing_env -> - let sym = - Name_in_binding_pos.create (Name.symbol sym) - Name_mode.normal - in - TE.add_definition typing_env sym (T.kind typ)) - types_of_symbols - denv.typing_env - in + else begin Symbol.Map.fold (fun sym typ typing_env -> let sym = Name.symbol sym in let env_extension = @@ -420,7 +420,8 @@ end = struct in TE.add_env_extension typing_env ~env_extension) types_of_symbols - typing_env + denv.typing_env + end in Code_id.Map.fold (fun code_id (params_and_body, newer_version_of) denv -> diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index d0dac8e68b85..5dac6481120e 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -272,6 +272,8 @@ and simplify_non_recursive_let_cont_handler KP.List.print params; *) let denv = + (* CR mshinwell: Don't need to re-add constants that were + above the [Let_cont], they will already be in denv. *) DE.add_lifted_constants denv ~lifted:(R.get_lifted_constants r) in let uses = From 3f5b4789ca55149d6cecfa226ccde17181df7377 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 17:26:22 +0000 Subject: [PATCH 72/80] Remove debug --- middle_end/flambda2.0/simplify/simplify_named.rec.ml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/middle_end/flambda2.0/simplify/simplify_named.rec.ml b/middle_end/flambda2.0/simplify/simplify_named.rec.ml index 50bcf2a8d177..d7a3bbfff805 100644 --- a/middle_end/flambda2.0/simplify/simplify_named.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_named.rec.ml @@ -365,16 +365,11 @@ let simplify_set_of_closures0 dacc set_of_closures closure_types_by_bound_name suitable_for_denv) in - let orig_set_of_closures = set_of_closures in let set_of_closures = Set_of_closures.create (Function_declarations.create all_function_decls_in_set) ~closure_elements in - Format.eprintf "Starting SOC:@ %a@ Returned SOC:@ %a@ dacc:@ %a\n%!" - Set_of_closures.print orig_set_of_closures - Set_of_closures.print set_of_closures - DA.print dacc; let newer_versions_of = Code_id.invert_map old_to_new_code_ids in { set_of_closures; closure_types_by_bound_name; From b48faa5dd198e1f1f25d3b501b4773a02ba036af Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Jan 2020 17:28:40 +0000 Subject: [PATCH 73/80] Fix? --- middle_end/flambda2.0/simplify/simplify_static_const.rec.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml index 9fb8f0e61bf7..8872f4c14c10 100644 --- a/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_static_const.rec.ml @@ -62,7 +62,7 @@ let simplify_set_of_closures0 dacc set_of_closures ~closure_symbols let dacc = DA.map_denv dacc ~f:(fun denv -> Closure_id.Map.fold (fun _closure_id symbol denv -> - DE.define_symbol denv symbol K.value) + DE.define_symbol_if_undefined denv symbol K.value) closure_symbols denv) in From 9b5f7cf7450daf8e1b19147745197b07883734c7 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 9 Jan 2020 10:24:22 +0000 Subject: [PATCH 74/80] Don't forget [Var] deps for SCC --- .../mlexamples/let_symbol_order_atexit.ml | 11 +++++ .../lifting/reify_continuation_param_types.ml | 4 +- .../lifting/sort_lifted_constants.ml | 44 +++++++++++++++++-- .../lifting/sort_lifted_constants.mli | 2 +- .../flambda2.0/simplify/simplify_expr.rec.ml | 5 ++- 5 files changed, 60 insertions(+), 6 deletions(-) create mode 100644 flambdatest/mlexamples/let_symbol_order_atexit.ml diff --git a/flambdatest/mlexamples/let_symbol_order_atexit.ml b/flambdatest/mlexamples/let_symbol_order_atexit.ml new file mode 100644 index 000000000000..34fed058385c --- /dev/null +++ b/flambdatest/mlexamples/let_symbol_order_atexit.ml @@ -0,0 +1,11 @@ +type 'a ref = { mutable contents : 'a } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +let id () = () +external sys_exit : int -> 'a = "caml_sys_exit" +let exit_function = ref id +let do_at_exit () = (!exit_function) () +let _at_exit _f = () +let exit retcode = + do_at_exit (); + sys_exit retcode diff --git a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml index 4f6983b4ef6a..52e612ab22f7 100644 --- a/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml +++ b/middle_end/flambda2.0/lifting/reify_continuation_param_types.ml @@ -209,7 +209,9 @@ let lift_via_reification_of_continuation_param_types dacc ~params continuation's parameters, which are in turn substituted for symbols at the Cmm translation phase). (Any SCC class containing >1 set of closures is maybe a bug?) *) - let reified_definitions = Sort_lifted_constants.sort reified_definitions in + let reified_definitions = + Sort_lifted_constants.sort dacc reified_definitions + in let handler = List.fold_left (fun handler (bound_symbols, defining_expr) -> Let_symbol.create bound_symbols defining_expr handler diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml index 241c823b73c5..cad10336eba1 100644 --- a/middle_end/flambda2.0/lifting/sort_lifted_constants.ml +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.ml @@ -29,13 +29,18 @@ type result = { bindings_outermost_last : (Bound_symbols.t * Static_const.t) list; } -let sort lifted_constants = +let sort dacc lifted_constants = (* The various lifted constants may exhibit recursion between themselves (specifically between closures and/or code). We use SCC to obtain a topological sort of groups that must be coalesced into single code-and-set-of-closures definitions. *) let lifted_constants_dep_graph = List.fold_left (fun dep_graph (bound_symbols, defining_expr) -> + (* + Format.eprintf "Input: %a = %a\n%!" + Bound_symbols.print bound_symbols + Static_const.print defining_expr; + *) Code_id_or_symbol.Set.fold (fun (being_defined : Code_id_or_symbol.t) dep_graph -> let free_names = @@ -110,6 +115,30 @@ let sort lifted_constants = end in let free_syms = Name_occurrences.symbols free_names in + (* Beware: when coming from [Reify_continuation_params] the + sets of closures may have dependencies on variables that are + now equal to symbols in the environment. (They haven't been + changed to symbols yet as the simplifier hasn't been run on + the definitions.) Some of these symbols may be the ones + involved in the current SCC calculation. As such, we must + explicitly add these dependencies. *) + let free_syms = + Variable.Set.fold (fun var free_syms -> + let typing_env = DE.typing_env (DA.denv dacc) in + let canonical = + TE.get_canonical_simple typing_env + ~min_name_mode:NM.normal + (Simple.var var) + in + match canonical with + | Bottom | Ok None -> free_syms + | Ok (Some canonical) -> + match Simple.descr canonical with + | Name (Var _) | Const _ -> free_syms + | Name (Symbol sym) -> Symbol.Set.add sym free_syms) + (Name_occurrences.variables free_names) + free_syms + in let free_code_ids = Code_id.Set.union (Name_occurrences.code_ids free_names) (Name_occurrences.newer_version_of_code_ids free_names) @@ -133,11 +162,11 @@ let sort lifted_constants = Code_id_or_symbol.Map.empty lifted_constants in -(* + (* Format.eprintf "SCC graph is:@ %a\n%!" (Code_id_or_symbol.Map.print Code_id_or_symbol.Set.print) lifted_constants_dep_graph; -*) + *) let connected_components = SCC_lifted_constants.connected_components_sorted_from_roots_to_leaf lifted_constants_dep_graph @@ -235,6 +264,9 @@ let sort lifted_constants = let bound_symbols : Bound_symbols.t = Singleton sym in bound_symbols, defining_expr | Closure_symbol (closure_id, set_of_closures) -> + (* CR mshinwell: This probably doesn't actually happen at + the moment since we add dependencies from each closure + symbol to all others (including itself) in the same set. *) let bound_symbols : Bound_symbols.t = Code_and_set_of_closures { code_ids = Code_id.Set.empty; @@ -323,4 +355,10 @@ let sort lifted_constants = Let the list L be a topological sort of a directed graph G. Then the reverse of L is a topological sort of the transpose of G. *) + (* + Format.eprintf "Result, outermost first:@ %a\n%!" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Bound_symbols.print) + (List.rev (List.map fst bindings_outermost_last)); + *) { bindings_outermost_last; } diff --git a/middle_end/flambda2.0/lifting/sort_lifted_constants.mli b/middle_end/flambda2.0/lifting/sort_lifted_constants.mli index dd3418995ad8..aa80d8163381 100644 --- a/middle_end/flambda2.0/lifting/sort_lifted_constants.mli +++ b/middle_end/flambda2.0/lifting/sort_lifted_constants.mli @@ -22,4 +22,4 @@ type result = private { bindings_outermost_last : (Bound_symbols.t * Static_const.t) list; } -val sort : (Bound_symbols.t * Static_const.t) list -> result +val sort : DA.t -> (Bound_symbols.t * Static_const.t) list -> result diff --git a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml index 5dac6481120e..f19395896523 100644 --- a/middle_end/flambda2.0/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda2.0/simplify/simplify_expr.rec.ml @@ -125,7 +125,10 @@ Format.eprintf "All bindings:@ %a\n%!" all_lifted_constants; *) let sorted_lifted_constants = - Sort_lifted_constants.sort all_lifted_constants + (* CR mshinwell: [Sort_lifted_constants] should never need dacc here. + We should maybe change the interface to make it optional and cause + an error if it tries to use it. *) + Sort_lifted_constants.sort dacc all_lifted_constants in let expr = List.fold_left (fun body (bound_symbols, defining_expr) -> From 4f98425df1ab3ca2d7d2b23d2c061f6c69a13526 Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Wed, 8 Jan 2020 13:15:47 +0100 Subject: [PATCH 75/80] Fix Un_cps --- middle_end/flambda2.0/to_cmm/un_cps.ml | 29 +++++-- middle_end/flambda2.0/to_cmm/un_cps_result.ml | 21 +---- .../flambda2.0/to_cmm/un_cps_result.mli | 4 +- middle_end/flambda2.0/to_cmm/un_cps_static.ml | 82 +++++++++++-------- .../flambda2.0/to_cmm/un_cps_static.mli | 2 +- 5 files changed, 71 insertions(+), 67 deletions(-) diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 4ce118d3d299..5ee0adb26d2b 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -615,13 +615,17 @@ and let_expr env t = and let_symbol env let_sym = let body = Let_symbol.body let_sym in - let env, r = + let env, r, update_opt = Un_cps_static.static_const env ~params_and_body (Let_symbol.bound_symbols let_sym) (Let_symbol.defining_expr let_sym) in result := R.combine !result r; - expr env body + match update_opt with + | None -> expr env body (* trying to preserve tail calls whenever we can *) + | Some update -> + let wrap, env = Env.flush_delayed_lets env in + wrap (C.sequence update (expr env body)) and let_set_of_closures env body closure_vars soc = (* First translate the set of closures, and bind it in the env *) @@ -1193,23 +1197,30 @@ let unit (unit : Flambda_unit.t) = Flambda_kind.value; ] in - let _return_cont, env = + let return_cont, env = Env.add_jump_cont env (List.map snd return_cont_params) (Flambda_unit.return_continuation unit) in - (* let functions = program_functions offsets used_closure_vars unit in *) - let _body = expr env (Flambda_unit.body unit) in - Misc.fatal_error "To be continued" -(* + let body = expr env (Flambda_unit.body unit) in let body = let unit_value = C.targetint Targetint.zero in C.ccatch ~rec_flag:false ~body ~handlers:[C.handler return_cont return_cont_params unit_value] in - let data, entry, gc_roots, functions = R.to_cmm !result in + let entry = + let dbg = Debuginfo.none in + let fun_name = Compilenv.make_symbol (Some "entry") in + let fun_codegen = + [ Cmm.Reduce_code_size; + Cmm.No_CSE ] + in + C.cfunction (C.fundecl fun_name [] body fun_codegen dbg) + in + let data, gc_roots, functions = R.to_cmm !result in let cmm_data = C.flush_cmmgen_state () in let roots = List.map symbol gc_roots in (C.gc_root_table roots) :: data @ cmm_data @ functions @ [entry] -*) + (* Misc.fatal_error "To be continued" *) + (* let functions = program_functions offsets used_closure_vars unit in *) ) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_result.ml b/middle_end/flambda2.0/to_cmm/un_cps_result.ml index 7584a4ce06da..5e63f282e6d0 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_result.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_result.ml @@ -20,7 +20,6 @@ module C = struct end type t = { - init : Cmm.expression; current_data : Cmm.data_item list; other_data : Cmm.data_item list list; gc_roots : Symbol.t list; @@ -28,7 +27,6 @@ type t = { } let empty = { - init = C.void; current_data = []; other_data = []; gc_roots = []; @@ -42,7 +40,6 @@ let add_if_not_empty x l = (* CR mshinwell: Label the arguments so the evaluation order is clear *) let combine r t = { - init = C.sequence r.init t.init; current_data = []; other_data = add_if_not_empty r.current_data ( @@ -56,9 +53,6 @@ let archive_data r = { r with current_data = []; other_data = add_if_not_empty r.current_data r.other_data; } -let wrap_init f r = - { r with init = f r.init; } - let add_data d r = { r with current_data = d @ r.current_data; } @@ -72,19 +66,6 @@ let add_function f r = { r with functions = f :: r.functions; } let to_cmm r = - let entry = - let dbg = Debuginfo.none in - let fun_name = Compilenv.make_symbol (Some "entry") in - let fun_codegen = - if Config.flambda then - [ Cmm.Reduce_code_size; - Cmm.No_CSE ] - else - [ Cmm.Reduce_code_size ] - in - let init = C.sequence r.init (C.unit ~dbg) in - C.cfunction (C.fundecl fun_name [] init fun_codegen dbg) - in let data_list = add_if_not_empty r.current_data r.other_data in let data = List.map C.cdata data_list in - data, entry, r.gc_roots, r.functions + data, r.gc_roots, r.functions diff --git a/middle_end/flambda2.0/to_cmm/un_cps_result.mli b/middle_end/flambda2.0/to_cmm/un_cps_result.mli index f8dccc32993d..2bafa7468cff 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_result.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_result.mli @@ -26,8 +26,6 @@ val combine : t -> t -> t val archive_data : t -> t -val wrap_init : (Cmm.expression -> Cmm.expression) -> t -> t - val add_data : Cmm.data_item list -> t -> t val update_data : (Cmm.data_item list -> Cmm.data_item list) -> t -> t @@ -39,4 +37,4 @@ val add_function : Cmm.phrase -> t -> t (* CR mshinwell: Use a "private" record for the return type of this. *) val to_cmm : t - -> Cmm.phrase list * Cmm.phrase * (Symbol.t list) * (Cmm.phrase list) + -> Cmm.phrase list * (Symbol.t list) * (Cmm.phrase list) diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.ml b/middle_end/flambda2.0/to_cmm/un_cps_static.ml index b30498d95e16..d1c3f093d16d 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_static.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.ml @@ -93,45 +93,47 @@ let map_or_variable f default v = | Const c -> f c | Var _ -> default -let make_update env kind symb var i = +let make_update env kind symb var i prev_update = let e = Env.get_variable env var in let address = C.field_address symb i Debuginfo.none in - C.store kind Lambda.Root_initialization address e + let update = C.store kind Lambda.Root_initialization address e in + match prev_update with + | None -> Some update + | Some prev_update -> Some (C.sequence prev_update update) let rec static_block_updates symb env acc i = function - | [] -> List.fold_left C.sequence C.void acc + | [] -> acc | sv :: r -> begin match (sv : SC.Field_of_block.t) with | Symbol _ | Tagged_immediate _ -> static_block_updates symb env acc (i + 1) r | Dynamically_computed var -> - let update = make_update env Cmm.Word_val symb var i in - static_block_updates symb env (update :: acc) (i + 1) r + let acc = make_update env Cmm.Word_val symb var i acc in + static_block_updates symb env acc (i + 1) r end let rec static_float_array_updates symb env acc i = function - | [] -> List.fold_left C.sequence C.void acc + | [] -> acc | sv :: r -> begin match (sv : _ SC.or_variable) with | Const _ -> static_float_array_updates symb env acc (i + 1) r | Var var -> - let update = make_update env Cmm.Double_u symb var i in - static_float_array_updates symb env (update :: acc) (i + 1) r + let acc = make_update env Cmm.Double_u symb var i acc in + static_float_array_updates symb env acc (i + 1) r end let static_boxed_number kind env s default emit transl v r = let name = symbol s in let aux x cont = emit (name, Cmmgen_state.Global) (transl x) cont in - let wrapper = + let updates = match (v : _ SC.or_variable) with - | Const _ -> Fun.id + | Const _ -> None | Var v -> - let update = make_update env kind (C.symbol name) v 0 in - C.sequence update + make_update env kind (C.symbol name) v 0 None in - R.wrap_init wrapper (R.update_data (or_variable aux default v) r) + R.update_data (or_variable aux default v) r, updates let get_whole_closure_symbol = let whole_closure_symb_count = ref 0 in @@ -160,7 +162,7 @@ let rec static_set_of_closures env symbs set = (List.map fst (Var_within_closure.Map.bindings elts)) in let l, updates, length = - fill_static_layout clos_symb symbs decls elts env [] C.void 0 layout + fill_static_layout clos_symb symbs decls elts env [] None 0 layout in let header = C.cint (C.black_closure_header length) in let sdef = match !clos_symb with @@ -189,10 +191,10 @@ and fill_static_slot s symbs decls elts env acc offset updates slot = | `Data fields -> fields, updates | `Var v -> let s = get_whole_closure_symbol s in - let update = - make_update env Cmm.Word_val (C.symbol (symbol s)) v offset + let updates = + make_update env Cmm.Word_val (C.symbol (symbol s)) v offset updates in - [C.cint 1n], C.sequence update updates + [C.cint 1n], updates in List.rev fields @ acc, offset + 1, updates | Closure c -> @@ -237,8 +239,8 @@ let static_const0 env r ~params_and_body (bound_symbols : Bound_symbols.t) let header = C.block_header tag (List.length fields) in let static_fields = List.map (static_value env) fields in let block = C.emit_block block_name header static_fields in - let e = static_block_updates (C.symbol name) env [] 0 fields in - env, R.wrap_init (C.sequence e) (R.add_data block r) + let updates = static_block_updates (C.symbol name) env None 0 fields in + env, R.add_data block r, updates | Code_and_set_of_closures { code_ids = _; closure_symbols; }, Code_and_set_of_closures { code; set_of_closures; } -> (* We cannot both build the environment and compile the functions in @@ -284,29 +286,41 @@ let static_const0 env r ~params_and_body (bound_symbols : Bound_symbols.t) r in begin match set_of_closures with - | None -> updated_env, r + | None -> updated_env, r, None | Some set -> let data, updates = static_set_of_closures env closure_symbols set in - updated_env, R.wrap_init (C.sequence updates) (R.add_data data r) + updated_env, R.add_data data r, updates end | Singleton s, Boxed_float v -> let default = Numbers.Float_by_bit_pattern.zero in let transl = Numbers.Float_by_bit_pattern.to_float in - env, static_boxed_number - Cmm.Double_u env s default C.emit_float_constant transl v r + let r, updates = + static_boxed_number + Cmm.Double_u env s default C.emit_float_constant transl v r + in + env, r, updates | Singleton s, Boxed_int32 v -> - env, static_boxed_number - Cmm.Word_int env s 0l C.emit_int32_constant Fun.id v r + let r, updates = + static_boxed_number + Cmm.Word_int env s 0l C.emit_int32_constant Fun.id v r + in + env, r, updates | Singleton s, Boxed_int64 v -> - env, static_boxed_number - Cmm.Word_int env s 0L C.emit_int64_constant Fun.id v r + let r, updates = + static_boxed_number + Cmm.Word_int env s 0L C.emit_int64_constant Fun.id v r + in + env, r, updates | Singleton s, Boxed_nativeint v -> let default = Targetint.zero in let transl = nativeint_of_targetint in - env, static_boxed_number - Cmm.Word_int env s default C.emit_nativeint_constant transl v r + let r, updates = + static_boxed_number + Cmm.Word_int env s default C.emit_nativeint_constant transl v r + in + env, r, updates | Singleton s, Immutable_float_array fields -> let name = symbol s in let aux = map_or_variable Numbers.Float_by_bit_pattern.to_float 0. in @@ -314,13 +328,13 @@ let static_const0 env r ~params_and_body (bound_symbols : Bound_symbols.t) let float_array = C.emit_float_array_constant (name, Cmmgen_state.Global) static_fields in - let e = static_float_array_updates (C.symbol name) env [] 0 fields in - env, R.wrap_init (C.sequence e) (R.update_data float_array r) + let e = static_float_array_updates (C.symbol name) env None 0 fields in + env, R.update_data float_array r, e | Singleton s, Mutable_string { initial_value = str; } | Singleton s, Immutable_string str -> let name = symbol s in let data = C.emit_string_constant (name, Cmmgen_state.Global) str in - env, R.update_data data r + env, R.update_data data r, None | Singleton _, Code_and_set_of_closures _ -> Misc.fatal_errorf "[Code_and_set_of_closures] cannot be bound by a \ [Singleton] binding:@ %a" @@ -347,9 +361,9 @@ let static_const env ~params_and_body (bound_symbols : Bound_symbols.t) else Symbol.Set.elements (Bound_symbols.being_defined bound_symbols) in let r = R.add_gc_roots roots R.empty in - let env, r = + let env, r, update_opt = static_const0 env r ~params_and_body bound_symbols static_const in (* [R.archive_data] helps keep definitions of separate symbols in different [data_item] lists and this increases readability of the generated Cmm. *) - env, R.archive_data r + env, R.archive_data r, update_opt diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.mli b/middle_end/flambda2.0/to_cmm/un_cps_static.mli index 0b8669a307e5..e4df62509f73 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_static.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.mli @@ -28,4 +28,4 @@ val static_const -> Cmm.fundecl) -> Let_symbol.Bound_symbols.t -> Static_const.t - -> Un_cps_env.t * Un_cps_result.t + -> Un_cps_env.t * Un_cps_result.t * Cmm.expression option From f16dcbd2a0522c391064dc5cd735f7ddf9cdfad2 Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Wed, 8 Jan 2020 14:26:45 +0100 Subject: [PATCH 76/80] Scope checks --- middle_end/flambda2.0/to_cmm/un_cps.ml | 12 +++++++++++- middle_end/flambda2.0/to_cmm/un_cps_env.ml | 16 ++++++++++++++++ middle_end/flambda2.0/to_cmm/un_cps_env.mli | 6 ++++++ middle_end/flambda2.0/to_cmm/un_cps_static.ml | 6 ++++-- 4 files changed, 37 insertions(+), 3 deletions(-) diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index 5ee0adb26d2b..dddd7930720e 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -65,7 +65,9 @@ let symbol s = let name env = function | Name.Var v -> Env.inline_variable env v - | Name.Symbol s -> C.symbol (symbol s), env, Ece.pure + | Name.Symbol s -> + Env.check_scope env (Code_id_or_symbol.Symbol s); + C.symbol (symbol s), env, Ece.pure (* Constants *) @@ -615,6 +617,13 @@ and let_expr env t = and let_symbol env let_sym = let body = Let_symbol.body let_sym in + let bound_symbols = Let_symbol.bound_symbols let_sym in + let env = + (* All bound symbols are allowed to appear in each other's definition, + so they're added to the environment first *) + Env.add_to_scope env + (Let_symbol.Bound_symbols.everything_being_defined bound_symbols) + in let env, r, update_opt = Un_cps_static.static_const env ~params_and_body (Let_symbol.bound_symbols let_sym) @@ -807,6 +816,7 @@ and apply_call env e = given arbitrary effects and coeffects. *) | Call_kind.Function (* FIXME Let code *) Call_kind.Function_call.Direct { code_id; closure_id = _; return_arity; } -> + Env.check_scope env (Code_id_or_symbol.Code_id code_id); let info = Env.get_function_info env code_id in let ty = machtype_of_return_arity return_arity in let args, env, _ = arg_list env (Apply_expr.args e) in diff --git a/middle_end/flambda2.0/to_cmm/un_cps_env.ml b/middle_end/flambda2.0/to_cmm/un_cps_env.ml index f97db50c2ebd..e246fda9c2e8 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_env.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_env.ml @@ -105,6 +105,9 @@ type t = { (* pure bindings that can be inlined across stages. *) stages : stage list; (* archived stages, in reverse chronological order. *) + + names_in_scope : Code_id_or_symbol.Set.t; + (* Code ids and symbols bound in this scope, for invariant checking *) } let mk offsets k_return k_exn used_closure_vars = { @@ -115,6 +118,7 @@ let mk offsets k_return k_exn used_closure_vars = { vars = Variable.Map.empty; conts = Continuation.Map.empty; exn_conts_extra_args = Continuation.Map.empty; + names_in_scope = Code_id_or_symbol.Set.empty; } let enter_function_def env k_return k_exn = { @@ -127,6 +131,7 @@ let enter_function_def env k_return k_exn = { vars = Variable.Map.empty; conts = Continuation.Map.empty; exn_conts_extra_args = Continuation.Map.empty; + names_in_scope = env.names_in_scope; } let dummy offsets used_closure_vars = @@ -400,3 +405,14 @@ let flush_delayed_lets env = let used_closure_vars t = t.used_closure_vars +let add_to_scope env names = + { env with + names_in_scope = Code_id_or_symbol.Set.union env.names_in_scope names; + } + +let check_scope env code_id_or_symbol = + if Code_id_or_symbol.Set.mem code_id_or_symbol env.names_in_scope then () + else + Misc.fatal_errorf "Use out of scope of %a@.Known names:@.%a@." + Code_id_or_symbol.print code_id_or_symbol + Code_id_or_symbol.Set.print env.names_in_scope diff --git a/middle_end/flambda2.0/to_cmm/un_cps_env.mli b/middle_end/flambda2.0/to_cmm/un_cps_env.mli index f6f6a59431d6..e73c8171fff5 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_env.mli +++ b/middle_end/flambda2.0/to_cmm/un_cps_env.mli @@ -139,3 +139,9 @@ val layout : val used_closure_vars : t -> Var_within_closure.Set.t (** All closure variables used in the whole program. *) +val add_to_scope : t -> Code_id_or_symbol.Set.t -> t +(* Add the given names to the current scope *) + +val check_scope : t -> Code_id_or_symbol.t -> unit +(* Check that the given name is in scope *) + diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.ml b/middle_end/flambda2.0/to_cmm/un_cps_static.ml index d1c3f093d16d..48ea77c988d3 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_static.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.ml @@ -51,9 +51,11 @@ let filter_closure_vars env s = let todo () = failwith "Not yet implemented" (* ----- End of functions to share ----- *) -let name_static _env = function +let name_static env = function | Name.Var v -> `Var v - | Name.Symbol s -> `Data [C.symbol_address (symbol s)] + | Name.Symbol s -> + Env.check_scope env (Code_id_or_symbol.Symbol s); + `Data [C.symbol_address (symbol s)] let const_static _env c = match (c : Simple.Const.t) with From 64a1fca81a2f46bb08325033b978d168f128ba77 Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Wed, 8 Jan 2020 14:33:05 +0100 Subject: [PATCH 77/80] Address review comments --- middle_end/flambda2.0/to_cmm/un_cps.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/middle_end/flambda2.0/to_cmm/un_cps.ml b/middle_end/flambda2.0/to_cmm/un_cps.ml index dddd7930720e..11fc33f0547e 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps.ml @@ -1202,6 +1202,8 @@ let unit (unit : Flambda_unit.t) = used_closure_vars in let _env, return_cont_params = + (* Note: the environment would be used if we needed to compile the + handler, but since it's constant we don't need it *) var_list env [ Kinded_parameter.create (Parameter.wrap (Variable.create "*ret*")) Flambda_kind.value; @@ -1213,7 +1215,7 @@ let unit (unit : Flambda_unit.t) = in let body = expr env (Flambda_unit.body unit) in let body = - let unit_value = C.targetint Targetint.zero in + let unit_value = C.targetint Targetint.one in C.ccatch ~rec_flag:false ~body ~handlers:[C.handler return_cont return_cont_params unit_value] From 418eb509e8b640f9ff8ba218b388e55c34eb4fce Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 9 Jan 2020 10:49:25 +0000 Subject: [PATCH 78/80] Get Compilation_unit correct for external symbols Allow undefined external symbols / code IDs in check in Un_cps --- driver/optcompile.ml | 37 ++++++++++++++----- .../flambda2.0/basic/code_id_or_symbol.ml | 5 +++ .../flambda2.0/basic/code_id_or_symbol.mli | 2 + middle_end/flambda2.0/to_cmm/un_cps_env.ml | 10 ++++- 4 files changed, 44 insertions(+), 10 deletions(-) diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 402dd2c7778a..036cb2f9cb42 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -31,18 +31,32 @@ let (|>>) (x, y) f = (x, f y) (** Native compilation backend for .ml files. *) -(* XXX *) module Flambda2_backend = struct - let symbol_for_global' ?comp_unit id = + let symbol_for_module_block id = + assert (Ident.global id); + assert (not (Ident.is_predef id)); let comp_unit = - match comp_unit with - | None -> Compilation_unit.get_current_exn () - | Some comp_unit -> comp_unit + (* CR mshinwell: Get rid of this "caml" hack *) + Compilation_unit.create id + (Linkage_name.create ("caml" ^ Ident.name id)) in Symbol.unsafe_create comp_unit (Linkage_name.create (Compilenv.symbol_for_global id)) + let symbol_for_global' ?comp_unit id = + if Ident.global id && not (Ident.is_predef id) then + symbol_for_module_block id + else + let comp_unit = + match comp_unit with + | Some comp_unit -> comp_unit + | None -> Compilation_unit.get_current_exn () + in + Symbol.unsafe_create + comp_unit + (Linkage_name.create (Compilenv.symbol_for_global id)) + let closure_symbol _ = failwith "Not yet implemented" let division_by_zero = @@ -56,10 +70,15 @@ module Flambda2_backend = struct Predef.ident_invalid_argument let all_predefined_exception_symbols = - Symbol.Set.of_list [ - division_by_zero; - invalid_argument; - ] (* CR mshinwell: and the rest... *) + Predef.all_predef_exns + |> List.map (fun ident -> + symbol_for_global' ~comp_unit:(Compilation_unit.predefined_exception ()) + ident) + |> Symbol.Set.of_list + + let () = + assert (Symbol.Set.mem division_by_zero all_predefined_exception_symbols); + assert (Symbol.Set.mem invalid_argument all_predefined_exception_symbols) let symbol_for_global' id : Symbol.t = symbol_for_global' id diff --git a/middle_end/flambda2.0/basic/code_id_or_symbol.ml b/middle_end/flambda2.0/basic/code_id_or_symbol.ml index 07694f02975a..5ab724817682 100644 --- a/middle_end/flambda2.0/basic/code_id_or_symbol.ml +++ b/middle_end/flambda2.0/basic/code_id_or_symbol.ml @@ -43,3 +43,8 @@ include Identifiable.Make (struct let hash _ = Misc.fatal_error "Not yet implemented" end) + +let compilation_unit t = + match t with + | Code_id code_id -> Code_id.get_compilation_unit code_id + | Symbol sym -> Symbol.compilation_unit sym diff --git a/middle_end/flambda2.0/basic/code_id_or_symbol.mli b/middle_end/flambda2.0/basic/code_id_or_symbol.mli index 5fd5da3f22e1..870e5e37b274 100644 --- a/middle_end/flambda2.0/basic/code_id_or_symbol.mli +++ b/middle_end/flambda2.0/basic/code_id_or_symbol.mli @@ -19,3 +19,5 @@ type t = | Symbol of Symbol.t include Identifiable.S with type t := t + +val compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda2.0/to_cmm/un_cps_env.ml b/middle_end/flambda2.0/to_cmm/un_cps_env.ml index e246fda9c2e8..2baf523d2a0c 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_env.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_env.ml @@ -411,7 +411,15 @@ let add_to_scope env names = } let check_scope env code_id_or_symbol = - if Code_id_or_symbol.Set.mem code_id_or_symbol env.names_in_scope then () + let in_scope = + Code_id_or_symbol.Set.mem code_id_or_symbol env.names_in_scope + in + let in_another_unit = + not (Compilation_unit.equal + (Code_id_or_symbol.compilation_unit code_id_or_symbol) + (Compilation_unit.get_current_exn ())) + in + if in_scope || in_another_unit then () else Misc.fatal_errorf "Use out of scope of %a@.Known names:@.%a@." Code_id_or_symbol.print code_id_or_symbol From ef52394264606e1a554387d3e902fabae22ba88c Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 9 Jan 2020 11:48:46 +0000 Subject: [PATCH 79/80] Various fixes --- driver/optcompile.ml | 4 ++- .../mlexamples/let_symbol_order_atexit.mli | 31 +++++++++++++++++++ .../from_lambda/closure_conversion.ml | 14 +++++++++ middle_end/flambda2.0/to_cmm/un_cps_static.ml | 6 ++-- .../types/structures/product.rec.ml | 10 ++++-- 5 files changed, 59 insertions(+), 6 deletions(-) create mode 100644 flambdatest/mlexamples/let_symbol_order_atexit.mli diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 036cb2f9cb42..d6ee0f350f40 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -51,7 +51,9 @@ module Flambda2_backend = struct let comp_unit = match comp_unit with | Some comp_unit -> comp_unit - | None -> Compilation_unit.get_current_exn () + | None -> + if Ident.is_predef id then Compilation_unit.predefined_exception () + else Compilation_unit.get_current_exn () in Symbol.unsafe_create comp_unit diff --git a/flambdatest/mlexamples/let_symbol_order_atexit.mli b/flambdatest/mlexamples/let_symbol_order_atexit.mli new file mode 100644 index 000000000000..cab5f709f087 --- /dev/null +++ b/flambdatest/mlexamples/let_symbol_order_atexit.mli @@ -0,0 +1,31 @@ +(* val at_exit : (unit -> unit) -> unit *) + +val exit : int -> 'a +val do_at_exit : unit -> unit +(* + +(let + (id/7 = (function param/9 0a) + exit_function/11 = (makemutable 0 id/7) + do_at_exit/12 = (function param/14 (apply (field_mut 0 exit_function/11) 0a)) + _at_exit/15 = (function _f/17 0a) + exit/18 = (function retcode/20[int] (seq (apply do_at_exit/12 0a) (caml_sys_exit retcode/20)))) + (makeblock 0 exit/18 do_at_exit/12)) + +*) + + +(* + +val do_at_exit : unit -> unit +val exit : int -> 'a + +(let + (id/7 = (function param/9 0a) + exit_function/11 = (makemutable 0 id/7) + do_at_exit/12 = (function param/14 (apply (field_mut 0 exit_function/11) 0a)) + _at_exit/15 = (function _f/17 0a) + exit/18 = (function retcode/20[int] (seq (apply do_at_exit/12 0a) (caml_sys_exit retcode/20)))) + (makeblock 0 do_at_exit/12 exit/18)) + +*) diff --git a/middle_end/flambda2.0/from_lambda/closure_conversion.ml b/middle_end/flambda2.0/from_lambda/closure_conversion.ml index 421ab28a4dba..277e8fa3109a 100644 --- a/middle_end/flambda2.0/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2.0/from_lambda/closure_conversion.ml @@ -962,6 +962,20 @@ let ilambda_to_flambda ~backend ~module_ident ~module_block_size_in_words body t.code in + (* We must make sure there is always an outer [Let_symbol] binding so that + lifted constants not in the scope of any other [Let_symbol] binding get + put into the term and not dropped. Adding this extra binding, which + will actually be removed by the simplifier, avoids a special case. *) + begin match t.declared_symbols with + | _::_ -> () + | [] -> + let (_sym : Symbol.t) = + register_const0 t + (Static_const.Block (Tag.Scannable.zero, Immutable, [])) + "first_const" + in + () + end; let body = List.fold_left (fun body (symbol, static_const) -> Let_symbol.create (Singleton symbol) static_const body diff --git a/middle_end/flambda2.0/to_cmm/un_cps_static.ml b/middle_end/flambda2.0/to_cmm/un_cps_static.ml index 48ea77c988d3..e99376570c10 100644 --- a/middle_end/flambda2.0/to_cmm/un_cps_static.ml +++ b/middle_end/flambda2.0/to_cmm/un_cps_static.ml @@ -78,9 +78,11 @@ let simple_static env s = | Name n -> name_static env n | Const c -> `Data (const_static env c) -let static_value _env v = +let static_value env v = match (v : SC.Field_of_block.t) with - | Symbol s -> C.symbol_address (symbol s) + | Symbol s -> + Env.check_scope env (Code_id_or_symbol.Symbol s); + C.symbol_address (symbol s) | Dynamically_computed _ -> C.cint 1n | Tagged_immediate i -> C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i))) diff --git a/middle_end/flambda2.0/types/structures/product.rec.ml b/middle_end/flambda2.0/types/structures/product.rec.ml index 0dc06a23b2e4..77c4970a4e1d 100644 --- a/middle_end/flambda2.0/types/structures/product.rec.ml +++ b/middle_end/flambda2.0/types/structures/product.rec.ml @@ -40,13 +40,17 @@ module Make (Index : Identifiable.S) = struct { components_by_index; } - (* XXX This isn't right -- it seems the 0-arity one isn't bottom. This - presumably needs to take a kind? *) let create_bottom () = { components_by_index = Index.Map.empty; } - let is_bottom t = Index.Map.is_empty t.components_by_index + (* CR mshinwell: This "bottom" stuff is still dubious. + We can't treat 0-sized blocks as bottom; it's legal to bind one of + those (e.g. an empty module). *) + + let is_bottom t = + Index.Map.exists (fun _ typ -> Type_grammar.is_obviously_bottom typ) + t.components_by_index let indexes t = Index.Map.keys t.components_by_index From 0b6b7db309a246c8a7cfbe26b48b9286653cb08d Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Thu, 9 Jan 2020 13:58:49 +0100 Subject: [PATCH 80/80] Fixes for the Makefile build --- .depend | 1104 +++++++++++++++++++++++++++++++--------------------- .gitignore | 2 +- Makefile | 48 ++- 3 files changed, 683 insertions(+), 471 deletions(-) diff --git a/.depend b/.depend index be6a33b0504e..2856edf38563 100644 --- a/.depend +++ b/.depend @@ -1977,7 +1977,7 @@ asmcomp/asmgen.cmo : \ asmcomp/interval.cmi \ asmcomp/interf.cmi \ typing/ident.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ @@ -2021,7 +2021,7 @@ asmcomp/asmgen.cmx : \ asmcomp/interval.cmx \ asmcomp/interf.cmx \ typing/ident.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ @@ -2042,7 +2042,7 @@ asmcomp/asmgen.cmx : \ asmcomp/asmgen.cmi : \ lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ asmcomp/cmm.cmi \ middle_end/clambda.cmi \ @@ -4974,14 +4974,11 @@ middle_end/flambda/base_types/closure_element.cmi : \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi middle_end/flambda/base_types/closure_id.cmo : \ utils/int_replace_polymorphic_compare.cmi \ - middle_end/flambda2.0/basic/closure_element.cmi \ middle_end/flambda/base_types/closure_id.cmi middle_end/flambda/base_types/closure_id.cmx : \ utils/int_replace_polymorphic_compare.cmx \ - middle_end/flambda2.0/basic/closure_element.cmx \ middle_end/flambda/base_types/closure_id.cmi -middle_end/flambda/base_types/closure_id.cmi : \ - middle_end/flambda2.0/basic/closure_element.cmi +middle_end/flambda/base_types/closure_id.cmi : middle_end/flambda/base_types/closure_origin.cmo : \ utils/int_replace_polymorphic_compare.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ @@ -5120,14 +5117,11 @@ middle_end/flambda/base_types/symbol.cmi : \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi middle_end/flambda/base_types/var_within_closure.cmo : \ utils/int_replace_polymorphic_compare.cmi \ - middle_end/flambda2.0/basic/closure_element.cmi \ middle_end/flambda/base_types/var_within_closure.cmi middle_end/flambda/base_types/var_within_closure.cmx : \ utils/int_replace_polymorphic_compare.cmx \ - middle_end/flambda2.0/basic/closure_element.cmx \ middle_end/flambda/base_types/var_within_closure.cmi -middle_end/flambda/base_types/var_within_closure.cmi : \ - middle_end/flambda2.0/basic/closure_element.cmi +middle_end/flambda/base_types/var_within_closure.cmi : middle_end/flambda/base_types/variable.cmo : \ utils/misc.cmi \ middle_end/internal_variable_names.cmi \ @@ -5299,7 +5293,7 @@ middle_end/flambda2.0/flambda2_middle_end.cmo : \ middle_end/flambda2.0/from_lambda/prepare_lambda.cmi \ utils/misc.cmi \ middle_end/flambda2.0/from_lambda/ilambda.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/from_lambda/eliminate_mutable_vars.cmi \ middle_end/flambda2.0/from_lambda/cps_conversion.cmi \ @@ -5314,7 +5308,7 @@ middle_end/flambda2.0/flambda2_middle_end.cmx : \ middle_end/flambda2.0/from_lambda/prepare_lambda.cmx \ utils/misc.cmx \ middle_end/flambda2.0/from_lambda/ilambda.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/from_lambda/eliminate_mutable_vars.cmx \ middle_end/flambda2.0/from_lambda/cps_conversion.cmx \ @@ -5325,7 +5319,7 @@ middle_end/flambda2.0/flambda2_middle_end.cmx : \ middle_end/flambda2.0/flambda2_middle_end.cmi : \ lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmo : \ utils/numbers.cmi \ @@ -5335,30 +5329,22 @@ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmx : \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi : \ utils/identifiable.cmi -middle_end/flambda2.0/basic/closure_element.cmo : \ +middle_end/flambda2.0/basic/closure_id.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ utils/identifiable.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ - middle_end/flambda2.0/basic/closure_element.cmi -middle_end/flambda2.0/basic/closure_element.cmx : \ + middle_end/flambda2.0/basic/closure_id.cmi +middle_end/flambda2.0/basic/closure_id.cmx : \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ utils/identifiable.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ - middle_end/flambda2.0/basic/closure_element.cmi -middle_end/flambda2.0/basic/closure_element.cmi : \ + middle_end/flambda2.0/basic/closure_id.cmi +middle_end/flambda2.0/basic/closure_id.cmi : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ utils/identifiable.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi -middle_end/flambda2.0/basic/closure_id.cmo : \ - middle_end/flambda2.0/basic/closure_element.cmi \ - middle_end/flambda2.0/basic/closure_id.cmi -middle_end/flambda2.0/basic/closure_id.cmx : \ - middle_end/flambda2.0/basic/closure_element.cmx \ - middle_end/flambda2.0/basic/closure_id.cmi -middle_end/flambda2.0/basic/closure_id.cmi : \ - middle_end/flambda2.0/basic/closure_element.cmi middle_end/flambda2.0/basic/closure_origin.cmo : \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/basic/closure_origin.cmi @@ -5370,18 +5356,41 @@ middle_end/flambda2.0/basic/closure_origin.cmi : \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ middle_end/flambda2.0/basic/closure_id.cmi middle_end/flambda2.0/basic/code_id.cmo : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ utils/identifiable.cmi \ middle_end/flambda2.0/basic/id_types.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/basic/code_id.cmx : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ utils/identifiable.cmx \ middle_end/flambda2.0/basic/id_types.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/basic/code_id.cmi : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ utils/identifiable.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi +middle_end/flambda2.0/basic/code_id_or_symbol.cmo : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + utils/misc.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi +middle_end/flambda2.0/basic/code_id_or_symbol.cmx : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + utils/misc.cmx \ + utils/identifiable.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi +middle_end/flambda2.0/basic/code_id_or_symbol.cmi : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/basic/coeffects.cmo : \ middle_end/flambda2.0/basic/coeffects.cmi middle_end/flambda2.0/basic/coeffects.cmx : \ @@ -5731,13 +5740,21 @@ middle_end/flambda2.0/basic/trap_action.cmi : \ middle_end/flambda2.0/basic/expr_std.cmo \ middle_end/flambda2.0/basic/continuation.cmi middle_end/flambda2.0/basic/var_within_closure.cmo : \ - middle_end/flambda2.0/basic/closure_element.cmi \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi middle_end/flambda2.0/basic/var_within_closure.cmx : \ - middle_end/flambda2.0/basic/closure_element.cmx \ + middle_end/flambda2.0/compilenv_deps/variable.cmx \ + utils/identifiable.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ middle_end/flambda2.0/basic/var_within_closure.cmi middle_end/flambda2.0/basic/var_within_closure.cmi : \ - middle_end/flambda2.0/basic/closure_element.cmi + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi middle_end/flambda2.0/from_lambda/closure_conversion.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi \ @@ -5763,7 +5780,7 @@ middle_end/flambda2.0/from_lambda/closure_conversion.cmo : \ middle_end/flambda2.0/basic/immediate.cmi \ middle_end/flambda2.0/from_lambda/ilambda.cmi \ typing/ident.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ @@ -5773,6 +5790,7 @@ middle_end/flambda2.0/from_lambda/closure_conversion.cmo : \ middle_end/flambda2.0/basic/continuation.cmi \ utils/config.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/from_lambda/closure_conversion_aux.cmi \ middle_end/flambda2.0/terms/call_kind.cmi \ @@ -5804,7 +5822,7 @@ middle_end/flambda2.0/from_lambda/closure_conversion.cmx : \ middle_end/flambda2.0/basic/immediate.cmx \ middle_end/flambda2.0/from_lambda/ilambda.cmx \ typing/ident.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/terms/flambda_primitive.cmx \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ @@ -5814,6 +5832,7 @@ middle_end/flambda2.0/from_lambda/closure_conversion.cmx : \ middle_end/flambda2.0/basic/continuation.cmx \ utils/config.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ middle_end/flambda2.0/from_lambda/closure_conversion_aux.cmx \ middle_end/flambda2.0/terms/call_kind.cmx \ @@ -5823,7 +5842,7 @@ middle_end/flambda2.0/from_lambda/closure_conversion.cmx : \ middle_end/flambda2.0/from_lambda/closure_conversion.cmi : \ middle_end/flambda2.0/from_lambda/ilambda.cmi \ typing/ident.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi middle_end/flambda2.0/from_lambda/closure_conversion_aux.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ @@ -6084,7 +6103,11 @@ middle_end/flambda2.0/from_lambda/prepare_lambda.cmi : \ lambda/lambda.cmi middle_end/flambda2.0/inlining/inlining_cost.cmo : \ lambda/switch.cmi \ + middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ @@ -6093,7 +6116,11 @@ middle_end/flambda2.0/inlining/inlining_cost.cmo : \ middle_end/flambda2.0/inlining/inlining_cost.cmi middle_end/flambda2.0/inlining/inlining_cost.cmx : \ lambda/switch.cmx \ + middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ middle_end/flambda2.0/terms/flambda_primitive.cmx \ middle_end/flambda2.0/terms/flambda.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ @@ -6101,6 +6128,7 @@ middle_end/flambda2.0/inlining/inlining_cost.cmx : \ utils/clflags.cmx \ middle_end/flambda2.0/inlining/inlining_cost.cmi middle_end/flambda2.0/inlining/inlining_cost.cmi : \ + middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/terms/flambda.cmi middle_end/flambda2.0/inlining/inlining_decision.cmo : \ @@ -6110,6 +6138,7 @@ middle_end/flambda2.0/inlining/inlining_decision.cmo : \ utils/misc.cmi \ middle_end/flambda2.0/inlining/inlining_cost.cmi \ middle_end/flambda2.0/basic/inline_attribute.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/inlining/inlining_decision.cmi @@ -6120,6 +6149,7 @@ middle_end/flambda2.0/inlining/inlining_decision.cmx : \ utils/misc.cmx \ middle_end/flambda2.0/inlining/inlining_cost.cmx \ middle_end/flambda2.0/basic/inline_attribute.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ middle_end/flambda2.0/terms/flambda.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/inlining/inlining_decision.cmi @@ -6127,6 +6157,7 @@ middle_end/flambda2.0/inlining/inlining_decision.cmi : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/inlining/rec_info.cmi \ middle_end/flambda2.0/basic/inline_attribute.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/terms/flambda.cmi middle_end/flambda2.0/inlining/inlining_transforms.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ @@ -6144,6 +6175,7 @@ middle_end/flambda2.0/inlining/inlining_transforms.cmo : \ middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/basic/exn_continuation.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ + lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/inlining/inlining_transforms.cmi middle_end/flambda2.0/inlining/inlining_transforms.cmx : \ @@ -6162,10 +6194,12 @@ middle_end/flambda2.0/inlining/inlining_transforms.cmx : \ middle_end/flambda2.0/types/flambda_type.cmx \ middle_end/flambda2.0/basic/exn_continuation.cmx \ middle_end/flambda2.0/simplify/env/downwards_acc.cmx \ + lambda/debuginfo.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/inlining/inlining_transforms.cmi middle_end/flambda2.0/inlining/inlining_transforms.cmi : \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/exn_continuation.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ @@ -6185,6 +6219,105 @@ middle_end/flambda2.0/inlining/rec_info.cmx : \ middle_end/flambda2.0/inlining/rec_info.cmi middle_end/flambda2.0/inlining/rec_info.cmi : \ utils/identifiable.cmi +middle_end/flambda2.0/lifting/reification.cmo : \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/simplify/simplify_import.cmi \ + middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/simplify/basic/reachable.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/naming/name_mode.cmi \ + utils/misc.cmi \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/lifting/reification.cmi +middle_end/flambda2.0/lifting/reification.cmx : \ + middle_end/flambda2.0/compilenv_deps/variable.cmx \ + middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + middle_end/flambda2.0/simplify/simplify_import.cmx \ + middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/simplify/basic/reachable.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/naming/name_mode.cmx \ + utils/misc.cmx \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/lifting/reification.cmi +middle_end/flambda2.0/lifting/reification.cmi : \ + middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ + middle_end/flambda2.0/simplify/basic/reachable.cmi \ + middle_end/flambda2.0/types/flambda_type.cmi \ + middle_end/flambda2.0/terms/flambda.cmi \ + middle_end/flambda2.0/simplify/env/downwards_acc.cmi +middle_end/flambda2.0/lifting/reify_continuation_param_types.cmo : \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmi \ + middle_end/flambda2.0/simplify/simplify_import.cmi \ + middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + middle_end/flambda2.0/lifting/reification.cmi \ + middle_end/flambda2.0/types/basic/or_bottom.cmi \ + middle_end/flambda2.0/basic/name.cmi \ + utils/misc.cmi \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ + middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmi +middle_end/flambda2.0/lifting/reify_continuation_param_types.cmx : \ + middle_end/flambda2.0/compilenv_deps/variable.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmx \ + middle_end/flambda2.0/simplify/simplify_import.cmx \ + middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + middle_end/flambda2.0/lifting/reification.cmx \ + middle_end/flambda2.0/types/basic/or_bottom.cmx \ + middle_end/flambda2.0/basic/name.cmx \ + utils/misc.cmx \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ + middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/basic/closure_id.cmx \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmi +middle_end/flambda2.0/lifting/reify_continuation_param_types.cmi : \ + middle_end/flambda2.0/basic/kinded_parameter.cmi \ + middle_end/flambda2.0/terms/flambda.cmi \ + middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ + middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi +middle_end/flambda2.0/lifting/sort_lifted_constants.cmo : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + utils/strongly_connected_components.cmi \ + middle_end/flambda2.0/simplify/simplify_import.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + utils/misc.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmi +middle_end/flambda2.0/lifting/sort_lifted_constants.cmx : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + utils/strongly_connected_components.cmx \ + middle_end/flambda2.0/simplify/simplify_import.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + utils/misc.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/basic/closure_id.cmx \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmi +middle_end/flambda2.0/lifting/sort_lifted_constants.cmi : \ + middle_end/flambda2.0/simplify/simplify_import.cmi middle_end/flambda2.0/naming/bindable.cmo : \ utils/printing_cache.cmi \ middle_end/flambda2.0/naming/name_permutation.cmi \ @@ -6233,6 +6366,7 @@ middle_end/flambda2.0/naming/bindable_let_bound.cmo : \ middle_end/flambda2.0/naming/name_mode.cmi \ utils/misc.cmi \ utils/identifiable.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/naming/bindable_let_bound.cmi middle_end/flambda2.0/naming/bindable_let_bound.cmx : \ @@ -6243,6 +6377,7 @@ middle_end/flambda2.0/naming/bindable_let_bound.cmx : \ middle_end/flambda2.0/naming/name_mode.cmx \ utils/misc.cmx \ utils/identifiable.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ middle_end/flambda2.0/naming/bindable_let_bound.cmi middle_end/flambda2.0/naming/bindable_let_bound.cmi : \ @@ -6354,6 +6489,7 @@ middle_end/flambda2.0/naming/name_occurrences.cmo : \ utils/misc.cmi \ utils/identifiable.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi middle_end/flambda2.0/naming/name_occurrences.cmx : \ @@ -6366,6 +6502,7 @@ middle_end/flambda2.0/naming/name_occurrences.cmx : \ utils/misc.cmx \ utils/identifiable.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/naming/name_occurrences.cmi middle_end/flambda2.0/naming/name_occurrences.cmi : \ @@ -6375,7 +6512,8 @@ middle_end/flambda2.0/naming/name_occurrences.cmi : \ middle_end/flambda2.0/naming/name_permutation.cmi \ middle_end/flambda2.0/naming/name_mode.cmi \ middle_end/flambda2.0/basic/name.cmi \ - middle_end/flambda2.0/basic/continuation.cmi + middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/naming/name_permutation.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/naming/permutation.cmi \ @@ -6445,66 +6583,8 @@ middle_end/flambda2.0/parser/fexpr.cmo : \ parsing/location.cmi middle_end/flambda2.0/parser/fexpr.cmx : \ parsing/location.cmx -middle_end/flambda2.0/parser/fexpr_to_flambda.cmo : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/basic/var_within_closure.cmi \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ - utils/targetint.cmi \ - lambda/tag.cmi \ - middle_end/flambda2.0/compilenv_deps/symbol.cmi \ - middle_end/flambda2.0/basic/simple.cmi \ - middle_end/flambda2.0/basic/recursive.cmi \ - middle_end/flambda2.0/basic/parameter.cmi \ - middle_end/flambda2.0/naming/name_mode.cmi \ - middle_end/flambda2.0/basic/name.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ - middle_end/flambda2.0/basic/kinded_parameter.cmi \ - middle_end/flambda2.0/basic/immediate.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ - middle_end/flambda2.0/terms/flambda_primitive.cmi \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ - middle_end/flambda2.0/terms/flambda.cmi \ - middle_end/flambda2.0/parser/fexpr.cmo \ - middle_end/flambda2.0/basic/exn_continuation.cmi \ - middle_end/flambda2.0/basic/effects.cmi \ - lambda/debuginfo.cmi \ - middle_end/flambda2.0/basic/continuation.cmi \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ - middle_end/flambda2.0/basic/closure_id.cmi \ - middle_end/flambda2.0/terms/call_kind.cmi \ - middle_end/flambda2.0/naming/bindable_let_bound.cmi -middle_end/flambda2.0/parser/fexpr_to_flambda.cmx : \ - middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/basic/var_within_closure.cmx \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ - utils/targetint.cmx \ - lambda/tag.cmx \ - middle_end/flambda2.0/compilenv_deps/symbol.cmx \ - middle_end/flambda2.0/basic/simple.cmx \ - middle_end/flambda2.0/basic/recursive.cmx \ - middle_end/flambda2.0/basic/parameter.cmx \ - middle_end/flambda2.0/naming/name_mode.cmx \ - middle_end/flambda2.0/basic/name.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ - middle_end/flambda2.0/basic/kinded_parameter.cmx \ - middle_end/flambda2.0/basic/immediate.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ - middle_end/flambda2.0/terms/flambda_primitive.cmx \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ - middle_end/flambda2.0/terms/flambda.cmx \ - middle_end/flambda2.0/parser/fexpr.cmx \ - middle_end/flambda2.0/basic/exn_continuation.cmx \ - middle_end/flambda2.0/basic/effects.cmx \ - lambda/debuginfo.cmx \ - middle_end/flambda2.0/basic/continuation.cmx \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ - middle_end/flambda2.0/basic/closure_id.cmx \ - middle_end/flambda2.0/terms/call_kind.cmx \ - middle_end/flambda2.0/naming/bindable_let_bound.cmx +middle_end/flambda2.0/parser/fexpr_to_flambda.cmo : +middle_end/flambda2.0/parser/fexpr_to_flambda.cmx : middle_end/flambda2.0/parser/fexpr_to_ilambda.cmo : \ middle_end/flambda2.0/parser/print_fexpr.cmo \ utils/misc.cmi \ @@ -6545,7 +6625,7 @@ middle_end/flambda2.0/parser/parse_ilambda.cmo : \ utils/misc.cmi \ parsing/location.cmi \ middle_end/flambda2.0/from_lambda/ilambda.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/parser/flambda_parser.cmi \ middle_end/flambda2.0/parser/flambda_lex.cmo \ middle_end/flambda2.0/parser/fexpr_to_ilambda.cmo \ @@ -6557,7 +6637,7 @@ middle_end/flambda2.0/parser/parse_ilambda.cmx : \ utils/misc.cmx \ parsing/location.cmx \ middle_end/flambda2.0/from_lambda/ilambda.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/parser/flambda_parser.cmx \ middle_end/flambda2.0/parser/flambda_lex.cmx \ middle_end/flambda2.0/parser/fexpr_to_ilambda.cmx \ @@ -6567,42 +6647,6 @@ middle_end/flambda2.0/parser/print_fexpr.cmo : \ middle_end/flambda2.0/parser/fexpr.cmo middle_end/flambda2.0/parser/print_fexpr.cmx : \ middle_end/flambda2.0/parser/fexpr.cmx -middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.cmo : \ - middle_end/flambda2.0/simplify/env/upwards_acc.cmi \ - middle_end/flambda2.0/unboxing/unbox_continuation_params.cmi \ - middle_end/flambda2.0/simplify/simplify_import.cmi \ - middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ - utils/misc.cmi \ - middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmo \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ - middle_end/flambda2.0/basic/continuation.cmi \ - utils/clflags.cmi \ - middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.cmi -middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.cmx : \ - middle_end/flambda2.0/simplify/env/upwards_acc.cmx \ - middle_end/flambda2.0/unboxing/unbox_continuation_params.cmx \ - middle_end/flambda2.0/simplify/simplify_import.cmx \ - middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ - utils/misc.cmx \ - middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmx \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmx \ - middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmx \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ - middle_end/flambda2.0/basic/continuation.cmx \ - utils/clflags.cmx \ - middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.cmi -middle_end/flambda2.0/simplify/generic_simplify_let_cont.rec.cmi : \ - middle_end/flambda2.0/simplify/env/upwards_acc.cmi \ - middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmo \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ - middle_end/flambda2.0/basic/continuation.cmi middle_end/flambda2.0/simplify/simplify.cmo : \ utils/warnings.cmi \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ @@ -6610,17 +6654,19 @@ middle_end/flambda2.0/simplify/simplify.cmo : \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ middle_end/flambda2.0/simplify/env/upwards_acc.cmi \ middle_end/flambda2.0/unboxing/unbox_continuation_params.cmi \ - middle_end/flambda2.0/utils/top_closure.cmi \ lambda/tag.cmi \ middle_end/flambda2.0/compilenv_deps/symbol.cmi \ lambda/switch.cmi \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmi \ middle_end/flambda2.0/simplify/simplify_primitive.cmi \ middle_end/flambda2.0/simplify/simplify_import.cmi \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/simplify/simplify_common.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ middle_end/flambda2.0/basic/scope.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmi \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmi \ + middle_end/flambda2.0/lifting/reification.cmi \ middle_end/flambda2.0/basic/recursive.cmi \ middle_end/flambda2.0/inlining/rec_info.cmi \ middle_end/flambda2.0/simplify/basic/reachable.cmi \ @@ -6638,8 +6684,9 @@ middle_end/flambda2.0/simplify/simplify.cmo : \ middle_end/flambda2.0/inlining/inlining_transforms.cmi \ middle_end/flambda2.0/inlining/inlining_decision.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/types/flambda_type.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ @@ -6649,10 +6696,11 @@ middle_end/flambda2.0/simplify/simplify.cmo : \ lambda/debuginfo.cmi \ middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmo \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/terms/call_kind.cmi \ @@ -6667,17 +6715,19 @@ middle_end/flambda2.0/simplify/simplify.cmx : \ middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ middle_end/flambda2.0/simplify/env/upwards_acc.cmx \ middle_end/flambda2.0/unboxing/unbox_continuation_params.cmx \ - middle_end/flambda2.0/utils/top_closure.cmx \ lambda/tag.cmx \ middle_end/flambda2.0/compilenv_deps/symbol.cmx \ lambda/switch.cmx \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmx \ middle_end/flambda2.0/simplify/simplify_primitive.cmx \ middle_end/flambda2.0/simplify/simplify_import.cmx \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ middle_end/flambda2.0/simplify/simplify_common.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ middle_end/flambda2.0/basic/scope.cmx \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmx \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmx \ + middle_end/flambda2.0/lifting/reification.cmx \ middle_end/flambda2.0/basic/recursive.cmx \ middle_end/flambda2.0/inlining/rec_info.cmx \ middle_end/flambda2.0/simplify/basic/reachable.cmx \ @@ -6695,8 +6745,9 @@ middle_end/flambda2.0/simplify/simplify.cmx : \ middle_end/flambda2.0/inlining/inlining_transforms.cmx \ middle_end/flambda2.0/inlining/inlining_decision.cmx \ middle_end/flambda2.0/basic/immediate.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ middle_end/flambda2.0/types/flambda_type.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ @@ -6706,10 +6757,11 @@ middle_end/flambda2.0/simplify/simplify.cmx : \ lambda/debuginfo.cmx \ middle_end/flambda2.0/simplify/env/continuation_uses_env.cmx \ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmx \ - middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmx \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/terms/call_kind.cmx \ @@ -6718,7 +6770,7 @@ middle_end/flambda2.0/simplify/simplify.cmx : \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmx \ middle_end/flambda2.0/simplify/simplify.cmi middle_end/flambda2.0/simplify/simplify.cmi : \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi middle_end/flambda2.0/simplify/simplify_binary_primitive.cmo : \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ @@ -6764,29 +6816,41 @@ middle_end/flambda2.0/simplify/simplify_binary_primitive.cmi : \ lambda/debuginfo.cmi middle_end/flambda2.0/simplify/simplify_common.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ middle_end/flambda2.0/simplify/simplify_import.cmi \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/simplify/basic/reachable.cmi \ middle_end/flambda2.0/basic/parameter.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ middle_end/flambda2.0/basic/name.cmi \ utils/misc.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/basic/exn_continuation.cmi \ + lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/naming/bindable_let_bound.cmi \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmi \ middle_end/flambda2.0/simplify/simplify_common.cmi middle_end/flambda2.0/simplify/simplify_common.cmx : \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ middle_end/flambda2.0/simplify/simplify_import.cmx \ middle_end/flambda2.0/basic/simple.cmx \ middle_end/flambda2.0/simplify/basic/reachable.cmx \ middle_end/flambda2.0/basic/parameter.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ middle_end/flambda2.0/basic/name.cmx \ utils/misc.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ middle_end/flambda2.0/basic/exn_continuation.cmx \ + lambda/debuginfo.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ + middle_end/flambda2.0/basic/closure_id.cmx \ middle_end/flambda2.0/naming/bindable_let_bound.cmx \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmx \ middle_end/flambda2.0/simplify/simplify_common.cmi @@ -6803,6 +6867,7 @@ middle_end/flambda2.0/simplify/simplify_common.cmi : \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/naming/bindable_let_bound.cmi \ middle_end/flambda2.0/terms/apply_expr.cmi \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi @@ -6810,10 +6875,15 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmo : \ utils/warnings.cmi \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi \ + middle_end/flambda2.0/unboxing/unbox_continuation_params.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ lambda/switch.cmi \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmi \ middle_end/flambda2.0/simplify/simplify_import.cmi \ middle_end/flambda2.0/simplify/simplify_common.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmi \ middle_end/flambda2.0/basic/recursive.cmi \ middle_end/flambda2.0/inlining/rec_info.cmi \ middle_end/flambda2.0/basic/parameter.cmi \ @@ -6827,6 +6897,9 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmo : \ middle_end/flambda2.0/inlining/inlining_transforms.cmi \ middle_end/flambda2.0/inlining/inlining_decision.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/exn_continuation.cmi \ @@ -6836,6 +6909,8 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmo : \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/terms/call_kind.cmi \ @@ -6847,10 +6922,15 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmx : \ utils/warnings.cmx \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ middle_end/flambda2.0/basic/var_within_closure.cmx \ + middle_end/flambda2.0/unboxing/unbox_continuation_params.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ lambda/switch.cmx \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmx \ middle_end/flambda2.0/simplify/simplify_import.cmx \ middle_end/flambda2.0/simplify/simplify_common.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmx \ middle_end/flambda2.0/basic/recursive.cmx \ middle_end/flambda2.0/inlining/rec_info.cmx \ middle_end/flambda2.0/basic/parameter.cmx \ @@ -6864,6 +6944,9 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmx : \ middle_end/flambda2.0/inlining/inlining_transforms.cmx \ middle_end/flambda2.0/inlining/inlining_decision.cmx \ middle_end/flambda2.0/basic/immediate.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ middle_end/flambda2.0/terms/flambda.cmx \ middle_end/flambda2.0/basic/exn_continuation.cmx \ @@ -6873,6 +6956,8 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmx : \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/terms/call_kind.cmx \ @@ -6885,7 +6970,8 @@ middle_end/flambda2.0/simplify/simplify_expr.rec.cmi : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi + middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi middle_end/flambda2.0/simplify/simplify_import.cmo : \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ middle_end/flambda2.0/simplify/env/upwards_acc.cmi \ @@ -6893,6 +6979,7 @@ middle_end/flambda2.0/simplify/simplify_import.cmo : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/naming/name_mode.cmi \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ @@ -6908,6 +6995,7 @@ middle_end/flambda2.0/simplify/simplify_import.cmx : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ middle_end/flambda2.0/naming/name_mode.cmx \ middle_end/flambda2.0/basic/kinded_parameter.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/types/flambda_type.cmx \ middle_end/flambda2.0/terms/flambda_primitive.cmx \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ @@ -6923,6 +7011,7 @@ middle_end/flambda2.0/simplify/simplify_import.cmi : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/naming/name_mode.cmi \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ @@ -6938,8 +7027,9 @@ middle_end/flambda2.0/simplify/simplify_named.rec.cmo : \ middle_end/flambda2.0/simplify/simplify_primitive.cmi \ middle_end/flambda2.0/simplify/simplify_import.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ middle_end/flambda2.0/basic/scope.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmi \ + middle_end/flambda2.0/lifting/reification.cmi \ middle_end/flambda2.0/inlining/rec_info.cmi \ middle_end/flambda2.0/simplify/basic/reachable.cmi \ utils/profile.cmi \ @@ -6949,10 +7039,15 @@ middle_end/flambda2.0/simplify/simplify_named.rec.cmo : \ middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ middle_end/flambda2.0/inlining/inlining_decision.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ + middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/exn_continuation.cmi \ + middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/naming/bindable_let_bound.cmi \ @@ -6965,8 +7060,9 @@ middle_end/flambda2.0/simplify/simplify_named.rec.cmx : \ middle_end/flambda2.0/simplify/simplify_primitive.cmx \ middle_end/flambda2.0/simplify/simplify_import.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ middle_end/flambda2.0/basic/scope.cmx \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmx \ + middle_end/flambda2.0/lifting/reification.cmx \ middle_end/flambda2.0/inlining/rec_info.cmx \ middle_end/flambda2.0/simplify/basic/reachable.cmx \ utils/profile.cmx \ @@ -6976,10 +7072,15 @@ middle_end/flambda2.0/simplify/simplify_named.rec.cmx : \ middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ middle_end/flambda2.0/basic/kinded_parameter.cmx \ middle_end/flambda2.0/inlining/inlining_decision.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/types/flambda_type.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ + middle_end/flambda2.0/terms/flambda.cmx \ middle_end/flambda2.0/basic/exn_continuation.cmx \ + middle_end/flambda2.0/simplify/env/downwards_acc.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/naming/bindable_let_bound.cmx \ @@ -6993,6 +7094,7 @@ middle_end/flambda2.0/simplify/simplify_named.rec.cmi : \ middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/naming/bindable_let_bound.cmi middle_end/flambda2.0/simplify/simplify_primitive.cmo : \ @@ -7040,67 +7142,33 @@ middle_end/flambda2.0/simplify/simplify_simple.cmi : \ middle_end/flambda2.0/naming/name_mode.cmi \ middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi -middle_end/flambda2.0/simplify/simplify_static.rec.cmo : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/utils/top_closure.cmi \ +middle_end/flambda2.0/simplify/simplify_static_const.rec.cmo : \ lambda/tag.cmi \ middle_end/flambda2.0/compilenv_deps/symbol.cmi \ middle_end/flambda2.0/simplify/simplify_import.cmi \ middle_end/flambda2.0/basic/simple.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmi \ - middle_end/flambda2.0/basic/parameter.cmi \ - middle_end/flambda2.0/naming/name_occurrences.cmi \ middle_end/flambda2.0/naming/name_mode.cmi \ middle_end/flambda2.0/naming/name_in_binding_pos.cmi \ - middle_end/flambda2.0/basic/name.cmi \ utils/misc.cmi \ - middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ - middle_end/flambda2.0/basic/immediate.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ - middle_end/flambda2.0/flambda2_backend_intf.cmi \ - middle_end/flambda2.0/basic/exn_continuation.cmi \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ - middle_end/flambda2.0/basic/continuation.cmi \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ - middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmi \ - middle_end/flambda2.0/simplify/simplify_static.rec.cmi -middle_end/flambda2.0/simplify/simplify_static.rec.cmx : \ - middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/utils/top_closure.cmx \ + middle_end/flambda2.0/simplify/simplify_static_const.rec.cmi +middle_end/flambda2.0/simplify/simplify_static_const.rec.cmx : \ lambda/tag.cmx \ middle_end/flambda2.0/compilenv_deps/symbol.cmx \ middle_end/flambda2.0/simplify/simplify_import.cmx \ middle_end/flambda2.0/basic/simple.cmx \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmx \ - middle_end/flambda2.0/basic/parameter.cmx \ - middle_end/flambda2.0/naming/name_occurrences.cmx \ middle_end/flambda2.0/naming/name_mode.cmx \ middle_end/flambda2.0/naming/name_in_binding_pos.cmx \ - middle_end/flambda2.0/basic/name.cmx \ utils/misc.cmx \ - middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ - middle_end/flambda2.0/basic/immediate.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ - middle_end/flambda2.0/flambda2_backend_intf.cmi \ - middle_end/flambda2.0/basic/exn_continuation.cmx \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmx \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ - middle_end/flambda2.0/basic/continuation.cmx \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ - middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmx \ - middle_end/flambda2.0/simplify/simplify_static.rec.cmi -middle_end/flambda2.0/simplify/simplify_static.rec.cmi : \ + middle_end/flambda2.0/simplify/simplify_static_const.rec.cmi +middle_end/flambda2.0/simplify/simplify_static_const.rec.cmi : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/compilenv_deps/symbol.cmi \ - middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/types/flambda_type.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ middle_end/flambda2.0/basic/closure_id.cmi @@ -7328,16 +7396,19 @@ middle_end/flambda2.0/simplify/env/continuation_uses_env_intf.cmx : \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmx middle_end/flambda2.0/simplify/env/downwards_acc.cmo : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ + middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi middle_end/flambda2.0/simplify/env/downwards_acc.cmx : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ + middle_end/flambda2.0/types/flambda_type.cmx \ middle_end/flambda2.0/simplify/env/continuation_uses_env.cmx \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi middle_end/flambda2.0/simplify/env/downwards_acc.cmi : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ middle_end/flambda2.0/simplify/env/continuation_uses_env_intf.cmo \ - middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi + middle_end/flambda2.0/simplify/env/continuation_uses_env.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ @@ -7354,11 +7425,13 @@ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmo : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ + middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/export_id.cmi \ middle_end/flambda2.0/basic/exn_continuation.cmi \ lambda/debuginfo.cmi \ middle_end/flambda2.0/simplify/basic/continuation_in_env.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmi \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx : \ @@ -7377,11 +7450,13 @@ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ middle_end/flambda2.0/flambda2_backend_intf.cmi \ + middle_end/flambda2.0/terms/flambda.cmx \ middle_end/flambda2.0/basic/export_id.cmx \ middle_end/flambda2.0/basic/exn_continuation.cmx \ lambda/debuginfo.cmx \ middle_end/flambda2.0/simplify/basic/continuation_in_env.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmx \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi : \ @@ -7405,6 +7480,7 @@ middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.cmo : \ lambda/debuginfo.cmi \ middle_end/flambda2.0/simplify/basic/continuation_in_env.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmi middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.cmx : \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ @@ -7425,18 +7501,24 @@ middle_end/flambda2.0/simplify/env/simplify_env_and_result_intf.cmx : \ lambda/debuginfo.cmx \ middle_end/flambda2.0/simplify/basic/continuation_in_env.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/simplify/basic/apply_cont_rewrite.cmx middle_end/flambda2.0/simplify/env/upwards_acc.cmo : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ + middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/simplify/env/upwards_acc.cmi middle_end/flambda2.0/simplify/env/upwards_acc.cmx : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ + middle_end/flambda2.0/types/flambda_type.cmx \ middle_end/flambda2.0/simplify/env/downwards_acc.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ middle_end/flambda2.0/simplify/env/upwards_acc.cmi middle_end/flambda2.0/simplify/env/upwards_acc.cmi : \ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmi + middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmo : \ middle_end/flambda2.0/basic/simple.cmi \ @@ -7532,47 +7614,6 @@ middle_end/flambda2.0/simplify/typing_helpers/one_continuation_use.cmi : \ middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmi \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi -middle_end/flambda2.0/simplify/typing_helpers/reification.cmo : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ - middle_end/flambda2.0/compilenv_deps/symbol.cmi \ - middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmi \ - middle_end/flambda2.0/basic/simple.cmi \ - middle_end/flambda2.0/simplify/basic/reachable.cmi \ - middle_end/flambda2.0/naming/name_mode.cmi \ - utils/misc.cmi \ - middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ - middle_end/flambda2.0/types/flambda_type.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ - middle_end/flambda2.0/terms/flambda.cmi \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmi \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmi -middle_end/flambda2.0/simplify/typing_helpers/reification.cmx : \ - middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ - middle_end/flambda2.0/compilenv_deps/symbol.cmx \ - middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmx \ - middle_end/flambda2.0/basic/simple.cmx \ - middle_end/flambda2.0/simplify/basic/reachable.cmx \ - middle_end/flambda2.0/naming/name_mode.cmx \ - utils/misc.cmx \ - middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ - middle_end/flambda2.0/types/flambda_type.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ - middle_end/flambda2.0/terms/flambda.cmx \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmx \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmi -middle_end/flambda2.0/simplify/typing_helpers/reification.cmi : \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ - middle_end/flambda2.0/simplify/basic/reachable.cmi \ - middle_end/flambda2.0/types/flambda_type.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ - middle_end/flambda2.0/simplify/env/downwards_acc.cmi middle_end/flambda2.0/terms/apply_cont_expr.cmo : \ middle_end/flambda2.0/basic/trap_action.cmi \ middle_end/flambda2.0/basic/simple.cmi \ @@ -7583,6 +7624,7 @@ middle_end/flambda2.0/terms/apply_cont_expr.cmo : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/terms/apply_cont_expr.cmi middle_end/flambda2.0/terms/apply_cont_expr.cmx : \ @@ -7595,12 +7637,14 @@ middle_end/flambda2.0/terms/apply_cont_expr.cmx : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ + lambda/debuginfo.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/terms/apply_cont_expr.cmi middle_end/flambda2.0/terms/apply_cont_expr.cmi : \ middle_end/flambda2.0/basic/trap_action.cmi \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/basic/expr_std.cmo \ + lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi middle_end/flambda2.0/terms/apply_expr.cmo : \ middle_end/flambda2.0/basic/simple.cmi \ @@ -7648,6 +7692,7 @@ middle_end/flambda2.0/terms/call_kind.cmo : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/terms/call_kind.cmi middle_end/flambda2.0/terms/call_kind.cmx : \ @@ -7658,12 +7703,14 @@ middle_end/flambda2.0/terms/call_kind.cmx : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ middle_end/flambda2.0/terms/call_kind.cmi middle_end/flambda2.0/terms/call_kind.cmi : \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/basic/expr_std.cmo \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi middle_end/flambda2.0/terms/continuation_handler.rec.cmo : \ middle_end/flambda2.0/basic/simple.cmi \ @@ -7766,12 +7813,13 @@ middle_end/flambda2.0/terms/expr.rec.cmi : \ middle_end/flambda2.0/naming/bindable_let_bound.cmi middle_end/flambda2.0/terms/flambda.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ - middle_end/flambda2.0/types/type_system_intf.cmo \ utils/targetint.cmi \ + lambda/tag.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ middle_end/flambda2.0/terms/switch_expr.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ middle_end/flambda2.0/basic/recursive.cmi \ utils/printing_cache.cmi \ middle_end/flambda2.0/basic/parameter.cmi \ @@ -7785,9 +7833,11 @@ middle_end/flambda2.0/terms/flambda.cmo : \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ middle_end/flambda2.0/basic/invariant_env.cmi \ middle_end/flambda2.0/basic/invalid_term_semantics.cmi \ - middle_end/flambda2.0/basic/inline_attribute.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ - middle_end/flambda2.0/types/flambda_type0.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ + middle_end/flambda2.0/types/flambda_type.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ @@ -7797,7 +7847,7 @@ middle_end/flambda2.0/terms/flambda.cmo : \ lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/naming/contains_names.cmo \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ utils/clflags.cmi \ @@ -7809,12 +7859,13 @@ middle_end/flambda2.0/terms/flambda.cmo : \ middle_end/flambda2.0/terms/flambda.cmi middle_end/flambda2.0/terms/flambda.cmx : \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/basic/var_within_closure.cmx \ middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ - middle_end/flambda2.0/types/type_system_intf.cmx \ utils/targetint.cmx \ + lambda/tag.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ middle_end/flambda2.0/terms/switch_expr.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ middle_end/flambda2.0/basic/recursive.cmx \ utils/printing_cache.cmx \ middle_end/flambda2.0/basic/parameter.cmx \ @@ -7828,9 +7879,11 @@ middle_end/flambda2.0/terms/flambda.cmx : \ middle_end/flambda2.0/basic/kinded_parameter.cmx \ middle_end/flambda2.0/basic/invariant_env.cmx \ middle_end/flambda2.0/basic/invalid_term_semantics.cmx \ - middle_end/flambda2.0/basic/inline_attribute.cmx \ middle_end/flambda2.0/basic/immediate.cmx \ - middle_end/flambda2.0/types/flambda_type0.cmx \ + utils/identifiable.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ + middle_end/flambda2.0/types/flambda_type.cmx \ middle_end/flambda2.0/terms/flambda_primitive.cmx \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ @@ -7840,7 +7893,7 @@ middle_end/flambda2.0/terms/flambda.cmx : \ lambda/debuginfo.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/naming/contains_names.cmx \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmx \ middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ utils/clflags.cmx \ @@ -7852,18 +7905,22 @@ middle_end/flambda2.0/terms/flambda.cmx : \ middle_end/flambda2.0/terms/flambda.cmi middle_end/flambda2.0/terms/flambda.cmi : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ - middle_end/flambda2.0/types/type_system_intf.cmo \ + utils/targetint.cmi \ + lambda/tag.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ middle_end/flambda2.0/terms/switch_expr.cmi \ middle_end/flambda2.0/basic/simple.cmi \ - middle_end/flambda2.0/basic/recursive.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + utils/numbers.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi \ middle_end/flambda2.0/basic/name.cmi \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ middle_end/flambda2.0/basic/invalid_term_semantics.cmi \ - middle_end/flambda2.0/basic/inline_attribute.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ @@ -7871,6 +7928,8 @@ middle_end/flambda2.0/terms/flambda.cmi : \ middle_end/flambda2.0/basic/exn_continuation.cmi \ lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/naming/contains_names.cmo \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/naming/bindable_let_bound.cmi \ @@ -7925,116 +7984,74 @@ middle_end/flambda2.0/terms/flambda_primitive.cmi : \ middle_end/flambda2.0/naming/contains_names.cmo \ middle_end/flambda2.0/basic/coeffects.cmi \ middle_end/flambda2.0/basic/closure_id.cmi -middle_end/flambda2.0/terms/flambda_static.cmo : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/basic/var_within_closure.cmi \ - utils/targetint.cmi \ - lambda/tag.cmi \ +middle_end/flambda2.0/terms/flambda_unit.cmo : \ middle_end/flambda2.0/compilenv_deps/symbol.cmi \ - utils/printing_cache.cmi \ - utils/numbers.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi \ - middle_end/flambda2.0/naming/name_mode.cmi \ - utils/misc.cmi \ - middle_end/flambda2.0/basic/kinded_parameter.cmi \ - middle_end/flambda2.0/basic/invariant_env.cmi \ - middle_end/flambda2.0/basic/immediate.cmi \ - utils/identifiable.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ - middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ - middle_end/flambda2.0/basic/exn_continuation.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ - middle_end/flambda2.0/basic/closure_id.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi -middle_end/flambda2.0/terms/flambda_static.cmx : \ - middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/basic/var_within_closure.cmx \ - utils/targetint.cmx \ - lambda/tag.cmx \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi +middle_end/flambda2.0/terms/flambda_unit.cmx : \ middle_end/flambda2.0/compilenv_deps/symbol.cmx \ - utils/printing_cache.cmx \ - utils/numbers.cmx \ middle_end/flambda2.0/naming/name_occurrences.cmx \ - middle_end/flambda2.0/naming/name_mode.cmx \ - utils/misc.cmx \ - middle_end/flambda2.0/basic/kinded_parameter.cmx \ - middle_end/flambda2.0/basic/invariant_env.cmx \ - middle_end/flambda2.0/basic/immediate.cmx \ - utils/identifiable.cmx \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ - middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/terms/flambda.cmx \ - middle_end/flambda2.0/basic/exn_continuation.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ - middle_end/flambda2.0/basic/closure_id.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmi -middle_end/flambda2.0/terms/flambda_static.cmi : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmi +middle_end/flambda2.0/terms/flambda_unit.cmi : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ - utils/targetint.cmi \ - lambda/tag.cmi \ middle_end/flambda2.0/compilenv_deps/symbol.cmi \ - utils/numbers.cmi \ - middle_end/flambda2.0/naming/name_occurrences.cmi \ - middle_end/flambda2.0/basic/kinded_parameter.cmi \ - middle_end/flambda2.0/basic/immediate.cmi \ - utils/identifiable.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ - middle_end/flambda2.0/basic/exn_continuation.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/basic/closure_id.cmi -middle_end/flambda2.0/terms/function_declaration.rec.cmo : \ +middle_end/flambda2.0/terms/function_declaration.cmo : \ middle_end/flambda2.0/basic/recursive.cmi \ utils/printing_cache.cmi \ - middle_end/flambda2.0/basic/parameter.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/naming/name_mode.cmi \ utils/misc.cmi \ - middle_end/flambda2.0/basic/kinded_parameter.cmi \ middle_end/flambda2.0/basic/inline_attribute.cmi \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ - middle_end/flambda2.0/basic/exn_continuation.cmi \ lambda/debuginfo.cmi \ - middle_end/flambda2.0/basic/continuation.cmi \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ middle_end/flambda2.0/basic/code_id.cmi \ - middle_end/flambda2.0/terms/function_declaration.rec.cmi -middle_end/flambda2.0/terms/function_declaration.rec.cmx : \ + middle_end/flambda2.0/terms/function_declaration.cmi +middle_end/flambda2.0/terms/function_declaration.cmx : \ middle_end/flambda2.0/basic/recursive.cmx \ utils/printing_cache.cmx \ - middle_end/flambda2.0/basic/parameter.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/naming/name_mode.cmx \ utils/misc.cmx \ - middle_end/flambda2.0/basic/kinded_parameter.cmx \ middle_end/flambda2.0/basic/inline_attribute.cmx \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ - middle_end/flambda2.0/basic/exn_continuation.cmx \ lambda/debuginfo.cmx \ - middle_end/flambda2.0/basic/continuation.cmx \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ middle_end/flambda2.0/basic/code_id.cmx \ - middle_end/flambda2.0/terms/function_declaration.rec.cmi -middle_end/flambda2.0/terms/function_declaration.rec.cmi : \ + middle_end/flambda2.0/terms/function_declaration.cmi +middle_end/flambda2.0/terms/function_declaration.cmi : \ middle_end/flambda2.0/basic/recursive.cmi \ middle_end/flambda2.0/basic/inline_attribute.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/basic/expr_std.cmo \ lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/code_id.cmi -middle_end/flambda2.0/terms/function_declarations.rec.cmo : \ +middle_end/flambda2.0/terms/function_declarations.cmo : \ utils/printing_cache.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ - middle_end/flambda2.0/terms/function_declarations.rec.cmi -middle_end/flambda2.0/terms/function_declarations.rec.cmx : \ + middle_end/flambda2.0/terms/function_declarations.cmi +middle_end/flambda2.0/terms/function_declarations.cmx : \ utils/printing_cache.cmx \ middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ - middle_end/flambda2.0/terms/function_declarations.rec.cmi -middle_end/flambda2.0/terms/function_declarations.rec.cmi : \ + middle_end/flambda2.0/terms/function_declarations.cmi +middle_end/flambda2.0/terms/function_declarations.cmi : \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/basic/expr_std.cmo \ middle_end/flambda2.0/basic/closure_id.cmi middle_end/flambda2.0/terms/function_params_and_body.rec.cmo : \ @@ -8042,7 +8059,11 @@ middle_end/flambda2.0/terms/function_params_and_body.rec.cmo : \ middle_end/flambda2.0/basic/parameter.cmi \ middle_end/flambda2.0/naming/name_abstraction.cmi \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ + middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + middle_end/flambda2.0/basic/exn_continuation.cmi \ + middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/naming/bindable_exn_continuation.cmi \ middle_end/flambda2.0/naming/bindable_continuation.cmi \ middle_end/flambda2.0/terms/function_params_and_body.rec.cmi @@ -8051,7 +8072,11 @@ middle_end/flambda2.0/terms/function_params_and_body.rec.cmx : \ middle_end/flambda2.0/basic/parameter.cmx \ middle_end/flambda2.0/naming/name_abstraction.cmx \ middle_end/flambda2.0/basic/kinded_parameter.cmx \ + middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ + middle_end/flambda2.0/basic/exn_continuation.cmx \ + middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/naming/bindable_exn_continuation.cmx \ middle_end/flambda2.0/naming/bindable_continuation.cmx \ middle_end/flambda2.0/terms/function_params_and_body.rec.cmi @@ -8115,9 +8140,41 @@ middle_end/flambda2.0/terms/let_expr.rec.cmx : \ middle_end/flambda2.0/terms/let_expr.rec.cmi : \ middle_end/flambda2.0/basic/expr_std.cmo \ middle_end/flambda2.0/naming/bindable_let_bound.cmi +middle_end/flambda2.0/terms/let_symbol_expr.rec.cmo : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + utils/printing_cache.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/naming/name_mode.cmi \ + utils/misc.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi \ + middle_end/flambda2.0/terms/let_symbol_expr.rec.cmi +middle_end/flambda2.0/terms/let_symbol_expr.rec.cmx : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + utils/printing_cache.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/naming/name_mode.cmx \ + utils/misc.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/basic/closure_id.cmx \ + middle_end/flambda2.0/terms/let_symbol_expr.rec.cmi +middle_end/flambda2.0/terms/let_symbol_expr.rec.cmi : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + middle_end/flambda2.0/basic/expr_std.cmo \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi middle_end/flambda2.0/terms/named.rec.cmo : \ utils/targetint.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ utils/printing_cache.cmi \ utils/numbers.cmi \ utils/misc.cmi \ @@ -8131,6 +8188,7 @@ middle_end/flambda2.0/terms/named.rec.cmo : \ middle_end/flambda2.0/terms/named.rec.cmx : \ utils/targetint.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ utils/printing_cache.cmx \ utils/numbers.cmx \ utils/misc.cmx \ @@ -8143,6 +8201,7 @@ middle_end/flambda2.0/terms/named.rec.cmx : \ middle_end/flambda2.0/terms/named.rec.cmi middle_end/flambda2.0/terms/named.rec.cmi : \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ middle_end/flambda2.0/basic/name.cmi \ middle_end/flambda2.0/basic/invariant_env.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ @@ -8180,24 +8239,81 @@ middle_end/flambda2.0/terms/recursive_let_cont_handlers.rec.cmx : \ middle_end/flambda2.0/terms/recursive_let_cont_handlers.rec.cmi middle_end/flambda2.0/terms/recursive_let_cont_handlers.rec.cmi : \ middle_end/flambda2.0/basic/expr_std.cmo -middle_end/flambda2.0/terms/set_of_closures.rec.cmo : \ +middle_end/flambda2.0/terms/set_of_closures.cmo : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/basic/simple.cmi \ utils/printing_cache.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi \ + utils/misc.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ - middle_end/flambda2.0/terms/set_of_closures.rec.cmi -middle_end/flambda2.0/terms/set_of_closures.rec.cmx : \ + middle_end/flambda2.0/terms/set_of_closures.cmi +middle_end/flambda2.0/terms/set_of_closures.cmx : \ middle_end/flambda2.0/basic/var_within_closure.cmx \ middle_end/flambda2.0/basic/simple.cmx \ utils/printing_cache.cmx \ middle_end/flambda2.0/naming/name_occurrences.cmx \ + utils/misc.cmx \ + utils/identifiable.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ - middle_end/flambda2.0/terms/set_of_closures.rec.cmi -middle_end/flambda2.0/terms/set_of_closures.rec.cmi : \ + middle_end/flambda2.0/terms/set_of_closures.cmi +middle_end/flambda2.0/terms/set_of_closures.cmi : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/basic/simple.cmi \ - middle_end/flambda2.0/basic/expr_std.cmo + utils/identifiable.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ + middle_end/flambda2.0/basic/expr_std.cmo \ + middle_end/flambda2.0/basic/closure_id.cmi +middle_end/flambda2.0/terms/static_const.rec.cmo : \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + utils/targetint.cmi \ + lambda/tag.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + utils/printing_cache.cmi \ + utils/numbers.cmi \ + middle_end/flambda2.0/naming/name_permutation.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/naming/name_mode.cmi \ + utils/misc.cmi \ + middle_end/flambda2.0/basic/immediate.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/terms/static_const.rec.cmi +middle_end/flambda2.0/terms/static_const.rec.cmx : \ + middle_end/flambda2.0/compilenv_deps/variable.cmx \ + utils/targetint.cmx \ + lambda/tag.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + utils/printing_cache.cmx \ + utils/numbers.cmx \ + middle_end/flambda2.0/naming/name_permutation.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/naming/name_mode.cmx \ + utils/misc.cmx \ + middle_end/flambda2.0/basic/immediate.cmx \ + utils/identifiable.cmx \ + middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ + middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/terms/static_const.rec.cmi +middle_end/flambda2.0/terms/static_const.rec.cmi : \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + utils/targetint.cmi \ + lambda/tag.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + utils/numbers.cmi \ + middle_end/flambda2.0/basic/immediate.cmi \ + utils/identifiable.cmi \ + middle_end/flambda2.0/naming/contains_names.cmo \ + middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/terms/switch_expr.cmo : \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/naming/name_permutation.cmi \ @@ -8231,14 +8347,16 @@ middle_end/flambda2.0/to_cmm/un_cps.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_static.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmi \ middle_end/flambda2.0/to_cmm/un_cps_helper.cmi \ middle_end/flambda2.0/to_cmm/un_cps_env.cmi \ middle_end/flambda2.0/to_cmm/un_cps_closure.cmi \ utils/targetint.cmi \ - lambda/tag.cmi \ middle_end/flambda2.0/compilenv_deps/symbol.cmi \ lambda/switch.cmi \ middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ utils/profile.cmi \ asmcomp/printcmm.cmi \ typing/primitive.cmi \ @@ -8254,7 +8372,9 @@ middle_end/flambda2.0/to_cmm/un_cps.cmo : \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ typing/ident.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ @@ -8263,10 +8383,9 @@ middle_end/flambda2.0/to_cmm/un_cps.cmo : \ middle_end/flambda2.0/basic/effects_and_coeffects.cmi \ lambda/debuginfo.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ - utils/config.cmi \ middle_end/compilenv.cmi \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ - asmcomp/cmmgen_state.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ asmcomp/cmm_helpers.cmi \ asmcomp/cmm.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ @@ -8281,14 +8400,16 @@ middle_end/flambda2.0/to_cmm/un_cps.cmx : \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ middle_end/flambda2.0/basic/var_within_closure.cmx \ middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_static.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmx \ middle_end/flambda2.0/to_cmm/un_cps_helper.cmx \ middle_end/flambda2.0/to_cmm/un_cps_env.cmx \ middle_end/flambda2.0/to_cmm/un_cps_closure.cmx \ utils/targetint.cmx \ - lambda/tag.cmx \ middle_end/flambda2.0/compilenv_deps/symbol.cmx \ lambda/switch.cmx \ middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ utils/profile.cmx \ asmcomp/printcmm.cmx \ typing/primitive.cmx \ @@ -8304,7 +8425,9 @@ middle_end/flambda2.0/to_cmm/un_cps.cmx : \ middle_end/flambda2.0/basic/kinded_parameter.cmx \ middle_end/flambda2.0/basic/immediate.cmx \ typing/ident.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/terms/flambda_primitive.cmx \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ @@ -8313,10 +8436,9 @@ middle_end/flambda2.0/to_cmm/un_cps.cmx : \ middle_end/flambda2.0/basic/effects_and_coeffects.cmx \ lambda/debuginfo.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ - utils/config.cmx \ middle_end/compilenv.cmx \ - middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ - asmcomp/cmmgen_state.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ asmcomp/cmm_helpers.cmx \ asmcomp/cmm.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ @@ -8328,36 +8450,37 @@ middle_end/flambda2.0/to_cmm/un_cps.cmx : \ middle_end/flambda2.0/terms/apply_cont_expr.cmx \ middle_end/flambda2.0/to_cmm/un_cps.cmi middle_end/flambda2.0/to_cmm/un_cps.cmi : \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ asmcomp/cmm.cmi middle_end/flambda2.0/to_cmm/un_cps_closure.cmo : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ utils/numbers.cmi \ - middle_end/flambda2.0/naming/name_occurrences.cmi \ utils/misc.cmi \ middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ - middle_end/flambda2.0/basic/continuation.cmi \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/flambda2.0/to_cmm/un_cps_closure.cmi middle_end/flambda2.0/to_cmm/un_cps_closure.cmx : \ middle_end/flambda2.0/basic/var_within_closure.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ utils/numbers.cmx \ - middle_end/flambda2.0/naming/name_occurrences.cmx \ utils/misc.cmx \ middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ - middle_end/flambda2.0/terms/flambda_static.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ + middle_end/flambda2.0/terms/flambda_unit.cmx \ middle_end/flambda2.0/terms/flambda.cmx \ - middle_end/flambda2.0/basic/continuation.cmx \ middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ middle_end/flambda2.0/to_cmm/un_cps_closure.cmi middle_end/flambda2.0/to_cmm/un_cps_closure.cmi : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ - middle_end/flambda2.0/terms/flambda_static.cmi \ - middle_end/flambda2.0/terms/flambda.cmi \ + middle_end/flambda2.0/terms/flambda_unit.cmi \ middle_end/flambda2.0/basic/closure_id.cmi middle_end/flambda2.0/to_cmm/un_cps_env.cmo : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ @@ -8370,6 +8493,8 @@ middle_end/flambda2.0/to_cmm/un_cps_env.cmo : \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/effects_and_coeffects.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ asmcomp/cmm.cmi \ middle_end/backend_var.cmi \ middle_end/flambda2.0/to_cmm/un_cps_env.cmi @@ -8384,6 +8509,8 @@ middle_end/flambda2.0/to_cmm/un_cps_env.cmx : \ middle_end/flambda2.0/terms/flambda.cmx \ middle_end/flambda2.0/basic/effects_and_coeffects.cmx \ middle_end/flambda2.0/basic/continuation.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ asmcomp/cmm.cmx \ middle_end/backend_var.cmx \ middle_end/flambda2.0/to_cmm/un_cps_env.cmi @@ -8396,10 +8523,13 @@ middle_end/flambda2.0/to_cmm/un_cps_env.cmi : \ middle_end/flambda2.0/terms/flambda.cmi \ middle_end/flambda2.0/basic/effects_and_coeffects.cmi \ middle_end/flambda2.0/basic/continuation.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ asmcomp/cmm.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ middle_end/backend_var.cmi middle_end/flambda2.0/to_cmm/un_cps_helper.cmo : \ + middle_end/flambda2.0/basic/trap_action.cmi \ utils/targetint.cmi \ lambda/tag.cmi \ typing/primitive.cmi \ @@ -8417,6 +8547,7 @@ middle_end/flambda2.0/to_cmm/un_cps_helper.cmo : \ asmcomp/arch.cmo \ middle_end/flambda2.0/to_cmm/un_cps_helper.cmi middle_end/flambda2.0/to_cmm/un_cps_helper.cmx : \ + middle_end/flambda2.0/basic/trap_action.cmx \ utils/targetint.cmx \ lambda/tag.cmx \ typing/primitive.cmx \ @@ -8434,6 +8565,7 @@ middle_end/flambda2.0/to_cmm/un_cps_helper.cmx : \ asmcomp/arch.cmx \ middle_end/flambda2.0/to_cmm/un_cps_helper.cmi middle_end/flambda2.0/to_cmm/un_cps_helper.cmi : \ + middle_end/flambda2.0/basic/trap_action.cmi \ utils/targetint.cmi \ typing/primitive.cmi \ lambda/lambda.cmi \ @@ -8443,15 +8575,90 @@ middle_end/flambda2.0/to_cmm/un_cps_helper.cmi : \ asmcomp/cmm.cmi \ middle_end/backend_var.cmi \ parsing/asttypes.cmi -middle_end/flambda2.0/types/flambda_type.cmo : \ +middle_end/flambda2.0/to_cmm/un_cps_result.cmo : \ + middle_end/flambda2.0/to_cmm/un_cps_helper.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + asmcomp/cmm_helpers.cmi \ + asmcomp/cmm.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmi +middle_end/flambda2.0/to_cmm/un_cps_result.cmx : \ + middle_end/flambda2.0/to_cmm/un_cps_helper.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + asmcomp/cmm_helpers.cmx \ + asmcomp/cmm.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmi +middle_end/flambda2.0/to_cmm/un_cps_result.cmi : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + asmcomp/cmm.cmi +middle_end/flambda2.0/to_cmm/un_cps_static.cmo : \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + middle_end/flambda2.0/basic/var_within_closure.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_helper.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_env.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_closure.cmi \ + utils/targetint.cmi \ + lambda/tag.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/terms/set_of_closures.cmi \ + utils/numbers.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/basic/name.cmi \ + utils/misc.cmi \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ + lambda/lambda.cmi \ + middle_end/flambda2.0/basic/immediate.cmi \ + middle_end/flambda2.0/terms/function_declarations.cmi \ + middle_end/flambda2.0/terms/function_declaration.cmi \ middle_end/flambda2.0/terms/flambda.cmi \ - middle_end/flambda2.0/types/flambda_type.cmi -middle_end/flambda2.0/types/flambda_type.cmx : \ + lambda/debuginfo.cmi \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + asmcomp/cmmgen_state.cmi \ + asmcomp/cmm_helpers.cmi \ + asmcomp/cmm.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_static.cmi +middle_end/flambda2.0/to_cmm/un_cps_static.cmx : \ + middle_end/flambda2.0/compilenv_deps/variable.cmx \ + middle_end/flambda2.0/basic/var_within_closure.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_helper.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_env.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_closure.cmx \ + utils/targetint.cmx \ + lambda/tag.cmx \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ + middle_end/flambda2.0/basic/simple.cmx \ + middle_end/flambda2.0/terms/set_of_closures.cmx \ + utils/numbers.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/basic/name.cmx \ + utils/misc.cmx \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ + lambda/lambda.cmx \ + middle_end/flambda2.0/basic/immediate.cmx \ + middle_end/flambda2.0/terms/function_declarations.cmx \ + middle_end/flambda2.0/terms/function_declaration.cmx \ middle_end/flambda2.0/terms/flambda.cmx \ - middle_end/flambda2.0/types/flambda_type.cmi -middle_end/flambda2.0/types/flambda_type.cmi : \ - middle_end/flambda2.0/terms/flambda.cmi -middle_end/flambda2.0/types/flambda_type0.cmo : \ + lambda/debuginfo.cmx \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + asmcomp/cmmgen_state.cmx \ + asmcomp/cmm_helpers.cmx \ + asmcomp/cmm.cmx \ + middle_end/flambda2.0/basic/closure_id.cmx \ + middle_end/flambda2.0/to_cmm/un_cps_static.cmi +middle_end/flambda2.0/to_cmm/un_cps_static.cmi : \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmi \ + middle_end/flambda2.0/to_cmm/un_cps_env.cmi \ + middle_end/flambda2.0/terms/flambda.cmi \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi +middle_end/flambda2.0/types/flambda_type.cmo : \ middle_end/flambda2.0/naming/with_delayed_permutation.cmi \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi \ @@ -8459,7 +8666,6 @@ middle_end/flambda2.0/types/flambda_type0.cmo : \ middle_end/flambda2.0/types/structures/type_structure_intf.cmo \ middle_end/flambda2.0/types/type_head_intf.cmo \ middle_end/flambda2.0/types/type_descr_intf.cmo \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo \ utils/targetint.cmi \ middle_end/flambda2.0/types/basic/tag_or_unknown_and_size.cmi \ middle_end/flambda2.0/types/basic/tag_and_size.cmi \ @@ -8490,6 +8696,7 @@ middle_end/flambda2.0/types/flambda_type0.cmo : \ middle_end/flambda2.0/types/basic/meet_or_join_op.cmi \ middle_end/flambda2.0/types/structures/lattice_ops_intf.cmo \ middle_end/flambda2.0/basic/kinded_parameter.cmi \ + middle_end/flambda2.0/basic/inline_attribute.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ utils/identifiable.cmi \ middle_end/flambda2.0/terms/flambda_primitive.cmi \ @@ -8497,10 +8704,12 @@ middle_end/flambda2.0/types/flambda_type0.cmo : \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ middle_end/flambda2.0/basic/export_id.cmi \ + lambda/debuginfo.cmi \ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmi \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ middle_end/flambda2.0/naming/contains_names.cmo \ middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/types/env/binding_time.cmi \ @@ -8508,8 +8717,8 @@ middle_end/flambda2.0/types/flambda_type0.cmo : \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi \ middle_end/flambda2.0/types/env/aliases.cmi \ middle_end/flambda2.0/types/env/alias.cmi \ - middle_end/flambda2.0/types/flambda_type0.cmi -middle_end/flambda2.0/types/flambda_type0.cmx : \ + middle_end/flambda2.0/types/flambda_type.cmi +middle_end/flambda2.0/types/flambda_type.cmx : \ middle_end/flambda2.0/naming/with_delayed_permutation.cmx \ middle_end/flambda2.0/compilenv_deps/variable.cmx \ middle_end/flambda2.0/basic/var_within_closure.cmx \ @@ -8517,7 +8726,6 @@ middle_end/flambda2.0/types/flambda_type0.cmx : \ middle_end/flambda2.0/types/structures/type_structure_intf.cmx \ middle_end/flambda2.0/types/type_head_intf.cmx \ middle_end/flambda2.0/types/type_descr_intf.cmx \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmx \ utils/targetint.cmx \ middle_end/flambda2.0/types/basic/tag_or_unknown_and_size.cmx \ middle_end/flambda2.0/types/basic/tag_and_size.cmx \ @@ -8548,6 +8756,7 @@ middle_end/flambda2.0/types/flambda_type0.cmx : \ middle_end/flambda2.0/types/basic/meet_or_join_op.cmx \ middle_end/flambda2.0/types/structures/lattice_ops_intf.cmx \ middle_end/flambda2.0/basic/kinded_parameter.cmx \ + middle_end/flambda2.0/basic/inline_attribute.cmx \ middle_end/flambda2.0/basic/immediate.cmx \ utils/identifiable.cmx \ middle_end/flambda2.0/terms/flambda_primitive.cmx \ @@ -8555,10 +8764,12 @@ middle_end/flambda2.0/types/flambda_type0.cmx : \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ middle_end/flambda2.0/basic/export_id.cmx \ + lambda/debuginfo.cmx \ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmx \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ middle_end/flambda2.0/naming/contains_names.cmx \ middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/types/env/binding_time.cmx \ @@ -8566,10 +8777,41 @@ middle_end/flambda2.0/types/flambda_type0.cmx : \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmx \ middle_end/flambda2.0/types/env/aliases.cmx \ middle_end/flambda2.0/types/env/alias.cmx \ - middle_end/flambda2.0/types/flambda_type0.cmi -middle_end/flambda2.0/types/flambda_type0.cmi : \ - middle_end/flambda2.0/types/type_system_intf.cmo \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo + middle_end/flambda2.0/types/flambda_type.cmi +middle_end/flambda2.0/types/flambda_type.cmi : \ + middle_end/flambda2.0/compilenv_deps/variable.cmi \ + middle_end/flambda2.0/basic/var_within_closure.cmi \ + middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ + utils/targetint.cmi \ + lambda/tag.cmi \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ + middle_end/flambda2.0/types/basic/string_info.cmi \ + middle_end/flambda2.0/basic/simple.cmi \ + middle_end/flambda2.0/basic/scope.cmi \ + middle_end/flambda2.0/basic/recursive.cmi \ + middle_end/flambda2.0/inlining/rec_info.cmi \ + utils/printing_cache.cmi \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi \ + middle_end/flambda2.0/types/basic/or_bottom.cmi \ + utils/numbers.cmi \ + middle_end/flambda2.0/naming/name_mode.cmi \ + middle_end/flambda2.0/naming/name_in_binding_pos.cmi \ + middle_end/flambda2.0/basic/name.cmi \ + middle_end/flambda2.0/basic/kinded_parameter.cmi \ + middle_end/flambda2.0/basic/invariant_env.cmi \ + middle_end/flambda2.0/basic/inline_attribute.cmi \ + middle_end/flambda2.0/basic/immediate.cmi \ + middle_end/flambda2.0/terms/flambda_primitive.cmi \ + middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ + middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + middle_end/flambda2.0/basic/export_id.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda2.0/simplify/env/continuation_use_kind.cmi \ + middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ + middle_end/flambda2.0/basic/closure_id.cmi \ + middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi middle_end/flambda2.0/types/resolved_type.rec.cmo : \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi \ @@ -8642,7 +8884,7 @@ middle_end/flambda2.0/types/type_grammar.rec.cmo : \ middle_end/flambda2.0/basic/simple.cmi \ middle_end/flambda2.0/types/structures/set_of_closures_contents.cmi \ utils/printing_cache.cmi \ - middle_end/flambda2.0/types/basic/or_unknown.cmi \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi \ middle_end/flambda2.0/types/basic/or_bottom.cmi \ middle_end/flambda2.0/naming/name_permutation.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi \ @@ -8662,7 +8904,7 @@ middle_end/flambda2.0/types/type_grammar.rec.cmx : \ middle_end/flambda2.0/basic/simple.cmx \ middle_end/flambda2.0/types/structures/set_of_closures_contents.cmx \ utils/printing_cache.cmx \ - middle_end/flambda2.0/types/basic/or_unknown.cmx \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmx \ middle_end/flambda2.0/types/basic/or_bottom.cmx \ middle_end/flambda2.0/naming/name_permutation.cmx \ middle_end/flambda2.0/naming/name_occurrences.cmx \ @@ -8677,7 +8919,6 @@ middle_end/flambda2.0/types/type_grammar.rec.cmx : \ middle_end/flambda2.0/types/type_grammar.rec.cmi : \ middle_end/flambda2.0/compilenv_deps/variable.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo \ utils/targetint.cmi \ lambda/tag.cmi \ middle_end/flambda2.0/basic/simple.cmi \ @@ -8687,10 +8928,13 @@ middle_end/flambda2.0/types/type_grammar.rec.cmi : \ middle_end/flambda2.0/types/basic/or_bottom.cmi \ utils/numbers.cmi \ middle_end/flambda2.0/basic/name.cmi \ + middle_end/flambda2.0/basic/inline_attribute.cmi \ middle_end/flambda2.0/basic/immediate.cmi \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + lambda/debuginfo.cmi \ middle_end/flambda2.0/naming/contains_names.cmo \ + middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi middle_end/flambda2.0/types/type_head_intf.cmo : \ middle_end/flambda2.0/inlining/rec_info.cmi \ @@ -8706,66 +8950,6 @@ middle_end/flambda2.0/types/type_head_intf.cmx : \ middle_end/flambda2.0/types/basic/or_bottom.cmx \ middle_end/flambda2.0/types/structures/lattice_ops_intf.cmx \ middle_end/flambda2.0/naming/contains_names.cmx -middle_end/flambda2.0/types/type_system_intf.cmo : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/basic/var_within_closure.cmi \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmi \ - utils/targetint.cmi \ - lambda/tag.cmi \ - middle_end/flambda2.0/compilenv_deps/symbol.cmi \ - middle_end/flambda2.0/types/basic/string_info.cmi \ - middle_end/flambda2.0/basic/simple.cmi \ - middle_end/flambda2.0/basic/scope.cmi \ - middle_end/flambda2.0/basic/recursive.cmi \ - middle_end/flambda2.0/inlining/rec_info.cmi \ - utils/printing_cache.cmi \ - middle_end/flambda2.0/types/basic/or_unknown.cmi \ - middle_end/flambda2.0/types/basic/or_bottom.cmi \ - utils/numbers.cmi \ - middle_end/flambda2.0/naming/name_mode.cmi \ - middle_end/flambda2.0/naming/name_in_binding_pos.cmi \ - middle_end/flambda2.0/basic/name.cmi \ - middle_end/flambda2.0/basic/kinded_parameter.cmi \ - middle_end/flambda2.0/basic/invariant_env.cmi \ - middle_end/flambda2.0/basic/immediate.cmi \ - middle_end/flambda2.0/terms/flambda_primitive.cmi \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ - middle_end/flambda2.0/basic/export_id.cmi \ - middle_end/flambda2.0/simplify/env/continuation_use_kind.cmi \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ - middle_end/flambda2.0/basic/closure_id.cmi \ - middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi -middle_end/flambda2.0/types/type_system_intf.cmx : \ - middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/basic/var_within_closure.cmx \ - middle_end/flambda2.0/naming/var_in_binding_pos.cmx \ - utils/targetint.cmx \ - lambda/tag.cmx \ - middle_end/flambda2.0/compilenv_deps/symbol.cmx \ - middle_end/flambda2.0/types/basic/string_info.cmx \ - middle_end/flambda2.0/basic/simple.cmx \ - middle_end/flambda2.0/basic/scope.cmx \ - middle_end/flambda2.0/basic/recursive.cmx \ - middle_end/flambda2.0/inlining/rec_info.cmx \ - utils/printing_cache.cmx \ - middle_end/flambda2.0/types/basic/or_unknown.cmx \ - middle_end/flambda2.0/types/basic/or_bottom.cmx \ - utils/numbers.cmx \ - middle_end/flambda2.0/naming/name_mode.cmx \ - middle_end/flambda2.0/naming/name_in_binding_pos.cmx \ - middle_end/flambda2.0/basic/name.cmx \ - middle_end/flambda2.0/basic/kinded_parameter.cmx \ - middle_end/flambda2.0/basic/invariant_env.cmx \ - middle_end/flambda2.0/basic/immediate.cmx \ - middle_end/flambda2.0/terms/flambda_primitive.cmx \ - middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ - middle_end/flambda2.0/basic/export_id.cmx \ - middle_end/flambda2.0/simplify/env/continuation_use_kind.cmx \ - middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmx \ - middle_end/flambda2.0/basic/closure_id.cmx \ - middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmx middle_end/flambda2.0/types/basic/closure_id_and_var_within_closure_set.cmo : \ middle_end/flambda2.0/types/basic/var_within_closure_set.cmi \ middle_end/flambda2.0/basic/var_within_closure.cmi \ @@ -8859,10 +9043,13 @@ middle_end/flambda2.0/types/basic/or_unknown.cmi : \ middle_end/flambda2.0/naming/name_occurrences.cmi \ utils/identifiable.cmi middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmo : \ + middle_end/flambda2.0/types/basic/or_unknown.cmi \ middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmx : \ + middle_end/flambda2.0/types/basic/or_unknown.cmx \ middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi -middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi : +middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi : \ + middle_end/flambda2.0/types/basic/or_unknown.cmi middle_end/flambda2.0/types/basic/string_info.cmo : \ utils/targetint.cmi \ utils/misc.cmi \ @@ -8907,12 +9094,6 @@ middle_end/flambda2.0/types/basic/tag_or_unknown_and_size.cmi : \ lambda/tag.cmi \ middle_end/flambda2.0/types/basic/or_unknown.cmi \ utils/identifiable.cmi -middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo : \ - middle_end/flambda2.0/basic/expr_std.cmo \ - middle_end/flambda2.0/basic/code_id.cmi -middle_end/flambda2.0/types/basic/term_language_function_declaration.cmx : \ - middle_end/flambda2.0/basic/expr_std.cmx \ - middle_end/flambda2.0/basic/code_id.cmx middle_end/flambda2.0/types/basic/unit.cmo : \ middle_end/flambda2.0/naming/name_occurrences.cmi \ utils/identifiable.cmi \ @@ -9010,6 +9191,7 @@ middle_end/flambda2.0/types/env/typing_env.rec.cmo : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmi \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmi \ middle_end/flambda2.0/basic/export_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ utils/clflags.cmi \ middle_end/flambda2.0/types/env/binding_time.cmi \ middle_end/flambda2.0/types/env/aliases.cmi \ @@ -9033,6 +9215,7 @@ middle_end/flambda2.0/types/env/typing_env.rec.cmx : \ middle_end/flambda2.0/types/kinds/flambda_kind.cmx \ middle_end/flambda2.0/compilenv_deps/flambda_colours.cmx \ middle_end/flambda2.0/basic/export_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ utils/clflags.cmx \ middle_end/flambda2.0/types/env/binding_time.cmx \ middle_end/flambda2.0/types/env/aliases.cmx \ @@ -9052,6 +9235,8 @@ middle_end/flambda2.0/types/env/typing_env.rec.cmi : \ middle_end/flambda2.0/basic/export_id.cmi \ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmi \ middle_end/flambda2.0/basic/continuation_extra_params_and_args.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi middle_end/flambda2.0/types/env/typing_env_extension.rec.cmo : \ middle_end/flambda2.0/naming/name_abstraction.cmi \ @@ -9158,61 +9343,78 @@ middle_end/flambda2.0/types/kinds/flambda_kind.cmi : \ middle_end/flambda2.0/basic/immediate.cmi \ utils/identifiable.cmi middle_end/flambda2.0/types/structures/closures_entry.rec.cmo : \ - middle_end/flambda2.0/compilenv_deps/variable.cmi \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo \ - middle_end/flambda2.0/basic/recursive.cmi \ utils/printing_cache.cmi \ - middle_end/flambda2.0/types/basic/or_unknown.cmi \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi \ middle_end/flambda2.0/types/basic/or_bottom.cmi \ middle_end/flambda2.0/naming/name_occurrences.cmi \ - utils/misc.cmi \ middle_end/flambda2.0/types/structures/lattice_ops_intf.cmo \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ - middle_end/flambda2.0/basic/code_id.cmi \ middle_end/flambda2.0/basic/closure_id.cmi \ - middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmi \ middle_end/flambda2.0/types/structures/closures_entry.rec.cmi middle_end/flambda2.0/types/structures/closures_entry.rec.cmx : \ - middle_end/flambda2.0/compilenv_deps/variable.cmx \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmx \ - middle_end/flambda2.0/basic/recursive.cmx \ utils/printing_cache.cmx \ - middle_end/flambda2.0/types/basic/or_unknown.cmx \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmx \ middle_end/flambda2.0/types/basic/or_bottom.cmx \ middle_end/flambda2.0/naming/name_occurrences.cmx \ - utils/misc.cmx \ middle_end/flambda2.0/types/structures/lattice_ops_intf.cmx \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ - middle_end/flambda2.0/basic/code_id.cmx \ middle_end/flambda2.0/basic/closure_id.cmx \ - middle_end/flambda2.0/basic/apply_cont_rewrite_id.cmx \ middle_end/flambda2.0/types/structures/closures_entry.rec.cmi middle_end/flambda2.0/types/structures/closures_entry.rec.cmi : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ middle_end/flambda2.0/types/structures/type_structure_intf.cmo \ - middle_end/flambda2.0/types/basic/or_unknown.cmi \ middle_end/flambda2.0/types/basic/or_bottom.cmi \ middle_end/flambda2.0/basic/closure_id.cmi +middle_end/flambda2.0/types/structures/code_age_relation.cmo : \ + middle_end/flambda2.0/types/basic/or_unknown.cmi \ + middle_end/flambda2.0/types/basic/or_bottom.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi +middle_end/flambda2.0/types/structures/code_age_relation.cmx : \ + middle_end/flambda2.0/types/basic/or_unknown.cmx \ + middle_end/flambda2.0/types/basic/or_bottom.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi +middle_end/flambda2.0/types/structures/code_age_relation.cmi : \ + middle_end/flambda2.0/types/basic/or_unknown.cmi \ + middle_end/flambda2.0/types/basic/or_bottom.cmi \ + middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/types/structures/function_declaration_type.rec.cmo : \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo \ middle_end/flambda2.0/basic/recursive.cmi \ middle_end/flambda2.0/inlining/rec_info.cmi \ - utils/printing_cache.cmi \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi \ + middle_end/flambda2.0/types/basic/or_bottom.cmi \ + middle_end/flambda2.0/naming/name_occurrences.cmi \ + middle_end/flambda2.0/naming/name_mode.cmi \ + middle_end/flambda2.0/types/structures/lattice_ops_intf.cmo \ + middle_end/flambda2.0/basic/inline_attribute.cmi \ middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda2.0/basic/code_id.cmi \ + middle_end/flambda2.0/types/structures/code_age_relation.cmi \ middle_end/flambda2.0/types/structures/function_declaration_type.rec.cmi middle_end/flambda2.0/types/structures/function_declaration_type.rec.cmx : \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmx \ middle_end/flambda2.0/basic/recursive.cmx \ middle_end/flambda2.0/inlining/rec_info.cmx \ - utils/printing_cache.cmx \ + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmx \ + middle_end/flambda2.0/types/basic/or_bottom.cmx \ + middle_end/flambda2.0/naming/name_occurrences.cmx \ + middle_end/flambda2.0/naming/name_mode.cmx \ + middle_end/flambda2.0/types/structures/lattice_ops_intf.cmx \ + middle_end/flambda2.0/basic/inline_attribute.cmx \ middle_end/flambda2.0/types/kinds/flambda_arity.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda2.0/basic/code_id.cmx \ + middle_end/flambda2.0/types/structures/code_age_relation.cmx \ middle_end/flambda2.0/types/structures/function_declaration_type.rec.cmi middle_end/flambda2.0/types/structures/function_declaration_type.rec.cmi : \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo \ + middle_end/flambda2.0/types/structures/type_structure_intf.cmo \ middle_end/flambda2.0/basic/recursive.cmi \ middle_end/flambda2.0/inlining/rec_info.cmi \ - utils/printing_cache.cmi \ - middle_end/flambda2.0/types/kinds/flambda_arity.cmi + middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmi \ + middle_end/flambda2.0/types/basic/or_bottom.cmi \ + middle_end/flambda2.0/basic/inline_attribute.cmi \ + middle_end/flambda2.0/types/kinds/flambda_arity.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda2.0/basic/code_id.cmi middle_end/flambda2.0/types/structures/lattice_ops.rec.cmo : \ middle_end/flambda2.0/basic/var_within_closure.cmi \ utils/targetint.cmi \ @@ -9609,14 +9811,6 @@ middle_end/flambda2.0/utils/monad.cmo : \ middle_end/flambda2.0/utils/monad.cmx : \ middle_end/flambda2.0/utils/monad.cmi middle_end/flambda2.0/utils/monad.cmi : -middle_end/flambda2.0/utils/top_closure.cmo : \ - middle_end/flambda2.0/utils/monad.cmi \ - middle_end/flambda2.0/utils/top_closure.cmi -middle_end/flambda2.0/utils/top_closure.cmx : \ - middle_end/flambda2.0/utils/monad.cmx \ - middle_end/flambda2.0/utils/top_closure.cmi -middle_end/flambda2.0/utils/top_closure.cmi : \ - middle_end/flambda2.0/utils/monad.cmi driver/compenv.cmo : \ utils/warnings.cmi \ utils/profile.cmi \ @@ -9748,18 +9942,28 @@ driver/errors.cmx : \ driver/errors.cmi driver/errors.cmi : driver/ilambdac.cmo : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmi \ asmcomp/proc.cmi \ typing/predef.cmi \ + middle_end/flambda2.0/parser/parse_ilambda.cmo \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmi \ typing/ident.cmi \ + middle_end/flambda2.0/flambda2_backend_intf.cmi \ middle_end/compilenv.cmi \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmi \ utils/clflags.cmi \ asmcomp/asmgen.cmi \ asmcomp/arch.cmo driver/ilambdac.cmx : \ + middle_end/flambda2.0/compilenv_deps/symbol.cmx \ asmcomp/proc.cmx \ typing/predef.cmx \ + middle_end/flambda2.0/parser/parse_ilambda.cmx \ + middle_end/flambda2.0/compilenv_deps/linkage_name.cmx \ typing/ident.cmx \ + middle_end/flambda2.0/flambda2_backend_intf.cmi \ middle_end/compilenv.cmx \ + middle_end/flambda2.0/compilenv_deps/compilation_unit.cmx \ utils/clflags.cmx \ asmcomp/asmgen.cmx \ asmcomp/arch.cmx diff --git a/.gitignore b/.gitignore index e9f6682fa5f5..91d44a59a1cb 100644 --- a/.gitignore +++ b/.gitignore @@ -94,7 +94,7 @@ _build middle_end/flambda2.0/simplify/simplify.ml middle_end/flambda2.0/terms/flambda.ml -middle_end/flambda2.0/types/flambda_type0.ml +middle_end/flambda2.0/types/flambda_type.ml /ocamldoc/ocamldoc /ocamldoc/ocamldoc.opt diff --git a/Makefile b/Makefile index 0f0a052cf16d..245fefbdd8e8 100644 --- a/Makefile +++ b/Makefile @@ -46,6 +46,7 @@ INCLUDES=-I utils -I parsing -I typing -I bytecomp -I file_formats \ -I middle_end/flambda2.0/basic \ -I middle_end/flambda2.0/from_lambda \ -I middle_end/flambda2.0/inlining \ + -I middle_end/flambda2.0/lifting \ -I middle_end/flambda2.0/naming \ -I middle_end/flambda2.0/parser \ -I middle_end/flambda2.0/simplify \ @@ -172,7 +173,9 @@ endif ASMCOMP_FLAMBDA2=\ middle_end/flambda2.0/to_cmm/un_cps_helper.cmo \ middle_end/flambda2.0/to_cmm/un_cps_closure.cmo \ + middle_end/flambda2.0/to_cmm/un_cps_result.cmo \ middle_end/flambda2.0/to_cmm/un_cps_env.cmo \ + middle_end/flambda2.0/to_cmm/un_cps_static.cmo \ middle_end/flambda2.0/to_cmm/un_cps.cmo ASMCOMP=\ @@ -227,13 +230,14 @@ MIDDLE_END_FLAMBDA2_COMPILENV_DEPS=\ middle_end/flambda2.0/compilenv_deps/symbol.cmo MIDDLE_END_FLAMBDA2_BASIC=\ - middle_end/flambda2.0/basic/closure_element.cmo \ + middle_end/flambda2.0/basic/id_types.cmo \ middle_end/flambda2.0/basic/continuation.cmo \ middle_end/flambda2.0/basic/name.cmo \ middle_end/flambda2.0/basic/var_within_closure.cmo \ middle_end/flambda2.0/naming/name_mode.cmo \ middle_end/flambda2.0/naming/permutation.cmo \ middle_end/flambda2.0/naming/name_permutation.cmo \ + middle_end/flambda2.0/basic/code_id.cmo \ middle_end/flambda2.0/naming/name_occurrences.cmo \ middle_end/flambda2.0/basic/immediate.cmo \ middle_end/flambda2.0/types/kinds/flambda_kind.cmo \ @@ -247,8 +251,7 @@ MIDDLE_END_FLAMBDA2_BASIC=\ middle_end/flambda2.0/basic/trap_action.cmo \ middle_end/flambda2.0/basic/exn_continuation.cmo \ middle_end/flambda2.0/basic/inline_attribute.cmo \ - middle_end/flambda2.0/basic/id_types.cmo \ - middle_end/flambda2.0/basic/code_id.cmo \ + middle_end/flambda2.0/basic/code_id_or_symbol.cmo \ middle_end/flambda2.0/basic/coeffects.cmo \ middle_end/flambda2.0/basic/effects.cmo \ middle_end/flambda2.0/basic/export_id.cmo \ @@ -291,17 +294,16 @@ MIDDLE_END_FLAMBDA2_TYPES=\ middle_end/flambda2.0/types/basic/or_bottom_or_absorbing.cmo \ middle_end/flambda2.0/types/basic/or_unknown.cmo \ middle_end/flambda2.0/types/basic/or_unknown_or_bottom.cmo \ + middle_end/flambda2.0/types/structures/code_age_relation.cmo \ middle_end/flambda2.0/types/structures/type_structure_intf.cmo \ middle_end/flambda2.0/types/structures/product_intf.cmo \ middle_end/flambda2.0/types/structures/row_like_maps_to_intf.cmo \ middle_end/flambda2.0/types/structures/set_of_closures_contents.cmo \ middle_end/flambda2.0/types/basic/tag_and_size.cmo \ middle_end/flambda2.0/types/basic/tag_or_unknown_and_size.cmo \ - middle_end/flambda2.0/types/basic/term_language_function_declaration.cmo \ middle_end/flambda2.0/types/type_descr_intf.cmo \ middle_end/flambda2.0/types/type_head_intf.cmo \ - middle_end/flambda2.0/types/flambda_type0.cmo \ - middle_end/flambda2.0/types/type_system_intf.cmo \ + middle_end/flambda2.0/types/flambda_type.cmo \ middle_end/flambda2.0/types/basic/unit.cmo \ middle_end/flambda2.0/types/basic/or_absorbing.cmo \ middle_end/flambda2.0/types/basic/closure_id_set.cmo \ @@ -312,10 +314,13 @@ MIDDLE_END_FLAMBDA2_TERMS=\ middle_end/flambda2.0/terms/apply_cont_expr.cmo \ middle_end/flambda2.0/terms/call_kind.cmo \ middle_end/flambda2.0/terms/apply_expr.cmo \ + middle_end/flambda2.0/terms/function_declaration.cmo \ + middle_end/flambda2.0/terms/function_declarations.cmo \ + middle_end/flambda2.0/terms/set_of_closures.cmo \ middle_end/flambda2.0/terms/switch_expr.cmo \ + middle_end/flambda2.0/types/flambda_type.cmo \ middle_end/flambda2.0/terms/flambda.cmo \ - middle_end/flambda2.0/terms/flambda_static.cmo \ - middle_end/flambda2.0/types/flambda_type.cmo + middle_end/flambda2.0/terms/flambda_unit.cmo MIDDLE_END_FLAMBDA2_SIMPLIFY=\ middle_end/flambda2.0/simplify/env/continuation_use_kind.cmo \ @@ -330,12 +335,10 @@ MIDDLE_END_FLAMBDA2_SIMPLIFY=\ middle_end/flambda2.0/simplify/env/simplify_env_and_result.cmo \ middle_end/flambda2.0/simplify/env/downwards_acc.cmo \ middle_end/flambda2.0/simplify/env/upwards_acc.cmo \ - middle_end/flambda2.0/inlining/inlining_cost.cmo \ - middle_end/flambda2.0/inlining/inlining_decision.cmo \ - middle_end/flambda2.0/inlining/inlining_transforms.cmo \ middle_end/flambda2.0/simplify/simplify_simple.cmo \ middle_end/flambda2.0/simplify/simplify_import.cmo \ middle_end/flambda2.0/unboxing/unbox_continuation_params.cmo \ + middle_end/flambda2.0/lifting/sort_lifted_constants.cmo \ middle_end/flambda2.0/simplify/basic/reachable.cmo \ middle_end/flambda2.0/simplify/simplify_common.cmo \ middle_end/flambda2.0/simplify/simplify_variadic_primitive.cmo \ @@ -344,10 +347,13 @@ MIDDLE_END_FLAMBDA2_SIMPLIFY=\ middle_end/flambda2.0/simplify/simplify_ternary_primitive.cmo \ middle_end/flambda2.0/simplify/simplify_binary_primitive.cmo \ middle_end/flambda2.0/simplify/simplify_primitive.cmo \ + middle_end/flambda2.0/inlining/inlining_cost.cmo \ + middle_end/flambda2.0/inlining/inlining_decision.cmo \ + middle_end/flambda2.0/inlining/inlining_transforms.cmo \ + middle_end/flambda2.0/lifting/reification.cmo \ + middle_end/flambda2.0/lifting/reify_continuation_param_types.cmo \ middle_end/flambda2.0/simplify/typing_helpers/continuation_handler_like_intf.cmo \ - middle_end/flambda2.0/simplify/typing_helpers/reification.cmo \ middle_end/flambda2.0/utils/monad.cmo \ - middle_end/flambda2.0/utils/top_closure.cmo \ middle_end/flambda2.0/simplify/simplify.cmo MIDDLE_END_FLAMBDA2_FROM_LAMBDA=\ @@ -1281,15 +1287,15 @@ partialclean:: # Flambda2 recursive modules black magic -FLAMBDA_TYPE0_DEPS=$(shell sed "s|^|middle_end/flambda2.0/types/|g" \ +FLAMBDA_TYPE_DEPS=$(shell sed "s|^|middle_end/flambda2.0/types/|g" \ middle_end/flambda2.0/types/rec_modules | tr '\n' ' ') -middle_end/flambda2.0/types/flambda_type0.ml: \ - middle_end/flambda2.0/types/template/flambda_type0.templ.ml \ +middle_end/flambda2.0/types/flambda_type.ml: \ + middle_end/flambda2.0/types/template/flambda_type.templ.ml \ middle_end/flambda2.0/types/rec_modules \ - $(FLAMBDA_TYPE0_DEPS) + $(FLAMBDA_TYPE_DEPS) cd middle_end/flambda2.0/types && \ - ../scripts/assemble_rec_modules.sh template/flambda_type0.templ.ml \ - rec_modules flambda_type0.ml + ../scripts/assemble_rec_modules.sh template/flambda_type.templ.ml \ + rec_modules flambda_type.ml FLAMBDA_DEPS=$(shell sed "s|^|middle_end/flambda2.0/terms/|g" \ middle_end/flambda2.0/terms/rec_modules | tr '\n' ' ') @@ -1312,7 +1318,7 @@ middle_end/flambda2.0/simplify/simplify.ml: \ rec_modules simplify.ml beforedepend:: \ - middle_end/flambda2.0/types/flambda_type0.ml \ + middle_end/flambda2.0/types/flambda_type.ml \ middle_end/flambda2.0/terms/flambda.ml \ middle_end/flambda2.0/simplify/simplify.ml @@ -1516,6 +1522,7 @@ partialclean:: middle_end/flambda2.0/basic \ middle_end/flambda2.0/from_lambda \ middle_end/flambda2.0/inlining \ + middle_end/flambda2.0/lifting \ middle_end/flambda2.0/naming \ middle_end/flambda2.0/parser \ middle_end/flambda2.0/simplify \ @@ -1548,6 +1555,7 @@ depend: beforedepend middle_end/flambda2.0/basic \ middle_end/flambda2.0/from_lambda \ middle_end/flambda2.0/inlining \ + middle_end/flambda2.0/lifting \ middle_end/flambda2.0/naming \ middle_end/flambda2.0/parser \ middle_end/flambda2.0/simplify \